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