From 527266cd5326ace30ade9a81640105417dc1b11b Mon Sep 17 00:00:00 2001 From: rtoy <rtoy> Date: Tue, 8 Nov 2005 17:12:29 +0000 Subject: [PATCH] Add an extension to allow printing pathnames using the syntax #P(<make-pathname args). So most pathnames can be printed readably, even if they have weird components. But we don't handle search-lists and patterns very well because we don't have readable syntax for those. code/sharpm.lisp: o Make the #P reader accept lists and apply make-pathname on them to create the pathname code/pathname.lisp: o If a pathname has no namestring, then try to print out the pathname object using #P(foo) syntax, if possible. If not possible, just print out the pathname unreadably, as we used to. o Put some conditional newlines when printing out unprintable pathnames so it wraps a bit better. (Needs work.) --- code/pathname.lisp | 63 +++++++++++++++++++++++++++++++++++++--------- code/sharpm.lisp | 8 ++++-- 2 files changed, 57 insertions(+), 14 deletions(-) diff --git a/code/pathname.lisp b/code/pathname.lisp index b805da3b2..2015972e1 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 025e9b5fe..f6098330b 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) -- GitLab