From c33b7b7a45c3fa7f178b1fa660ab98a2de09598b Mon Sep 17 00:00:00 2001
From: rtoy <rtoy>
Date: Mon, 12 Sep 2005 14:38:17 +0000
Subject: [PATCH] Fix some issues with printing (make-pathname :directory
 '(:relative)), which used to print as #p"", and with reading #p".", #p"./".

code/filesys.lisp:
o When parsing a unix namestring, delete any "." elements of the
  directory list.
o If we've parsed a namestring such that the file name is ".", replace
  that with :name NIL and adjust the :directory component
  appropriately, because on Unix, "." can't be the name of a file.
o Make :directory '(:relative) be printed as "./"

code/pathname.lisp:
o If the :directory argument to MAKE-PATHNAME contains strings with
  #\/, print a warning that this is not a valid element.
o Remove all "."'s from a :relative directory component.
---
 code/filesys.lisp  | 23 ++++++++++++++++++-----
 code/pathname.lisp | 22 +++++++++++++++++++---
 2 files changed, 37 insertions(+), 8 deletions(-)

diff --git a/code/filesys.lisp b/code/filesys.lisp
index 8476d449c..2327cc0ac 100644
--- a/code/filesys.lisp
+++ b/code/filesys.lisp
@@ -6,7 +6,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/filesys.lisp,v 1.88 2005/08/31 13:57:08 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/filesys.lisp,v 1.89 2005/09/12 14:38:17 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -339,10 +339,21 @@
 		  (cond (absolute
 			 (cons :absolute (dirs)))
 			((dirs)
-			 (cons :relative (dirs)))
+			 ;; "." in a :relative directory is the same
+			 ;; as if it weren't there, so remove them.
+			 (cons :relative (delete "." (dirs) :test #'equal)))
 			(t
-			 nil)))
-		name
+			 ;; If there is no directory and the name is
+			 ;; ".", we really got directory ".", so make it so.
+			 (if (equal name ".")
+			     (list :relative)
+			 nil))))
+		;; A file with name "." can't be the name of file on
+		;; Unix because it's a directory.  This was handled
+		;; above, so we can just set the name to nil.
+		(if (equal name ".")
+		    nil
+		    name)
 		type
 		version)))))
 
@@ -415,7 +426,9 @@
 	       (t
 		(pieces "/"))))
 	(:relative
-	 ;; Nothing special.
+	 ;; Nothing special, except if we were given '(:relative).
+	 (unless directory
+	   (pieces "./"))
 	 ))
       (dolist (dir directory)
 	(typecase dir
diff --git a/code/pathname.lisp b/code/pathname.lisp
index 256b321fa..353cb34ba 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.73 2005/05/11 13:51:09 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pathname.lisp,v 1.74 2005/09/12 14:38:17 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -724,8 +724,24 @@ a host-structure or string."
 		     (warn "Silly argument for a unix ~A: ~S"
 			   name-or-type name)))))))
       (check-component-validity name :pathname-name)
-      (check-component-validity type :pathname-type))
-
+      (check-component-validity type :pathname-type)
+      (mapc #'(lambda (d)
+		(check-component-validity d :directory))
+	    (cdr dir)))
+
+    ;; More sanity checking
+    (when dir
+      ;; Try to canonicalize the directory component.  :absolute
+      ;; followed by a bunch of "/" deletes the leading "/"'s.
+      ;; :relative followed by "."  anywhere gets them all deleted.
+      (ecase (first dir)
+	(:absolute
+	 (do ((p (cdr dir) (cdr p)))
+	    ((or (null p)
+		 (not (equal "/" (car p))))
+	     (setf (cdr dir) p))))
+	(:relative
+	 (setf (cdr dir) (delete "." (cdr dir) :test #'equal)))))
     ;; CLHS 19.2.2.4.3 says :absolute or :wild-inferiors immediately
     ;; followed by :up or :back signals a file-error.
 
-- 
GitLab