Skip to content
Snippets Groups Projects
Commit 527266cd authored by rtoy's avatar rtoy
Browse files

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.)
parent 3a8dc700
No related branches found
No related tags found
No related merge requests found
...@@ -4,7 +4,7 @@ ...@@ -4,7 +4,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain. ;;; Carnegie Mellon University, and has been placed in the public domain.
;;; ;;;
(ext:file-comment (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 @@ ...@@ -125,18 +125,57 @@
(if (or *print-escape* *print-readably*) (if (or *print-escape* *print-readably*)
(format stream "#P~S" namestring) (format stream "#P~S" namestring)
(format stream "~A" namestring))) (format stream "~A" namestring)))
(*print-readably*
(error 'print-not-readable :object pathname))
(t (t
(funcall (formatter "#<Unprintable pathname, Host=~S, Device=~S, ~ (let ((host (%pathname-host pathname))
Directory=~S, Name=~S, Type=~S, Version=~S>") (device (%pathname-device pathname))
stream (directory (%pathname-directory pathname))
(%pathname-host pathname) (name (%pathname-name pathname))
(%pathname-device pathname) (type (%pathname-type pathname))
(%pathname-directory pathname) (version (%pathname-version pathname)))
(%pathname-name pathname) (cond ((every #'(lambda (d)
(%pathname-type pathname) (or (stringp d)
(%pathname-version pathname)))))) (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)))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; ;;;
......
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain. ;;; Carnegie Mellon University, and has been placed in the public domain.
;;; ;;;
(ext:file-comment (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 @@ ...@@ -400,7 +400,11 @@
(ignore-numarg sub-char numarg) (ignore-numarg sub-char numarg)
(let ((namestring (read stream t nil t))) (let ((namestring (read stream t nil t)))
(unless *read-suppress* (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) (make-dispatch-macro-character #\# t)
(set-dispatch-macro-character #\# #\\ #'sharp-backslash) (set-dispatch-macro-character #\# #\\ #'sharp-backslash)
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment