X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-cover%2Fcover.lisp;h=28ead428e959f2424e13aad7068c7392d1b91a62;hb=dcf7b5cbc859426d005b534f3fa273be5da0b64c;hp=c507289c10a8c6f092fde77faf14bd479077c3ca;hpb=8e85b1cc727995b411bd5ab28beaeae42271a760;p=sbcl.git diff --git a/contrib/sb-cover/cover.lisp b/contrib/sb-cover/cover.lisp index c507289..28ead42 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,17 +79,40 @@ 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 + :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." +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) - (*default-pathname-defaults* (merge-pathnames (pathname directory)))) + (*default-pathname-defaults* (pathname-as-directory directory))) (ensure-directories-exist *default-pathname-defaults*) (maphash (lambda (k v) (declare (ignore v)) - (let* ((n (substitute #\_ #\. (substitute #\_ #\/ k))) + (let* ((n (format nil "~(~{~2,'0X~}~)" + (coerce (sb-md5:md5sum-string + (sb-ext:native-namestring k)) + 'list))) (path (make-pathname :name n :type "html"))) (when (probe-file k) (with-open-file (stream path @@ -227,11 +253,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 +406,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 +416,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 +489,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 +507,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 +573,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