X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-cover%2Fcover.lisp;h=957954b74cdffa9ca2d96e607a2d92f993b7662e;hb=260de2062fca170efdac3e42491d7d866c2d2e56;hp=c507289c10a8c6f092fde77faf14bd479077c3ca;hpb=8e85b1cc727995b411bd5ab28beaeae42271a760;p=sbcl.git diff --git a/contrib/sb-cover/cover.lisp b/contrib/sb-cover/cover.lisp index c507289..957954b 100644 --- a/contrib/sb-cover/cover.lisp +++ b/contrib/sb-cover/cover.lisp @@ -15,6 +15,9 @@ (in-package #:sb-cover) +(declaim (type (member :whole :car) *source-path-mode*)) +(defvar *source-path-mode* :whole) + (defclass sample-count () ((mode :accessor mode-of :initarg :mode) (all :accessor all-of :initform 0) @@ -76,19 +79,45 @@ result to RESTORE-COVERAGE." (restore-coverage (read stream)))) (values))) -(defun report (directory &key (external-format :default)) +(defun pathname-as-directory (pathname &optional (errorp t)) + (let ((pathname (merge-pathnames pathname))) + (if (and (member (pathname-name pathname) '(nil :unspecific)) + (member (pathname-type pathname) '(nil :unspecific))) + pathname + (if errorp + (error "~S does not designate a directory" pathname) + (make-pathname :directory (append (or (pathname-directory pathname) + (list :relative)) + (list (file-namestring pathname))) + :name nil :type nil :version nil + :defaults pathname))))) + +(defun report (directory &key ((:form-mode *source-path-mode*) :whole) + (external-format :default)) "Print a code coverage report of all instrumented files into DIRECTORY. If DIRECTORY does not exist, it will be created. The main report will be printed to the file cover-index.html. The external format of the source -files can be specified with the EXTERNAL-FORMAT parameter." - (let ((paths) - (*default-pathname-defaults* (merge-pathnames (pathname directory)))) +files can be specified with the EXTERNAL-FORMAT parameter. + +If the keyword argument FORM-MODE has the value :CAR, the annotations in +the coverage report will be placed on the CARs of any cons-forms, while if +it has the value :WHOLE the whole form will be annotated (the default). +The former mode shows explicitly which forms were instrumented, while the +latter mode is generally easier to read." + (let* ((paths) + (directory (pathname-as-directory directory)) + (*default-pathname-defaults* (translate-logical-pathname directory))) (ensure-directories-exist *default-pathname-defaults*) (maphash (lambda (k v) (declare (ignore v)) - (let* ((n (substitute #\_ #\. (substitute #\_ #\/ k))) - (path (make-pathname :name n :type "html"))) + (let* ((pk (translate-logical-pathname k)) + (n (format nil "~(~{~2,'0X~}~)" + (coerce (sb-md5:md5sum-string + (sb-ext:native-namestring pk)) + 'list))) + (path (make-pathname :name n :type "html" :defaults directory))) (when (probe-file k) + (ensure-directories-exist pk) (with-open-file (stream path :direction :output :if-exists :supersede @@ -96,7 +125,7 @@ files can be specified with the EXTERNAL-FORMAT parameter." (push (list* k n (report-file k stream external-format)) paths))))) *code-coverage-info*) - (let ((report-file (make-pathname :name "cover-index" :type "html"))) + (let ((report-file (make-pathname :name "cover-index" :type "html" :defaults directory))) (with-open-file (stream report-file :direction :output :if-exists :supersede :if-does-not-exist :create) @@ -227,11 +256,15 @@ files can be specified with the EXTERNAL-FORMAT parameter." (warn "Error finding source location for source path ~A in file ~A~%" source-path file))) (warn "Unable to find a source map for toplevel form ~A in file ~A~%" tlf file))))) ;; Now process the locations, from the shortest range to the longest - ;; one. - (dolist (location (sort locations #'< - :key (lambda (location) - (- (second location) - (first location))))) + ;; one. If two locations have the same range, the one with the higher + ;; state takes precedence. The latter condition ensures that if + ;; there are both normal- and a branch-states for the same form, + ;; the branch-state will be used. + (setf locations (sort locations #'> :key #'fourth)) + (dolist (location (stable-sort locations #'< + :key (lambda (location) + (- (second location) + (first location))))) (destructuring-bind (start end source state) location (fill-with-state source states state start end)))) (print-report html-stream file counts states source) @@ -376,9 +409,9 @@ table.summary tr.subheading td { text-align: left; font-weight: bold; padding-le unless (member (caar record) '(:then :else)) collect (list mode (car record) - (ecase (cdr record) - ((t) 1) - ((nil) 2))))) + (if (sb-c::code-coverage-record-marked record) + 1 + 2)))) (:branch (let ((hash (make-hash-table :test 'equal))) (dolist (record records) @@ -386,7 +419,7 @@ table.summary tr.subheading td { text-align: left; font-weight: bold; padding-le (when (member (car path) '(:then :else)) (setf (gethash (cdr path) hash) (logior (gethash (cdr path) hash 0) - (ash (if (cdr record) + (ash (if (sb-c::code-coverage-record-marked record) 1 2) (if (eql (car path) :then) @@ -459,7 +492,7 @@ The source locations are stored in SOURCE-MAP." (cond ((sb-impl::token-delimiterp nextchar) (cond ((eq listtail thelist) (unless *read-suppress* - (sb-impl::%reader-error + (sb-int:simple-reader-error stream "Nothing appears before . in list."))) ((sb-impl::whitespace[2]p nextchar) @@ -477,7 +510,7 @@ The source locations are stored in SOURCE-MAP." ;; allows the possibility that a comment was read (when listobj (unless (consp (car listobj)) - (setf (car listobj) (gensym)) + (setf (car listobj) (gensym)) (push (list start end *read-suppress*) (gethash (car listobj) source-map))) (rplacd listtail listobj) @@ -543,15 +576,15 @@ subforms along the path are considered and the start and end position of the deepest (i.e. smallest) possible form is returned." ;; compute all subforms along path (let ((forms (loop for n in path - for m on path - for dummy = (when (eql n :progn) - (return forms)) for f = form then (nth n f) - unless (null (cdr m)) collect f into forms finally (return forms)))) ;; select the first subform present in source-map - (loop for form in (reverse forms) + (loop for real-form in (reverse forms) + for form = (if (or (eql *source-path-mode* :whole) + (not (consp real-form))) + real-form + (car real-form)) for positions = (gethash form source-map) until (and positions (null (cdr positions))) finally (destructuring-bind ((start end suppress)) positions