Only try frlock.1 test on #+sb-thread

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

diff --git a/contrib/sb-cover/cover.lisp b/contrib/sb-cover/cover.lisp
index 03ac9da..28ead42 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)))
 
         (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.
 (defun report (directory &key ((:form-mode *source-path-mode*) :whole)
                (external-format :default))
   "Print a code coverage report of all instrumented files into DIRECTORY.

@@ -92,11 +105,14 @@ 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)
 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))
     (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
                       (path (make-pathname :name n :type "html")))
                  (when (probe-file k)
                    (with-open-file (stream path

@@ -390,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)
            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)
     (:branch
      (let ((hash (make-hash-table :test 'equal)))
        (dolist (record records)

@@ -400,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)
            (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)
                                     1
                                     2)
                                 (if (eql (car path) :then)

@@ -473,7 +489,7 @@ The source locations are stored in SOURCE-MAP."
               (cond ((sb-impl::token-delimiterp nextchar)
                      (cond ((eq listtail thelist)
                             (unless *read-suppress*
               (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)
                                stream
                                "Nothing appears before . in list.")))
                            ((sb-impl::whitespace[2]p nextchar)