diff --git a/code/pathname.lisp b/code/pathname.lisp index 42f340e8decb4d696d88d3cbfeb4964f8801d5b1..78e41c9ff8988af62eb590a21b5b76771716cf6a 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