#| -*-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
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
(define (greatest-common-prefix pathnames)
(if (null? pathnames)
- '()
+ (->pathname "")
(let ((prefix 'NONE))
(for-each (lambda (pathname)
(let ((directory (pathname-directory pathname)))
(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