/[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.85 by rtoy, Mon Sep 10 16:25:00 2007 UTC revision 1.86 by rtoy, Fri Apr 4 15:11:13 2008 UTC
# Line 119  Line 119 
119  ;;;  ;;;
120  (defun %print-pathname (pathname stream depth)  (defun %print-pathname (pathname stream depth)
121    (declare (ignore depth))    (declare (ignore depth))
122    (let ((namestring (handler-case (namestring pathname)    (let* ((host (%pathname-host pathname))
123                        (error nil))))           (namestring (if host
124                             (handler-case (namestring pathname)
125                               (error nil))
126                             nil)))
127      (cond (namestring      (cond (namestring
128             (if (or *print-escape* *print-readably*)             (if (or *print-escape* *print-readably*)
129                 (format stream "#P~S" namestring)                 (format stream "#P~S" namestring)
130                 (format stream "~A" namestring)))                 (format stream "~A" namestring)))
131            (t            (t
132             (let ((host (%pathname-host pathname))             (let ((device (%pathname-device pathname))
                  (device (%pathname-device pathname))  
133                   (directory (%pathname-directory pathname))                   (directory (%pathname-directory pathname))
134                   (name (%pathname-name pathname))                   (name (%pathname-name pathname))
135                   (type (%pathname-type pathname))                   (type (%pathname-type pathname))
# Line 147  Line 149 
149                      (collect ((result))                      (collect ((result))
150                        (unless (eq host *unix-host*)                        (unless (eq host *unix-host*)
151                          (result :host)                          (result :host)
152                          (result (pathname-host pathname)))                          (result (if host
153                                        (pathname-host pathname)
154                                        nil)))
155                        (when device                        (when device
156                          (result :device)                          (result :device)
157                          (result device))                          (result device))
# Line 760  a host-structure or string." Line 764  a host-structure or string."
764                               (host-customary-case default-host)))))                               (host-customary-case default-host)))))
765           (dev (if devp device (if defaults (%pathname-device defaults))))           (dev (if devp device (if defaults (%pathname-device defaults))))
766           (dir (import-directory directory diddle-args))           (dir (import-directory directory diddle-args))
767             ;; CLHS MERGE-PATHNAMES (via MAKE-PATHNAME) says
768             ;;
769             ;; If pathname does not specify a name, then the version, if
770             ;; not provided, will come from default-pathname, just like
771             ;; the other components. If pathname does specify a name,
772             ;; then the version is not affected by default-pathname. If
773             ;; this process leaves the version missing, the
774             ;; default-version is used.
775           (ver (cond           (ver (cond
776                 (versionp version)                  (versionp version)
777                 (defaults (%pathname-version defaults))                  (namep version)
778                 (t nil))))                  (defaults (%pathname-version defaults))
779                    (t nil))))
780      (when (and defaults (not dirp))      (when (and defaults (not dirp))
781        (setf dir        (setf dir
782              (merge-directories dir              (merge-directories dir

Legend:
Removed from v.1.85  
changed lines
  Added in v.1.86

  ViewVC Help
Powered by ViewVC 1.1.5