diff --git a/code/pathname.lisp b/code/pathname.lisp index b805da3b2fa8c81bc55ad000211d8393d8f6aca7..2015972e197071db9d09f7d47be0e44b4a793e1e 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.83 2005/10/24 14:55:32 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pathname.lisp,v 1.84 2005/11/08 17:12:29 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -125,18 +125,57 @@ (if (or *print-escape* *print-readably*) (format stream "#P~S" namestring) (format stream "~A" namestring))) - (*print-readably* - (error 'print-not-readable :object pathname)) (t - (funcall (formatter "#<Unprintable pathname, Host=~S, Device=~S, ~ - Directory=~S, Name=~S, Type=~S, Version=~S>") - stream - (%pathname-host pathname) - (%pathname-device pathname) - (%pathname-directory pathname) - (%pathname-name pathname) - (%pathname-type pathname) - (%pathname-version pathname)))))) + (let ((host (%pathname-host pathname)) + (device (%pathname-device pathname)) + (directory (%pathname-directory pathname)) + (name (%pathname-name pathname)) + (type (%pathname-type pathname)) + (version (%pathname-version pathname))) + (cond ((every #'(lambda (d) + (or (stringp d) + (symbolp d))) + (cdr directory)) + ;; A CMUCL extension. If we have an unprintable + ;; pathname, convert it to a form that would be + ;; suitable as args to MAKE-PATHNAME to recreate + ;; the pathname. + ;; + ;; We don't handle search-lists because we don't + ;; currently have a readable syntax for + ;; search-lists. + (collect ((result)) + (unless (eq host *unix-host*) + (result :host) + (result (pathname-host pathname))) + (when device + (result :device) + (result device)) + (when directory + (result :directory) + (result directory)) + (when name + (result :name) + (result name)) + (when type + (result :type) + (result type)) + (when version + (result :version) + (result version)) + (format stream "#P~S" (result)))) + (*print-readably* + (error 'print-not-readable :object pathname)) + (t + (funcall (formatter "#<Unprintable pathname,~:_ Host=~S,~:_ Device=~S,~:_ ~ + Directory=~S,~:_ Name=~S,~:_ Type=~S,~:_ Version=~S>") + stream + (%pathname-host pathname) + (%pathname-device pathname) + (%pathname-directory pathname) + (%pathname-name pathname) + (%pathname-type pathname) + (%pathname-version pathname))))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; diff --git a/code/sharpm.lisp b/code/sharpm.lisp index 025e9b5feab3b29f133f479cdef6b63111ac53e1..f6098330b53dc1a352270d096299dce36ef33dfc 100644 --- a/code/sharpm.lisp +++ b/code/sharpm.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/sharpm.lisp,v 1.25 2005/04/28 20:32:10 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/sharpm.lisp,v 1.26 2005/11/08 17:12:29 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -400,7 +400,11 @@ (ignore-numarg sub-char numarg) (let ((namestring (read stream t nil t))) (unless *read-suppress* - (parse-namestring namestring)))) + (if (listp namestring) + ;; A CMUCL extension: #P(foo) treats foo as the args to + ;; make-pathname + (apply #'make-pathname namestring) + (parse-namestring namestring))))) (make-dispatch-macro-character #\# t) (set-dispatch-macro-character #\# #\\ #'sharp-backslash)