1.0.8.13: .cvsignore test output.

[sbcl.git] / contrib / sb-cover / cover.lisp

diff --git a/contrib/sb-cover/cover.lisp b/contrib/sb-cover/cover.lisp
index a4eb33b..c507289 100644 (file)
--- a/contrib/sb-cover/cover.lisp
+++ b/contrib/sb-cover/cover.lisp
@@ -9,6 +9,8 @@
   (: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)
@@ -29,6 +31,51 @@ image."
   "Reset all coverage data back to the `Not executed` state."
   (sb-c::reset-code-coverage))
 
+(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 report (directory &key (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
@@ -138,16 +185,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))
@@ -174,10 +222,18 @@ 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.
+        (dolist (location (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)