From 52d2dc6cbeff65cbe4871d0dc5c0d25c87fd0f2c Mon Sep 17 00:00:00 2001
From: rtoy <rtoy>
Date: Fri, 4 Apr 2008 15:11:13 +0000
Subject: [PATCH] o Pathname printer was producing an error for (MAKE-PATHNAME
 :HOST NIL   :TYPE "foo").  This is because PATHNAME-HOST was signaling an
 error   for a host of NIL.  We check for a host of NIL now, and bypass the  
 call to PATHNAME-HOST.  This allows the pathname printer to print   #P(:HOST
 NIL :TYPE "foo"), as we want.

  (The error comes from host-pathname.  NIL is a valid result of
  host-pathname, so we could change that, but I think that has other
  implications, one of which is (MAKE-PATHNAME :HOST NIL :NAME "foo"
  :TYPE "lisp") gets printed as #P"foo.lisp", which is wrong, since
  that pathname has a unix-host host.)

o Fix merging of version in MAKE-PATHNAME.  CLHS MERGE-PATHNAMES says
  if the pathname name is given, the version is not affected by the
  default pathname.
---
 code/pathname.lisp | 31 ++++++++++++++++++++++---------
 1 file changed, 22 insertions(+), 9 deletions(-)

diff --git a/code/pathname.lisp b/code/pathname.lisp
index 42f340e8d..78e41c9ff 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.85 2007/09/10 16:25:00 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pathname.lisp,v 1.86 2008/04/04 15:11:13 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -119,15 +119,17 @@
 ;;;
 (defun %print-pathname (pathname stream depth)
   (declare (ignore depth))
-  (let ((namestring (handler-case (namestring pathname)
-		      (error nil))))
+  (let* ((host (%pathname-host pathname))
+	 (namestring (if host
+			 (handler-case (namestring pathname)
+			   (error nil))
+			 nil)))
     (cond (namestring
 	   (if (or *print-escape* *print-readably*)
 	       (format stream "#P~S" namestring)
 	       (format stream "~A" namestring)))
 	  (t
-	   (let ((host (%pathname-host pathname))
-		 (device (%pathname-device pathname))
+	   (let ((device (%pathname-device pathname))
 		 (directory (%pathname-directory pathname))
 		 (name (%pathname-name pathname))
 		 (type (%pathname-type pathname))
@@ -147,7 +149,9 @@
 		    (collect ((result))
 		      (unless (eq host *unix-host*)
 			(result :host)
-			(result (pathname-host pathname)))
+			(result (if host
+				    (pathname-host pathname)
+				    nil)))
 		      (when device
 			(result :device)
 			(result device))
@@ -760,10 +764,19 @@ a host-structure or string."
 			     (host-customary-case default-host)))))
 	 (dev (if devp device (if defaults (%pathname-device defaults))))
 	 (dir (import-directory directory diddle-args))
+	 ;; CLHS MERGE-PATHNAMES (via MAKE-PATHNAME) says
+	 ;;
+	 ;; If pathname does not specify a name, then the version, if
+	 ;; not provided, will come from default-pathname, just like
+	 ;; the other components. If pathname does specify a name,
+	 ;; then the version is not affected by default-pathname. If
+	 ;; this process leaves the version missing, the
+	 ;; default-version is used.
 	 (ver (cond
-	       (versionp version)
-	       (defaults (%pathname-version defaults))
-	       (t nil))))
+		(versionp version)
+		(namep version)
+		(defaults (%pathname-version defaults))
+		(t nil))))
     (when (and defaults (not dirp))
       (setf dir
 	    (merge-directories dir
-- 
GitLab