Fix the cheneygc build

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

diff --git a/contrib/sb-cover/cover.lisp b/contrib/sb-cover/cover.lisp
index 03ac9da..957954b 100644 (file)
--- a/contrib/sb-cover/cover.lisp
+++ b/contrib/sb-cover/cover.lisp
@@ -79,6 +79,19 @@ result to RESTORE-COVERAGE."
         (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 :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.
@@ -91,14 +104,20 @@ 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))))
+  (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
@@ -106,7 +125,7 @@ latter mode is generally easier to read."
                      (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)
@@ -390,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)
@@ -400,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)
@@ -473,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)