Changed to use ENOUGH-PATHNAME for reporting the file names. The
authorStephen Adams <edu/mit/csail/zurich/adams>
Sat, 29 Jul 1995 16:55:56 +0000 (16:55 +0000)
committerStephen Adams <edu/mit/csail/zurich/adams>
Sat, 29 Jul 1995 16:55:56 +0000 (16:55 +0000)
previous version was using the pathname-directory list and losing
information.  There was also a #F/() bug in this code.

v7/src/rcs/logmer.scm

index 5d2af8520ec49b24a6af1409c2b9a2580f886c4f..24381cdb58ffbb713a3f34e257a27f0aa01a1d0b 100644 (file)
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: logmer.scm,v 1.5 1992/11/05 20:51:41 cph Exp $
+$Id: logmer.scm,v 1.6 1995/07/29 16:55:56 adams Exp $
 
 Copyright (c) 1988-92 Massachusetts Institute of Technology
 
@@ -117,27 +117,25 @@ MIT in each case. |#
                                entries*))))))))
 \f
 (define (read-entries pathnames)
-  (append-map! (let ((prefix (length (greatest-common-prefix pathnames))))
-                (lambda (pathname)
+  (let ((prefix (greatest-common-prefix pathnames)))
+    (append-map! (lambda (pathname)
                   (map (let ((filename (working-file-string pathname prefix)))
                          (lambda (delta)
                            (cons delta filename)))
-                       (read-file pathname))))
-              pathnames))
+                       (read-file pathname)))
+                pathnames)))
 
 (define (working-file-string pathname prefix)
-  (let ((filename
-        (->namestring
-         (pathname-new-directory
-          pathname
-          (let ((directory (list-tail (pathname-directory pathname) prefix)))
-            (if (and (not (null? directory))
-                     (equal? (car (last-pair directory)) "RCS"))
-                (except-last-pair directory)
-                directory))))))
+  (let ((relative-pathname (enough-pathname pathname prefix)))
+    (let ((filename
+          (->namestring
+           (pathname-new-directory
+            relative-pathname
+            (let ((directory (pathname-directory relative-pathname)))
+              (and directory (delete "RCS" directory)))))))
     (if (string-suffix? ",v" filename)
        (substring filename 0 (- (string-length filename) 2))
-       filename)))
+       filename))))
 
 (define (sort-entries entries)
   (sort entries
@@ -185,7 +183,7 @@ MIT in each case. |#
 
 (define (greatest-common-prefix pathnames)
   (if (null? pathnames)
-      '()
+      (->pathname "")
       (let ((prefix 'NONE))
        (for-each (lambda (pathname)
                    (let ((directory (pathname-directory pathname)))
@@ -201,6 +199,4 @@ MIT in each case. |#
                                            (common-prefix (cdr x)
                                                           (cdr y)))))))))
                  pathnames)
-       (if (equal? prefix '(ABSOLUTE))
-           '()
-           prefix))))
\ No newline at end of file
+       (pathname-new-directory "" prefix))))
\ No newline at end of file