From: Stephen Adams <edu/mit/csail/zurich/adams>
Date: Sat, 29 Jul 1995 16:55:56 +0000 (+0000)
Subject: Changed to use ENOUGH-PATHNAME for reporting the file names.  The
X-Git-Tag: 20090517-FFI~6091
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=78c8882bdc8d79fc4cb65f036f11fc68d82dd6e8;p=mit-scheme.git

Changed to use ENOUGH-PATHNAME for reporting the file names.  The
previous version was using the pathname-directory list and losing
information.  There was also a #F/() bug in this code.
---

diff --git a/v7/src/rcs/logmer.scm b/v7/src/rcs/logmer.scm
index 5d2af8520..24381cdb5 100644
--- a/v7/src/rcs/logmer.scm
+++ b/v7/src/rcs/logmer.scm
@@ -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*))))))))
 
 (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