X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-cover%2Fcover.lisp;h=28ead428e959f2424e13aad7068c7392d1b91a62;hb=d720bc359f03734ccb9baf66cb45dc01d623f369;hp=bcaebfa27bcb18b7fb49e3428961e43bae5ef991;hpb=49e92ee57b3b01f5862d0c6fa65f521de1688941;p=sbcl.git diff --git a/contrib/sb-cover/cover.lisp b/contrib/sb-cover/cover.lisp index bcaebfa..28ead42 100644 --- a/contrib/sb-cover/cover.lisp +++ b/contrib/sb-cover/cover.lisp @@ -9,10 +9,15 @@ (:use #:cl #:sb-c) (:export #:report #:reset-coverage #:clear-coverage + #:restore-coverage #:restore-coverage-from-file + #:save-coverage #:save-coverage-in-file #:store-coverage-data)) (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) @@ -29,17 +34,85 @@ image." "Reset all coverage data back to the `Not executed` state." (sb-c::reset-code-coverage)) -(defun report (directory &key (external-format :default)) +(defun save-coverage () + "Returns an opaque representation of the current code coverage state. +The only operation that may be done on the state is passing it to +RESTORE-COVERAGE. The representation is guaranteed to be readably printable. +A representation that has been printed and read back will work identically +in RESTORE-COVERAGE." + (loop for file being the hash-keys of sb-c::*code-coverage-info* + using (hash-value states) + collect (cons file states))) + +(defun restore-coverage (coverage-state) + "Restore the code coverage data back to an earlier state produced by +SAVE-COVERAGE." + (loop for (file . states) in coverage-state + do (let ((image-states (gethash file sb-c::*code-coverage-info*)) + (table (make-hash-table :test 'equal))) + (when image-states + (loop for cons in image-states + do (setf (gethash (car cons) table) cons)) + (loop for (key . value) in states + do (let ((state (gethash key table))) + (when state + (setf (cdr state) value)))))))) + +(defun save-coverage-in-file (pathname) + "Call SAVE-COVERAGE and write the results of that operation into the +file designated by PATHNAME." + (with-open-file (stream pathname + :direction :output + :if-exists :supersede + :if-does-not-exist :create) + (with-standard-io-syntax + (let ((*package* (find-package :sb-cover))) + (write (save-coverage) :stream stream))) + (values))) + +(defun restore-coverage-from-file (pathname) + "READ the contents of the file designated by PATHNAME and pass the +result to RESTORE-COVERAGE." + (with-open-file (stream pathname :direction :input) + (with-standard-io-syntax + (let ((*package* (find-package :sb-cover))) + (restore-coverage (read stream)))) + (values))) + +(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 @@ -113,13 +186,16 @@ files can be specified with the EXTERNAL-FORMAT parameter." (loop with map = nil with form = nil with eof = nil + for i from 0 do (setf (values form map) (handler-case (read-and-record-source-map stream) (end-of-file () (setf eof t)) - (error () - (values nil nil)))) + (error (error) + (warn "Error when recording source map for toplevel form ~A:~% ~A" i error) + (values nil + (make-hash-table))))) until eof when map collect (cons form map))))) @@ -135,16 +211,17 @@ files can be specified with the EXTERNAL-FORMAT parameter." maps) ;; Go through all records, find the matching source in the file, ;; and update STATES to contain the state of the record in the - ;; indexes matching the source location. Process the longest paths - ;; first, so that the state of each index will reflect the state - ;; of the innermost containing form. Processes branch-records - ;; before expr-records of the same length, for the same reason. + ;; indexes matching the source location. We do this in two stages: + ;; the first stage records the character ranges, and the second stage + ;; does the update, in order from shortest to longest ranges. This + ;; ensures that for each index in STATES will reflect the state of + ;; the innermost containing form. (let ((counts (list :branch (make-instance 'sample-count :mode :branch) :expression (make-instance 'sample-count :mode :expression)))) - (let ((records (append branch-records expr-records))) - (dolist (record (stable-sort records #'> - :key (lambda (e) (length (second e))))) + (let ((records (append branch-records expr-records)) + (locations nil)) + (dolist (record records) (destructuring-bind (mode path state) record (let* ((path (reverse path)) (tlf (car path)) @@ -171,10 +248,22 @@ files can be specified with the EXTERNAL-FORMAT parameter." (source-path-source-position (cons 0 source-path) source-form source-map) - (fill-with-state source states state start end)) + (push (list start end source state) locations)) (error () (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)))))) + (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. 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) (format html-stream "") (list (getf counts :expression) @@ -317,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) @@ -327,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) @@ -400,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) @@ -418,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) @@ -427,12 +516,10 @@ The source locations are stored in SOURCE-MAP." (defun suppress-sharp-dot (readtable) (when (get-macro-character #\# readtable) (let ((sharp-dot (get-dispatch-macro-character #\# #\. readtable))) - (set-dispatch-macro-character #\# #\. (lambda (&rest args) - (let ((*read-suppress* t)) - (apply sharp-dot args)) - (if *read-suppress* - (values) - (list (gensym "#.")))) + (set-dispatch-macro-character #\# #\. + (lambda (&rest args) + (let ((*read-suppress* t)) + (apply sharp-dot args))) readtable)))) (defun read-and-record-source-map (stream) @@ -486,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