/[cmucl]/src/code/pathname.lisp
ViewVC logotype

Diff of /src/code/pathname.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.83 by rtoy, Mon Oct 24 14:55:32 2005 UTC revision 1.84 by rtoy, Tue Nov 8 17:12:29 2005 UTC
# Line 125  Line 125 
125             (if (or *print-escape* *print-readably*)             (if (or *print-escape* *print-readably*)
126                 (format stream "#P~S" namestring)                 (format stream "#P~S" namestring)
127                 (format stream "~A" namestring)))                 (format stream "~A" namestring)))
           (*print-readably*  
            (error 'print-not-readable :object pathname))  
128            (t            (t
129             (funcall (formatter "#<Unprintable pathname, Host=~S, Device=~S, ~             (let ((host (%pathname-host pathname))
130                                  Directory=~S, Name=~S, Type=~S, Version=~S>")                   (device (%pathname-device pathname))
131                      stream                   (directory (%pathname-directory pathname))
132                      (%pathname-host pathname)                   (name (%pathname-name pathname))
133                      (%pathname-device pathname)                   (type (%pathname-type pathname))
134                      (%pathname-directory pathname)                   (version (%pathname-version pathname)))
135                      (%pathname-name pathname)               (cond ((every #'(lambda (d)
136                      (%pathname-type pathname)                                 (or (stringp d)
137                      (%pathname-version pathname))))))                                     (symbolp d)))
138                               (cdr directory))
139                        ;; A CMUCL extension.  If we have an unprintable
140                        ;; pathname, convert it to a form that would be
141                        ;; suitable as args to MAKE-PATHNAME to recreate
142                        ;; the pathname.
143                        ;;
144                        ;; We don't handle search-lists because we don't
145                        ;; currently have a readable syntax for
146                        ;; search-lists.
147                        (collect ((result))
148                          (unless (eq host *unix-host*)
149                            (result :host)
150                            (result (pathname-host pathname)))
151                          (when device
152                            (result :device)
153                            (result device))
154                          (when directory
155                            (result :directory)
156                            (result directory))
157                          (when name
158                            (result :name)
159                            (result name))
160                          (when type
161                            (result :type)
162                            (result type))
163                          (when version
164                            (result :version)
165                            (result version))
166                          (format stream "#P~S" (result))))
167                       (*print-readably*
168                        (error 'print-not-readable :object pathname))
169                       (t
170                        (funcall (formatter "#<Unprintable pathname,~:_ Host=~S,~:_ Device=~S,~:_ ~
171                                    Directory=~S,~:_ Name=~S,~:_ Type=~S,~:_ Version=~S>")
172                                 stream
173                                 (%pathname-host pathname)
174                                 (%pathname-device pathname)
175                                 (%pathname-directory pathname)
176                                 (%pathname-name pathname)
177                                 (%pathname-type pathname)
178                                 (%pathname-version pathname)))))))))
179    
180  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
181  ;;;  ;;;

Legend:
Removed from v.1.83  
changed lines
  Added in v.1.84

  ViewVC Help
Powered by ViewVC 1.1.5