(: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)
"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
(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)))))
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))
(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 "</body></html>")
(list (getf counts :expression)
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)
(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)
(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)
;; 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)
(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)
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
projects / sbcl.git / blobdiff