contrib/asdf: Import asdf 2.20 from upstream.

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

diff --git a/contrib/sb-cover/cover.lisp b/contrib/sb-cover/cover.lisp
index d697492..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