From 2b72dfd5734c5226524258d35ee7bdff979e0a27 Mon Sep 17 00:00:00 2001
From: dtc <dtc>
Date: Sat, 9 Jan 1999 11:20:30 +0000
Subject: [PATCH] Patches from Raymond Toy: 1. Fix up a comment bug for
 translate-directories 2. Give a better implementation of enough-namestring

---
 code/pathname.lisp | 38 ++++++++++++++++++++++++++++++++++----
 1 file changed, 34 insertions(+), 4 deletions(-)

diff --git a/code/pathname.lisp b/code/pathname.lisp
index 9593f8f20..69626e47d 100644
--- a/code/pathname.lisp
+++ b/code/pathname.lisp
@@ -4,7 +4,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pathname.lisp,v 1.35 1998/12/29 17:55:51 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pathname.lisp,v 1.36 1999/01/09 11:20:30 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -63,7 +63,7 @@
 		       #'(lambda (x) (logical-host-name (%pathname-host x))))
 		      (:unparse-directory #'unparse-logical-directory)
 		      (:unparse-file #'unparse-unix-file)
-		      (:unparse-enough #'identity)
+		      (:unparse-enough #'unparse-enough-namestring)
 		      (:customary-case :upper)))
   (name "" :type simple-base-string)
   (translations nil :type list)
@@ -1151,8 +1151,8 @@ a host-structure or string."
 ;;;    Called by TRANSLATE-PATHNAME on the directory components of its argument
 ;;; pathanames to produce the result directory component.  If any leaves the
 ;;; directory NIL, we return the source directory.  The :RELATIVE or :ABSOLUTE
-;;; is always taken from the source directory. If TO is :absolute, the result
-;;; will be :absolute
+;;; is taken from the source directory, except if TO is :ABSOLUTE, in which
+;;; case the result will be :ABSOLUTE.
 ;;;
 (defun translate-directories (source from to diddle-case)
   (if (not (and source to from))
@@ -1712,6 +1712,36 @@ a host-structure or string."
 		  (t (error "Invalid keyword: ~S" piece))))))
        (apply #'concatenate 'simple-string (strings))))))
 
+;;; UNPARSE-ENOUGH-NAMESTRING -- Internal
+;;;
+(defun unparse-enough-namestring (pathname defaults)
+  (let* ((path-dir (pathname-directory pathname))
+        (def-dir (pathname-directory defaults))
+        (enough-dir
+         ;; Go down the directory lists to see what matches.  What's
+         ;; left is what we want, more or less.
+         (cond ((and (eq (first path-dir) (first def-dir))
+                     (eq (first path-dir) :absolute))
+                ;; Both paths are :absolute, so find where the common
+                ;; parts end and return what's left
+                (do* ((p (rest path-dir) (rest p))
+                      (d (rest def-dir) (rest d)))
+                     ((or (endp p) (endp d)
+                          (not (equal (first p) (first d))))
+                      `(:relative ,@p))))
+               (t
+                ;; At least one path is :relative, so just return the
+                ;; original path.  If the original path is :relative,
+                ;; then that's the right one.  If PATH-DIR is
+                ;; :absolute, we want to return that except when
+                ;; DEF-DIR is :absolute, as handled above. so return
+                ;; the original directory.
+                path-dir))))
+    (make-pathname :host (pathname-host pathname)
+                  :directory enough-dir
+                  :name (pathname-name pathname)
+                  :type (pathname-type pathname)
+                  :version (pathname-version pathname))))
 
 ;;; UNPARSE-LOGICAL-NAMESTRING -- Internal
 ;;;
-- 
GitLab