/[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.59.2.1 by gerd, Mon Mar 24 10:54:40 2003 UTC revision 1.92 by rtoy, Tue Apr 20 17:57:45 2010 UTC
# Line 16  Line 16 
16  ;;; **********************************************************************  ;;; **********************************************************************
17    
18  (in-package "LISP")  (in-package "LISP")
19    (intl:textdomain "cmucl")
20    
21  (export '(pathname pathnamep logical-pathname  (export '(pathname pathnamep logical-pathname
22            parse-namestring merge-pathnames make-pathname            parse-namestring merge-pathnames make-pathname
# Line 59  Line 60 
60    (declare (ignore depth))    (declare (ignore depth))
61    (print-unreadable-object (host stream :type t)))    (print-unreadable-object (host stream :type t)))
62    
63    (defun %print-logical-host (host stream depth)
64      (declare (ignore depth))
65      (print-unreadable-object (host stream :type t :identity t)
66        (write (logical-host-name host) :stream stream)))
67    
68  (defstruct (logical-host  (defstruct (logical-host
69              (:include host              (:include host
70                        (:parse #'parse-logical-namestring)                        (:parse #'parse-logical-namestring)
# Line 69  Line 75 
75                        (:unparse-file #'unparse-unix-file)                        (:unparse-file #'unparse-unix-file)
76                        (:unparse-enough #'unparse-enough-namestring)                        (:unparse-enough #'unparse-enough-namestring)
77                        (:customary-case :upper))                        (:customary-case :upper))
78                (:print-function %print-logical-host)
79              (:make-load-form-fun make-logical-host-load-form-fun))              (:make-load-form-fun make-logical-host-load-form-fun))
80    (name "" :type simple-base-string)    (name "" :type simple-base-string)
81    (translations nil :type list)    (translations nil :type list)
# Line 113  Line 120 
120  ;;;  ;;;
121  (defun %print-pathname (pathname stream depth)  (defun %print-pathname (pathname stream depth)
122    (declare (ignore depth))    (declare (ignore depth))
123    (let ((namestring (handler-case (namestring pathname)    (let* ((host (%pathname-host pathname))
124                        (error nil))))           (namestring (if host
125                             (handler-case (namestring pathname)
126                               (error nil))
127                             nil)))
128      (cond (namestring      (cond (namestring
129             (if (or *print-escape* *print-readably*)             (if (or *print-escape* *print-readably*)
130                 (format stream "#p~S" namestring)                 (format stream "#P~S" namestring)
131                 (format stream "~A" namestring)))                 (format stream "~A" namestring)))
           (*print-readably*  
            (error "~S Cannot be printed readably." pathname))  
132            (t            (t
133             (funcall (formatter "#<Unprintable pathname, Host=~S, Device=~S, ~             (let ((device (%pathname-device pathname))
134                                  Directory=~S, Name=~S, Type=~S, Version=~S>")                   (directory (%pathname-directory pathname))
135                      stream                   (name (%pathname-name pathname))
136                      (%pathname-host pathname)                   (type (%pathname-type pathname))
137                      (%pathname-device pathname)                   (version (%pathname-version pathname)))
138                      (%pathname-directory pathname)               (cond ((every #'(lambda (d)
139                      (%pathname-name pathname)                                 (or (stringp d)
140                      (%pathname-type pathname)                                     (symbolp d)))
141                      (%pathname-version pathname))))))                             (cdr directory))
142                        ;; A CMUCL extension.  If we have an unprintable
143                        ;; pathname, convert it to a form that would be
144                        ;; suitable as args to MAKE-PATHNAME to recreate
145                        ;; the pathname.
146                        ;;
147                        ;; We don't handle search-lists because we don't
148                        ;; currently have a readable syntax for
149                        ;; search-lists.
150                        (collect ((result))
151                          (unless (eq host *unix-host*)
152                            (result :host)
153                            (result (if host
154                                        (pathname-host pathname)
155                                        nil)))
156                          (when device
157                            (result :device)
158                            (result device))
159                          (when directory
160                            (result :directory)
161                            (result directory))
162                          (when name
163                            (result :name)
164                            (result name))
165                          (when type
166                            (result :type)
167                            (result type))
168                          (when version
169                            (result :version)
170                            (result version))
171                          (format stream "#P~S" (result))))
172                       (*print-readably*
173                        (error 'print-not-readable :object pathname))
174                       (t
175                        (funcall (formatter "#<Unprintable pathname,~:_ Host=~S,~:_ Device=~S,~:_ ~
176                                    Directory=~S,~:_ Name=~S,~:_ Type=~S,~:_ Version=~S>")
177                                 stream
178                                 (%pathname-host pathname)
179                                 (%pathname-device pathname)
180                                 (%pathname-directory pathname)
181                                 (%pathname-name pathname)
182                                 (%pathname-type pathname)
183                                 (%pathname-version pathname)))))))))
184    
185  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
186  ;;;  ;;;
# Line 171  Line 221 
221  ;;; The potential conflict with search-lists requires isolating the printed  ;;; The potential conflict with search-lists requires isolating the printed
222  ;;; representation to use the i/o macro #.(logical-pathname <path-designator>).  ;;; representation to use the i/o macro #.(logical-pathname <path-designator>).
223  ;;;  ;;;
224    ;;; Is there really a potential conflict?  CMUCL does not allow
225    ;;; search-list hosts and logical pathname hosts have the same name.
226    ;;; Hence, if we use #P to print them out, we can always read them
227    ;;; back without confusion.  (rtoy)
228    ;;;
229  (defun %print-logical-pathname (pathname stream depth)  (defun %print-logical-pathname (pathname stream depth)
230    (declare (ignore depth))    (declare (ignore depth))
231    (let ((namestring (handler-case (namestring pathname)    (let ((namestring (handler-case (namestring pathname)
232                        (error nil))))                        (error nil))))
233      (cond (namestring      (cond (namestring
234             (if (or *print-escape* *print-readably*)             (if (or *print-escape* *print-readably*)
235                 (format stream "#.(logical-pathname ~S)" namestring)                 (format stream "#P~S" namestring)
236                 (format stream "~A" namestring)))                 (format stream "~A" namestring)))
237            (*print-readably*            (*print-readably*
238             (error "~S Cannot be printed readably." pathname))             (error 'print-not-readable :object pathname))
239            (t            (t
240             (funcall (formatter "#<Unprintable pathname, Host=~S,  ~             (funcall (formatter "#<Unprintable pathname, Host=~S,  ~
241                                  Directory=~S, File=~S, Name=~S, Version=~S>")                                  Directory=~S, File=~S, Name=~S, Version=~S>")
# Line 199  Line 254 
254    
255  (defun %make-pathname-object (host device directory name type version)  (defun %make-pathname-object (host device directory name type version)
256    (if (typep host 'logical-host)    (if (typep host 'logical-host)
257        (%make-logical-pathname host :unspecific directory name type version)        (flet ((upcasify (thing)
258        (%make-pathname         host device      directory name type version)))                 (typecase thing
259                     (list
260                      (mapcar #'(lambda (x)
261                                  (if (stringp x)
262                                      (string-upcase x)
263                                      x))
264                              thing))
265                     (simple-base-string
266                      (string-upcase thing))
267                     (t
268                      thing))))
269            (%make-logical-pathname host :unspecific
270                                    (upcasify directory)
271                                    (upcasify name)
272                                    (upcasify type)
273                                    (upcasify version)))
274          (%make-pathname host device directory name type version)))
275    
276  ;;; *LOGICAL-HOSTS* --internal.  ;;; *LOGICAL-HOSTS* --internal.
277  ;;;  ;;;
# Line 212  Line 283 
283  ;;; PATH-DESIGNATOR -- internal type  ;;; PATH-DESIGNATOR -- internal type
284  ;;;  ;;;
285  (deftype path-designator ()  (deftype path-designator ()
286    "A path specification, either a string, stream or pathname."    "A path specification, either a string, file-stream or pathname."
287    '(or string stream pathname))    ;; This used to be stream, not file-stream, but ANSI CL says a
288      ;; pathname designator is a string, a pathname or a stream
289      ;; associated with a file.  In the places we use path-designator, we
290      ;; are really talking about ANSI pathname designators.
291      '(or string file-stream pathname))
292    
293    
294  ;;;; Patterns  ;;;; Patterns
# Line 296  Line 371 
371                            (:character-set                            (:character-set
372                             (and (< start len)                             (and (< start len)
373                                  (let ((char (schar string start)))                                  (let ((char (schar string start)))
374                                    (if (find char (cdr piece) :test #'char=)                                    (if (find char (second piece) :test #'char=)
375                                        (matches (cdr pieces) (1+ start) subs t                                        (matches (cdr pieces) (1+ start) subs t
376                                                 (cons char chars))))))))                                                 (cons char chars))))))))
377                         ((member :single-char-wild)                         ((member :single-char-wild)
# Line 392  Line 467 
467                (compare-component (car this) (car that))                (compare-component (car this) (car that))
468                (compare-component (cdr this) (cdr that)))))))                (compare-component (cdr this) (cdr that)))))))
469    
470    ;; Compare the version component.  We treat NIL to be EQUAL to
471    ;; :NEWEST.
472    (defun compare-version-component (this that)
473      (or (eql this that)
474          (and (null this) (eq that :newest))
475          (and (null that) (eq this :newest))))
476    
477  ;;;; Pathname functions.  ;;;; Pathname functions.
478    
# Line 414  Line 495 
495                            (%pathname-name pathname2))                            (%pathname-name pathname2))
496         (compare-component (%pathname-type pathname1)         (compare-component (%pathname-type pathname1)
497                            (%pathname-type pathname2))                            (%pathname-type pathname2))
498         (compare-component (%pathname-version pathname1)         (compare-version-component (%pathname-version pathname1)
499                            (%pathname-version pathname2))))                                    (%pathname-version pathname2))))
500    
501  ;;; WITH-PATHNAME -- Internal  ;;; WITH-PATHNAME -- Internal
502  ;;;   Converts the expr, a pathname designator (a pathname, or string, or  ;;;   Converts the expr, a pathname designator (a pathname, or string, or
# Line 426  Line 507 
507                   (etypecase ,var                   (etypecase ,var
508                     (pathname ,var)                     (pathname ,var)
509                     (string (parse-namestring ,var))                     (string (parse-namestring ,var))
510                     (file-stream (file-name ,var))))))                     (file-stream (file-name ,var))
511                       (stream:file-simple-stream (file-name ,var))))))
512       ,@body))       ,@body))
513    
514  ;;; WITH-HOST -- Internal  ;;; WITH-HOST -- Internal
# Line 534  Line 616 
616        (let ((results nil))        (let ((results nil))
617          (flet ((add (dir)          (flet ((add (dir)
618                   (if (and (eq dir :back)                   (if (and (eq dir :back)
619                            results                            (cdr results)
620                            (not (eq (car results) :back)))                            (not (eq (car results) :back)))
621                       (pop results)                       (pop results)
622                       (push dir results))))                       (push dir results))))
# Line 564  Line 646 
646                (and default-host pathname-host                (and default-host pathname-host
647                     (not (eq (host-customary-case default-host)                     (not (eq (host-customary-case default-host)
648                              (host-customary-case pathname-host))))))                              (host-customary-case pathname-host))))))
649          (%make-pathname-object          (make-pathname
650           (or pathname-host default-host)           :host (or pathname-host default-host)
651           (or (%pathname-device pathname)           :device (or (%pathname-device pathname)
652               (maybe-diddle-case (%pathname-device defaults)                       (maybe-diddle-case (%pathname-device defaults)
653                                  diddle-case))                                          diddle-case))
654           (merge-directories (%pathname-directory pathname)           :directory (merge-directories (%pathname-directory pathname)
655                              (%pathname-directory defaults)                                         (%pathname-directory defaults)
656                              diddle-case)                                         diddle-case)
657           (or (%pathname-name pathname)           :name (or (%pathname-name pathname)
658               (maybe-diddle-case (%pathname-name defaults)                     (maybe-diddle-case (%pathname-name defaults)
659                                  diddle-case))                                        diddle-case))
660           (or (%pathname-type pathname)           :type (or (%pathname-type pathname)
661               (maybe-diddle-case (%pathname-type defaults)                     (maybe-diddle-case (%pathname-type defaults)
662                                  diddle-case))                                        diddle-case))
663           (or (if (null (%pathname-name pathname))           :version (or (if (null (%pathname-name pathname))
664                   (or (%pathname-version pathname)                            (or (%pathname-version pathname)
665                       (%pathname-version defaults))                                (%pathname-version defaults))
666                   (%pathname-version pathname))                            (%pathname-version pathname))
667               default-version))))))                        default-version))))))
668    
669  ;;; IMPORT-DIRECTORY -- Internal  ;;; IMPORT-DIRECTORY -- Internal
670  ;;;  ;;;
# Line 609  Line 691 
691                  (results (maybe-diddle-case (coerce piece 'simple-string)                  (results (maybe-diddle-case (coerce piece 'simple-string)
692                                              diddle-case)))                                              diddle-case)))
693                 (t                 (t
694                  (error "~S is not allowed as a directory component." piece))))                  (error (intl:gettext "~S is not allowed as a directory component.") piece))))
695         (results)))         (results)))
696      (simple-string      (simple-string
697       `(:absolute       `(:absolute
# Line 621  Line 703 
703    
704  ;;; MAKE-PATHNAME -- Interface  ;;; MAKE-PATHNAME -- Interface
705  ;;;  ;;;
706  (defun make-pathname (&key host  (defun make-pathname (&key (host nil hostp)
707                             (device nil devp)                             (device nil devp)
708                             (directory nil dirp)                             (directory nil dirp)
709                             (name nil namep)                             (name nil namep)
# Line 631  Line 713 
713                             (case :local))                             (case :local))
714    "Makes a new pathname from the component arguments.  Note that host is    "Makes a new pathname from the component arguments.  Note that host is
715  a host-structure or string."  a host-structure or string."
716    (declare (type (or string host component-tokens) host)    (declare (type (or null string host component-tokens) host)
717             (type (or string component-tokens) device)             (type (or string component-tokens) device)
718             (type (or list string pattern component-tokens) directory)             (type (or list string pattern component-tokens) directory)
719             (type (or string pattern component-tokens) name type)             (type (or string pattern component-tokens) name type)
# Line 665  a host-structure or string." Line 747  a host-structure or string."
747                   (host host)            ; A valid host, use it.                   (host host)            ; A valid host, use it.
748                   ((string 0) default-host) ; "" cannot be a logical host                   ((string 0) default-host) ; "" cannot be a logical host
749                   (string (find-logical-host host t)) ; logical-host or lose.                   (string (find-logical-host host t)) ; logical-host or lose.
750                   (t default-host)))     ; unix-host                   (t
751           (diddle-args (and (eq (host-customary-case host) :lower)                    ;; If the user specifically set :host to be NIL, use
752                             (eq case :common)))                    ;; it.  Otherwise, we use the default host.
753                      (if (and hostp (null host))
754                          nil
755                          default-host))))
756             (diddle-args
757              ;; What to do if no host is given?  Can't figure out the
758              ;; customary case, so I (rtoy) am going to assume we don't
759              ;; need to diddle args.
760              (and host (eq (host-customary-case host) :lower)
761                   (eq case :common)))
762           (diddle-defaults           (diddle-defaults
763            (not (eq (host-customary-case host)            ;; Same for diddle-defaults.  Do nothing if no host was given.
764                     (host-customary-case default-host))))            (and host (not (eq (host-customary-case host)
765                                 (host-customary-case default-host)))))
766           (dev (if devp device (if defaults (%pathname-device defaults))))           (dev (if devp device (if defaults (%pathname-device defaults))))
767           (dir (import-directory directory diddle-args))           (dir (import-directory directory diddle-args))
768             ;; CLHS MERGE-PATHNAMES (via MAKE-PATHNAME) says
769             ;;
770             ;; If pathname does not specify a name, then the version, if
771             ;; not provided, will come from default-pathname, just like
772             ;; the other components. If pathname does specify a name,
773             ;; then the version is not affected by default-pathname. If
774             ;; this process leaves the version missing, the
775             ;; default-version is used.
776           (ver (cond           (ver (cond
777                 (versionp version)                  (versionp version)
778                 (defaults (%pathname-version defaults))                  (namep version)
779                 (t nil))))                  (defaults (%pathname-version defaults))
780                    (t nil))))
781      (when (and defaults (not dirp))      (when (and defaults (not dirp))
782        (setf dir        (setf dir
783              (merge-directories dir              (merge-directories dir
# Line 689  a host-structure or string." Line 790  a host-structure or string."
790                 (let ((unix-directory-separator #\/))                 (let ((unix-directory-separator #\/))
791                   (when (eq host (%pathname-host *default-pathname-defaults*))                   (when (eq host (%pathname-host *default-pathname-defaults*))
792                     (when (find unix-directory-separator name)                     (when (find unix-directory-separator name)
793                       (warn "Silly argument for a unix ~A: ~S"                       (warn (intl:gettext "Silly argument for a unix ~A: ~S")
794                             name-or-type name)))))))                             name-or-type name)))))))
795        (check-component-validity name :pathname-name)        (check-component-validity name :pathname-name)
796        (check-component-validity type :pathname-type))        (check-component-validity type :pathname-type)
797          (mapc #'(lambda (d)
798                    (check-component-validity d :directory))
799                (cdr dir))
800          (when (and (stringp name)
801                     (or (and (string= name "..")
802                              (not type))
803                         (and (string= name ".")
804                              (not type))))
805            ;;
806            (warn (intl:gettext "Silly argument for a unix PATHNAME-NAME: ~S") name)))
807    
808        ;; More sanity checking
809        (when dir
810          ;; Try to canonicalize the directory component.  :absolute
811          ;; followed by a bunch of "/" deletes the leading "/"'s.
812          ;; :relative followed by "."  anywhere gets them all deleted.
813          (ecase (first dir)
814            (:absolute
815             (do ((p (cdr dir) (cdr p)))
816                ((or (null p)
817                     (not (equal "/" (car p))))
818                 (setf (cdr dir) p))))
819            (:relative
820             (setf (cdr dir) (delete "." (cdr dir) :test #'equal)))))
821        ;; CLHS 19.2.2.4.3 says :absolute or :wild-inferiors immediately
822        ;; followed by :up or :back signals a file-error.
823    
824        (let ((d (or (member :wild-inferiors dir)
825                     (member :absolute dir))))
826          (when (and d (rest d) (member (second d) '(:up :back)))
827            ;; What should we put in the for pathname part of file-error?
828            ;; I'm just going to use the directory but removing the
829            ;; offending :up or :back.  Or would just (make-pathname) be
830            ;; enough?
831            ;;
832            ;; Or instead of checking here, we could check whenever we
833            ;; "use" the file system (CLHS 19.2.2.4.3).  But that's a lot
834            ;; harder to do.
835            (error 'simple-file-error
836                   :pathname (make-pathname :directory (remove-if #'(lambda (x)
837                                                                      (member x '(:up :back)))
838                                                                  dir))
839                   :format-control (intl:gettext "Illegal pathname: ~
840                                    Directory with ~S immediately followed by ~S")
841                   :format-arguments (list (first d) (second d)))))
842    
843      (macrolet ((pick (var varp field)      (macrolet ((pick (var varp field)
844                   `(cond ((or (simple-string-p ,var)                   `(cond ((or (simple-string-p ,var)
# Line 745  a host-structure or string." Line 891  a host-structure or string."
891    (declare (type path-designator pathname)    (declare (type path-designator pathname)
892             (type (member :local :common) case))             (type (member :local :common) case))
893    (with-pathname (pathname pathname)    (with-pathname (pathname pathname)
894      (maybe-diddle-case (%pathname-directory pathname)      ;; CLHS 19.2.2.1.2.2 says: "should receive and yield strings in
895                         (and (eq case :common)      ;; component values"
896                              (eq (host-customary-case      ;;
897                                   (%pathname-host pathname))      ;; We take this to mean it applies to each component of the
898                                  :lower)))))      ;; directory individually.  This also matches the example in the
899        ;; entry for PATHNAME-HOST.
900        (let ((diddle-p (and (eq case :common)
901                             (eq (host-customary-case
902                                  (%pathname-host pathname))
903                                 :lower))))
904          (mapcar #'(lambda (piece)
905                      (maybe-diddle-case piece diddle-p))
906                  (%pathname-directory pathname)))))
907    
908  ;;; PATHNAME-NAME -- Interface  ;;; PATHNAME-NAME -- Interface
909  ;;;  ;;;
910  (defun pathname-name (pathname &key (case :local))  (defun pathname-name (pathname &key (case :local))
# Line 790  a host-structure or string." Line 945  a host-structure or string."
945  ;;; %PRINT-NAMESTRING-PARSE-ERROR -- Internal  ;;; %PRINT-NAMESTRING-PARSE-ERROR -- Internal
946  ;;;  ;;;
947  (defun %print-namestring-parse-error (condition stream)  (defun %print-namestring-parse-error (condition stream)
948    (format stream "Parse error in namestring: ~?~%  ~A~%  ~V@T^"    (format stream (intl:gettext "Parse error in namestring: ~?~%  ~A~%  ~V@T^")
949            (namestring-parse-error-complaint condition)            (namestring-parse-error-complaint condition)
950            (namestring-parse-error-arguments condition)            (namestring-parse-error-arguments condition)
951            (namestring-parse-error-namestring condition)            (namestring-parse-error-namestring condition)
952            (namestring-parse-error-offset condition)))            (namestring-parse-error-offset condition)))
953    
954  (define-condition namestring-parse-error (parse-error)  (define-condition namestring-parse-error (parse-error type-error)
955    ((complaint :reader namestring-parse-error-complaint :initarg :complaint)    ((complaint :reader namestring-parse-error-complaint :initarg :complaint)
956     (arguments :reader namestring-parse-error-arguments :initarg :arguments     (arguments :reader namestring-parse-error-arguments :initarg :arguments
957                :initform nil)                :initform nil)
# Line 831  a host-structure or string." Line 986  a host-structure or string."
986                               (extract-logical-host-prefix namestr start end)                               (extract-logical-host-prefix namestr start end)
987                               default-host)))                               default-host)))
988          (unless parse-host          (unless parse-host
989            (error "When Host arg is not supplied, Defaults arg must ~            (error (intl:gettext "When Host arg is not supplied, Defaults arg must ~
990                    have a non-null PATHNAME-HOST."))                    have a non-null PATHNAME-HOST.")))
991    
992          (multiple-value-bind          (multiple-value-bind
993              (new-host device directory file type version)              (new-host device directory file type version)
994              (funcall (host-parse parse-host) namestr start end)              (funcall (host-parse parse-host) namestr start end)
995            (when (and host new-host (not (eq new-host host)))            (when (and host new-host (not (eq new-host host)))
996              (error "Host in namestring: ~S~@              (error (intl:gettext "Host in namestring: ~S~@
997                      does not match explicit host argument: ~S"                      does not match explicit host argument: ~S")
998                     namestr host))                     namestr host))
999            (let ((pn-host (or new-host parse-host)))            (let ((pn-host (or new-host parse-host)))
1000              (values (%make-pathname-object              (values (%make-pathname-object
# Line 872  a host-structure or string." Line 1027  a host-structure or string."
1027     a physical host structure or host namestring."     a physical host structure or host namestring."
1028    (declare (type path-designator thing)    (declare (type path-designator thing)
1029             (type (or list string host (member :unspecific)) host)             (type (or list string host (member :unspecific)) host)
1030             (type pathname defaults)             (type path-designator defaults)
1031             (type index start)             (type index start)
1032             (type (or index null) end))             (type (or index null) end))
1033    ;; Generally, redundant specification of information in software,    ;; Generally, redundant specification of information in software,
# Line 921  a host-structure or string." Line 1076  a host-structure or string."
1076                   ;; but leaves its interpretation                   ;; but leaves its interpretation
1077                   ;; implementation-defined. Our interpretation                   ;; implementation-defined. Our interpretation
1078                   ;; is that it's unsupported.:-|                   ;; is that it's unsupported.:-|
1079                   (error "A LIST representing a pathname host is not ~                   (error (intl:gettext "A LIST representing a pathname host is not ~
1080                                supported in this implementation:~%  ~S"                                supported in this implementation:~%  ~S")
1081                          host))                          host))
1082                  (host                  (host
1083                   host))))                   host))))
1084      (declare (type (or null host) host))      (declare (type (or null host) host))
1085      (etypecase thing      (with-pathname (defaults defaults)
1086        (simple-string        (etypecase thing
1087         (%parse-namestring thing host defaults start end junk-allowed))          (simple-string
1088        (string           (%parse-namestring thing host defaults start end junk-allowed))
1089         (%parse-namestring (coerce thing 'simple-string)          (string
1090                            host defaults start end junk-allowed))           (%parse-namestring (coerce thing 'simple-string)
1091        (pathname                              host defaults start end junk-allowed))
1092         (let ((host (if host host (%pathname-host defaults))))          (pathname
1093           (unless (eq host (%pathname-host thing))           (let ((host (if host host (%pathname-host defaults))))
1094             (error "Hosts do not match: ~S and ~S."             (unless (eq host (%pathname-host thing))
1095                    host (%pathname-host thing))))               (error (intl:gettext "Hosts do not match: ~S and ~S.")
1096         (values thing start))                      host (%pathname-host thing))))
1097        (stream           (values thing start))
1098         (let ((name (file-name thing)))          (stream
1099           (unless name           (let ((name (file-name thing)))
1100             (error "Can't figure out the file associated with stream:~%  ~S"             (unless name
1101                    thing))               (error 'simple-type-error
1102           (values name nil))))))                      :datum thing
1103                        :expected-type 'pathname
1104                        :format-control (intl:gettext "Can't figure out the file associated with stream:~%  ~S")
1105                        :format-arguments (list thing)))
1106               (values name nil)))))))
1107    
1108    
1109  ;;; NAMESTRING -- Interface  ;;; NAMESTRING -- Interface
# Line 955  a host-structure or string." Line 1114  a host-structure or string."
1114             (values (or null simple-base-string)))             (values (or null simple-base-string)))
1115    (with-pathname (pathname pathname)    (with-pathname (pathname pathname)
1116      (when pathname      (when pathname
1117        (let ((host (%pathname-host pathname)))        (let ((host (or (%pathname-host pathname)
1118                          ;; Is this what we really want?  Does a NIL host
1119                          ;; really mean to get it from *d-p-d* and, if
1120                          ;; that's NIL, use *unix-host*?
1121                          (%pathname-host *default-pathname-defaults*)
1122                          *unix-host*)
1123                          ))
1124          (unless host          (unless host
1125            (error "Cannot determine the namestring for pathnames with no ~            (error (intl:gettext "Cannot determine the namestring for pathnames with no ~
1126                    host:~%  ~S" pathname))                    host:~%  ~S") pathname))
1127          (funcall (host-unparse host) pathname)))))          (funcall (host-unparse host) pathname)))))
1128    
1129    
# Line 973  a host-structure or string." Line 1138  a host-structure or string."
1138        (if host        (if host
1139            (funcall (host-unparse-host host) pathname)            (funcall (host-unparse-host host) pathname)
1140            (error            (error
1141             "Cannot determine the namestring for pathnames with no host:~%  ~S"             (intl:gettext "Cannot determine the namestring for pathnames with no host:~%  ~S")
1142             pathname)))))             pathname)))))
1143    
1144  ;;; DIRECTORY-NAMESTRING -- Interface  ;;; DIRECTORY-NAMESTRING -- Interface
# Line 987  a host-structure or string." Line 1152  a host-structure or string."
1152        (if host        (if host
1153            (funcall (host-unparse-directory host) pathname)            (funcall (host-unparse-directory host) pathname)
1154            (error            (error
1155             "Cannot determine the namestring for pathnames with no host:~%  ~S"             (intl:gettext "Cannot determine the namestring for pathnames with no host:~%  ~S")
1156             pathname)))))             pathname)))))
1157    
1158  ;;; FILE-NAMESTRING -- Interface  ;;; FILE-NAMESTRING -- Interface
# Line 1001  a host-structure or string." Line 1166  a host-structure or string."
1166        (if host        (if host
1167            (funcall (host-unparse-file host) pathname)            (funcall (host-unparse-file host) pathname)
1168            (error            (error
1169             "Cannot determine the namestring for pathnames with no host:~%  ~S"             (intl:gettext "Cannot determine the namestring for pathnames with no host:~%  ~S")
1170             pathname)))))             pathname)))))
1171    
1172  ;;; ENOUGH-NAMESTRING -- Interface  ;;; ENOUGH-NAMESTRING -- Interface
# Line 1010  a host-structure or string." Line 1175  a host-structure or string."
1175                            &optional (defaults *default-pathname-defaults*))                            &optional (defaults *default-pathname-defaults*))
1176    "Returns an abbreviated pathname sufficent to identify the pathname relative    "Returns an abbreviated pathname sufficent to identify the pathname relative
1177     to the defaults."     to the defaults."
1178    (declare (type path-designator pathname))    (declare (type path-designator pathname defaults))
1179    (with-pathname (pathname pathname)    (with-pathname (pathname pathname)
1180      (let ((host (%pathname-host pathname)))      (let ((host (%pathname-host pathname)))
1181        (if host        (if host
1182            (with-pathname (defaults defaults)            (with-pathname (defaults defaults)
1183              (funcall (host-unparse-enough host) pathname defaults))              ;; Give up if the hosts are different.  I (rtoy) don't
1184                ;; think it makes sense to do anything if the hosts are
1185                ;; different.
1186                (if (equal host (%pathname-host defaults))
1187                    (funcall (host-unparse-enough host) pathname defaults)
1188                    (namestring pathname)))
1189            (error            (error
1190             "Cannot determine the namestring for pathnames with no host:~%  ~S"             (intl:gettext "Cannot determine the namestring for pathnames with no host:~%  ~S")
1191             pathname)))))             pathname)))))
1192    
1193    
# Line 1053  a host-structure or string." Line 1223  a host-structure or string."
1223  ;;;  ;;;
1224  (defun pathname-match-p (in-pathname in-wildname)  (defun pathname-match-p (in-pathname in-wildname)
1225    "Pathname matches the wildname template?"    "Pathname matches the wildname template?"
1226    (declare (type path-designator in-pathname))    (declare (type path-designator in-pathname)
1227               ;; Not path-designator because a file-stream can't have a
1228               ;; wild pathname.
1229               (type (or string pathname) in-wildname))
1230    (with-pathname (pathname in-pathname)    (with-pathname (pathname in-pathname)
1231      (with-pathname (wildname in-wildname)      (with-pathname (wildname in-wildname)
1232        (macrolet ((frob (field &optional (op 'components-match ))        (macrolet ((frob (field &optional (op 'components-match ))
# Line 1092  a host-structure or string." Line 1265  a host-structure or string."
1265              (t              (t
1266               (setf in-wildcard t)               (setf in-wildcard t)
1267               (unless subs               (unless subs
1268                 (error "Not enough wildcards in FROM pattern to match ~                 (error (intl:gettext "Not enough wildcards in FROM pattern to match ~
1269                         TO pattern:~%  ~S"                         TO pattern:~%  ~S")
1270                        pattern))                        pattern))
1271               (let ((sub (pop subs)))               (let ((sub (pop subs)))
1272                 (typecase sub                 (typecase sub
# Line 1107  a host-structure or string." Line 1280  a host-structure or string."
1280                   (simple-string                   (simple-string
1281                    (push sub strings))                    (push sub strings))
1282                   (t                   (t
1283                    (error "Can't substitute this into the middle of a word:~                    (error (intl:gettext "Can't substitute this into the middle of a word:~
1284                            ~%  ~S"                            ~%  ~S")
1285                           sub)))))))                           sub)))))))
1286    
1287      (when strings      (when strings
# Line 1128  a host-structure or string." Line 1301  a host-structure or string."
1301  ;;;    Called when we can't see how source and from matched.  ;;;    Called when we can't see how source and from matched.
1302  ;;;  ;;;
1303  (defun didnt-match-error (source from)  (defun didnt-match-error (source from)
1304    (error "Pathname components from Source and From args to TRANSLATE-PATHNAME~@    (error (intl:gettext "Pathname components from Source and From args to TRANSLATE-PATHNAME~@
1305            did not match:~%  ~S ~S"            did not match:~%  ~S ~S")
1306           source from))           source from))
1307    
1308    
# Line 1234  a host-structure or string." Line 1407  a host-structure or string."
1407  ;;;    Called by TRANSLATE-PATHNAME on the directory components of its argument  ;;;    Called by TRANSLATE-PATHNAME on the directory components of its argument
1408  ;;; pathanames to produce the result directory component.  If any leaves the  ;;; pathanames to produce the result directory component.  If any leaves the
1409  ;;; directory NIL, we return the source directory.  The :RELATIVE or :ABSOLUTE  ;;; directory NIL, we return the source directory.  The :RELATIVE or :ABSOLUTE
1410  ;;; is taken from the source directory, except if TO is :ABSOLUTE, in which  ;;; is taken from the TO directory.
 ;;; case the result will be :ABSOLUTE.  
1411  ;;;  ;;;
1412  (defun translate-directories (source from to diddle-case)  (defun translate-directories (source from to diddle-case)
1413    (if (not (and source to from))    (if (not (and source to from))
# Line 1262  a host-structure or string." Line 1434  a host-structure or string."
1434                           (res to-part)))))                           (res to-part)))))
1435                (res))))                (res))))
1436        (collect ((res))        (collect ((res))
1437          (res (if (eq (first to) :absolute)          (res (first to))
                  :absolute  
                  (first source)))  
1438          (let ((subs-left (compute-directory-substitutions (rest source)          (let ((subs-left (compute-directory-substitutions (rest source)
1439                                                            (rest from))))                                                            (rest from))))
1440            (dolist (to-part (rest to))            (dolist (to-part (rest to))
# Line 1273  a host-structure or string." Line 1443  a host-structure or string."
1443                 (assert subs-left)                 (assert subs-left)
1444                 (let ((match (pop subs-left)))                 (let ((match (pop subs-left)))
1445                   (when (listp match)                   (when (listp match)
1446                     (error ":WILD-INFERIORS not paired in from and to ~                     (error (intl:gettext ":WILD-INFERIORS not paired in from and to ~
1447                             patterns:~%  ~S ~S" from to))                             patterns:~%  ~S ~S") from to))
1448                   (res (maybe-diddle-case match diddle-case))))                   (res (maybe-diddle-case match diddle-case))))
1449                ((member :wild-inferiors)                ((member :wild-inferiors)
1450                 (assert subs-left)                 (assert subs-left)
1451                 (let ((match (pop subs-left)))                 (let ((match (pop subs-left)))
1452                   (unless (listp match)                   (unless (listp match)
1453                     (error ":WILD-INFERIORS not paired in from and to ~                     (error (intl:gettext ":WILD-INFERIORS not paired in from and to ~
1454                             patterns:~%  ~S ~S" from to))                             patterns:~%  ~S ~S") from to))
1455                   (dolist (x match)                   (dolist (x match)
1456                     (res (maybe-diddle-case x diddle-case)))))                     (res (maybe-diddle-case x diddle-case)))))
1457                (pattern                (pattern
# Line 1303  a host-structure or string." Line 1473  a host-structure or string."
1473    (with-pathname (source source)    (with-pathname (source source)
1474      (with-pathname (from from-wildname)      (with-pathname (from from-wildname)
1475        (with-pathname (to to-wildname)        (with-pathname (to to-wildname)
1476              (unless (pathname-match-p source from)
1477                (didnt-match-error source from))
1478            (let* ((source-host (%pathname-host source))            (let* ((source-host (%pathname-host source))
1479                   (to-host (%pathname-host to))                   (to-host (%pathname-host to))
1480                   (diddle-case                   (diddle-case
# Line 1315  a host-structure or string." Line 1487  a host-structure or string."
1487                                               (,field to)                                               (,field to)
1488                                               diddle-case)))                                               diddle-case)))
1489                              (if (eq result :error)                              (if (eq result :error)
1490                                  (error "~S doesn't match ~S" source from)                                  (error (intl:gettext "~S doesn't match ~S") source from)
1491                                  result))))                                  result))))
1492                (%make-pathname-object                (%make-pathname-object
1493                 (or to-host source-host)                 (or to-host source-host)
# Line 1364  a host-structure or string." Line 1536  a host-structure or string."
1536    (let ((search-list (gethash (string-downcase name) *search-lists*)))    (let ((search-list (gethash (string-downcase name) *search-lists*)))
1537      (if search-list search-list      (if search-list search-list
1538          (when flame-not-found-p          (when flame-not-found-p
1539            (error "Search-list ~a not defined." name)))))            (error (intl:gettext "Search-list ~a not defined.") name)))))
1540    
1541  ;;; INTERN-SEARCH-LIST -- internal interface.  ;;; INTERN-SEARCH-LIST -- internal interface.
1542  ;;;  ;;;
# Line 1424  a host-structure or string." Line 1596  a host-structure or string."
1596        (cond ((search-list-p search-list)        (cond ((search-list-p search-list)
1597               search-list)               search-list)
1598              (flame-if-none              (flame-if-none
1599               (error "~S doesn't start with a search-list." pathname))               (error (intl:gettext "~S doesn't start with a search-list.") pathname))
1600              (t              (t
1601               nil)))))               nil)))))
1602    
# Line 1446  a host-structure or string." Line 1618  a host-structure or string."
1618                        (make-pathname :host host                        (make-pathname :host host
1619                                       :directory (cons :absolute directory)))                                       :directory (cons :absolute directory)))
1620                    (search-list-expansions search-list))                    (search-list-expansions search-list))
1621            (error "Search list ~S has not been defined yet." pathname)))))            (error (intl:gettext "Search list ~S has not been defined yet.") pathname)))))
1622    
1623  ;;; SEARCH-LIST-DEFINED-P -- public.  ;;; SEARCH-LIST-DEFINED-P -- public.
1624  ;;;  ;;;
# Line 1468  a host-structure or string." Line 1640  a host-structure or string."
1640      (labels      (labels
1641          ((check (target-list path)          ((check (target-list path)
1642             (when (eq search-list target-list)             (when (eq search-list target-list)
1643               (error "That would result in a circularity:~%  ~               (error (intl:gettext "That would result in a circularity:~%  ~
1644                       ~A~{ -> ~A~} -> ~A"                       ~A~{ -> ~A~} -> ~A")
1645                      (search-list-name search-list)                      (search-list-name search-list)
1646                      (reverse path)                      (reverse path)
1647                      (search-list-name target-list)))                      (search-list-name target-list)))
# Line 1482  a host-structure or string." Line 1654  a host-structure or string."
1654               (when (or (pathname-name pathname)               (when (or (pathname-name pathname)
1655                         (pathname-type pathname)                         (pathname-type pathname)
1656                         (pathname-version pathname))                         (pathname-version pathname))
1657                 (error "Search-lists cannot expand into pathnames that have ~                 (error (intl:gettext "Search-lists cannot expand into pathnames that have ~
1658                         a name, type, or ~%version specified:~%  ~S"                         a name, type, or ~%version specified:~%  ~S")
1659                        pathname))                        pathname))
1660               (let ((directory (pathname-directory pathname)))               (let ((directory (pathname-directory pathname)))
1661                 (let ((expansion                 (let ((expansion
# Line 1526  a host-structure or string." Line 1698  a host-structure or string."
1698       ((not search-list)       ((not search-list)
1699        (funcall function pathname))        (funcall function pathname))
1700       ((not (search-list-defined search-list))       ((not (search-list-defined search-list))
1701        (error "Undefined search list: ~A"        (error (intl:gettext "Undefined search list: ~A")
1702               (search-list-name search-list)))               (search-list-name search-list)))
1703       (t       (t
1704        (let ((tail (cddr (pathname-directory pathname))))        (let ((tail (cddr (pathname-directory pathname))))
# Line 1558  a host-structure or string." Line 1730  a host-structure or string."
1730        (let ((ch (schar word i)))        (let ((ch (schar word i)))
1731          (unless (or (alpha-char-p ch) (digit-char-p ch) (char= ch #\-))          (unless (or (alpha-char-p ch) (digit-char-p ch) (char= ch #\-))
1732            (error 'namestring-parse-error            (error 'namestring-parse-error
1733                   :complaint "Logical namestring character ~                   :complaint (intl:gettext "Logical namestring character ~
1734                               is not alphanumeric or hyphen:~%  ~S"                               is not alphanumeric or hyphen:~%  ~S")
1735                   :arguments (list ch)                   :arguments (list ch)
1736                   :namestring word :offset i))))                   :namestring word :offset i))))
1737      word))      word))
# Line 1593  a host-structure or string." Line 1765  a host-structure or string."
1765             found             found
1766             (error 'simple-file-error             (error 'simple-file-error
1767                    :pathname thing                    :pathname thing
1768                    :format-control "Logical host not yet defined: ~S"                    :format-control (intl:gettext "Logical host not yet defined: ~S")
1769                    :format-arguments (list thing)))))                    :format-arguments (list thing)))))
1770      (logical-host thing)))      (logical-host thing)))
1771    
# Line 1629  a host-structure or string." Line 1801  a host-structure or string."
1801              (if (= pos last-pos)              (if (= pos last-pos)
1802                  (when (pattern)                  (when (pattern)
1803                    (error 'namestring-parse-error                    (error 'namestring-parse-error
1804                           :complaint "Double asterisk inside of logical ~                           :complaint (intl:gettext "Double asterisk inside of logical ~
1805                                       word: ~S"                                       word: ~S")
1806                           :arguments (list chunk)                           :arguments (list chunk)
1807                           :namestring namestring                           :namestring namestring
1808                           :offset (+ (cdar chunks) pos)))                           :offset (+ (cdar chunks) pos)))
# Line 1656  a host-structure or string." Line 1828  a host-structure or string."
1828  (defun logical-chunkify (namestr start end)  (defun logical-chunkify (namestr start end)
1829    (collect ((chunks))    (collect ((chunks))
1830      (do ((i start (1+ i))      (do ((i start (1+ i))
1831           (prev 0))           (prev start))
1832          ((= i end)          ((= i end)
1833           (when (> end prev)           (when (> end prev)
1834              (chunks (cons (nstring-upcase (subseq namestr prev end)) prev))))              (chunks (cons (nstring-upcase (subseq namestr prev end)) prev))))
# Line 1668  a host-structure or string." Line 1840  a host-structure or string."
1840            (setq prev (1+ i))            (setq prev (1+ i))
1841            (unless (member ch '(#\; #\: #\.))            (unless (member ch '(#\; #\: #\.))
1842              (error 'namestring-parse-error              (error 'namestring-parse-error
1843                     :complaint "Illegal character for logical pathname:~%  ~S"                     :complaint (intl:gettext "Illegal character for logical pathname:~%  ~S")
1844                     :arguments (list ch)                     :arguments (list ch)
1845                     :namestring namestr                     :namestring namestr
1846                     :offset i))                     :offset i))
# Line 1692  a host-structure or string." Line 1864  a host-structure or string."
1864        (labels ((expecting (what chunks)        (labels ((expecting (what chunks)
1865                   (unless (and chunks (simple-string-p (caar chunks)))                   (unless (and chunks (simple-string-p (caar chunks)))
1866                     (error 'namestring-parse-error                     (error 'namestring-parse-error
1867                            :complaint "Expecting ~A, got ~:[nothing~;~:*~S~]."                            :complaint (intl:gettext "Expecting ~A, got ~:[nothing~;~:*~S~].")
1868                            :arguments (list what (caar chunks))                            :arguments (list (intl:gettext what) (caar chunks))
1869                            :namestring namestr                            :namestring namestr
1870                            :offset (if chunks (cdar chunks) end)))                            :offset (if chunks (cdar chunks) end)))
1871                   (caar chunks))                   (caar chunks))
# Line 1701  a host-structure or string." Line 1873  a host-structure or string."
1873                   (case (caadr chunks)                   (case (caadr chunks)
1874                     (#\:                     (#\:
1875                      (setq host                      (setq host
1876                            (find-logical-host (expecting "a host name" chunks)))                            (find-logical-host (expecting _N"a host name" chunks)))
1877                      (parse-relative (cddr chunks)))                      (parse-relative (cddr chunks)))
1878                     (t                     (t
1879                      (parse-relative chunks))))                      (parse-relative chunks))))
# Line 1717  a host-structure or string." Line 1889  a host-structure or string."
1889                   (case (caadr chunks)                   (case (caadr chunks)
1890                     (#\;                     (#\;
1891                      (directory                      (directory
1892                       (let ((res (expecting "a directory name" chunks)))                       (let ((res (expecting _N"a directory name" chunks)))
1893                         (cond ((string= res "..") :up)                         (cond ((string= res "..") :up)
1894                               ((string= res "**") :wild-inferiors)                               ((string= res "**") :wild-inferiors)
1895                               (t                               (t
# Line 1727  a host-structure or string." Line 1899  a host-structure or string."
1899                      (parse-name chunks))))                      (parse-name chunks))))
1900                 (parse-name (chunks)                 (parse-name (chunks)
1901                   (when chunks                   (when chunks
1902                     (expecting "a file name" chunks)                     (expecting _N"a file name" chunks)
1903                     (setq name (maybe-make-logical-pattern namestr chunks))                     (setq name (maybe-make-logical-pattern namestr chunks))
1904                     (expecting-dot (cdr chunks))))                     (expecting-dot (cdr chunks))))
1905                 (expecting-dot (chunks)                 (expecting-dot (chunks)
1906                   (when chunks                   (when chunks
1907                     (unless (eql (caar chunks) #\.)                     (unless (eql (caar chunks) #\.)
1908                       (error 'namestring-parse-error                       (error 'namestring-parse-error
1909                              :complaint "Expecting a dot, got ~S."                              :complaint _N"Expecting a dot, got ~S."
1910                              :arguments (list (caar chunks))                              :arguments (list (caar chunks))
1911                              :namestring namestr                              :namestring namestr
1912                              :offset (cdar chunks)))                              :offset (cdar chunks)))
# Line 1742  a host-structure or string." Line 1914  a host-structure or string."
1914                         (parse-version (cdr chunks))                         (parse-version (cdr chunks))
1915                         (parse-type (cdr chunks)))))                         (parse-type (cdr chunks)))))
1916                 (parse-type (chunks)                 (parse-type (chunks)
1917                   (expecting "a file type" chunks)                   (expecting _N"a file type" chunks)
1918                   (setq type (maybe-make-logical-pattern namestr chunks))                   (setq type (maybe-make-logical-pattern namestr chunks))
1919                   (expecting-dot (cdr chunks)))                   (expecting-dot (cdr chunks)))
1920                 (parse-version (chunks)                 (parse-version (chunks)
1921                   (let ((str (expecting "a positive integer, * or NEWEST"                   (let ((str (expecting _N"a positive integer, * or NEWEST"
1922                                         chunks)))                                         chunks)))
1923                     (cond                     (cond
1924                      ((string= str "*") (setq version :wild))                      ((string= str "*") (setq version :wild))
# Line 1757  a host-structure or string." Line 1929  a host-structure or string."
1929                           (parse-integer str :junk-allowed t)                           (parse-integer str :junk-allowed t)
1930                         (unless (and res (plusp res))                         (unless (and res (plusp res))
1931                           (error 'namestring-parse-error                           (error 'namestring-parse-error
1932                                  :complaint "Expected a positive integer, ~                                  :complaint (intl:gettext "Expected a positive integer, ~
1933                                              got ~S"                                              got ~S")
1934                                  :arguments (list str)                                  :arguments (list str)
1935                                  :namestring namestr                                  :namestring namestr
1936                                  :offset (+ pos (cdar chunks))))                                  :offset (+ pos (cdar chunks))))
1937                         (setq version res)))))                         (setq version res)))))
1938                   (when (cdr chunks)                   (when (cdr chunks)
1939                     (error 'namestring-parse-error                     (error 'namestring-parse-error
1940                            :complaint "Extra stuff after end of file name."                            :complaint (intl:gettext "Extra stuff after end of file name.")
1941                            :namestring namestr                            :namestring namestr
1942                            :offset (cdadr chunks)))))                            :offset (cdadr chunks)))))
1943          (parse-host (logical-chunkify namestr start end)))          (parse-host (logical-chunkify namestr start end)))
# Line 1777  a host-structure or string." Line 1949  a host-structure or string."
1949  ;;; Can't defvar here because not all host methods are loaded yet.  ;;; Can't defvar here because not all host methods are loaded yet.
1950  (declaim (special *logical-pathname-defaults*))  (declaim (special *logical-pathname-defaults*))
1951    
1952    (defun logical-pathname-namestring-p (pathspec)
1953      ;; Checks to see if pathspec is a logical pathname or not.
1954      (let ((res (parse-namestring pathspec nil *logical-pathname-defaults*)))
1955        ;; Even though *logical-pathname-defaults* has a host with name
1956        ;; BOGUS, the user can still use BOGUS as a logical host because
1957        ;; we compare with EQ here, so the users BOGUS host is never our
1958        ;; BOGUS host.
1959        (values (not (eq (%pathname-host res)
1960                         (%pathname-host *logical-pathname-defaults*)))
1961                res)))
1962    
1963  ;;; LOGICAL-PATHNAME -- Public  ;;; LOGICAL-PATHNAME -- Public
1964  ;;;  ;;;
1965  (defun logical-pathname (pathspec)  (defun logical-pathname (pathspec)
# Line 1785  a host-structure or string." Line 1968  a host-structure or string."
1968             (values logical-pathname))             (values logical-pathname))
1969    (if (typep pathspec 'logical-pathname)    (if (typep pathspec 'logical-pathname)
1970        pathspec        pathspec
1971        (let ((res (parse-namestring pathspec nil *logical-pathname-defaults*)))        (multiple-value-bind (logical-p res)
1972          (when (eq (%pathname-host res)            (logical-pathname-namestring-p pathspec)
1973                    (%pathname-host *logical-pathname-defaults*))          (unless logical-p
1974            (error            (error
1975             'simple-type-error             'simple-type-error
1976             :format-control "Logical namestring does not specify a host:~%  ~S"             :format-control (intl:gettext "Logical namestring does not specify a host:~%  ~S")
1977             :format-arguments (list pathspec)             :format-arguments (list pathspec)
1978             :datum pathspec             :datum pathspec
1979             :expected-type '(satisfies logical-pathname-namestring-p)))             :expected-type '(satisfies logical-pathname-namestring-p)))
1980            ;; Make sure the result is a logical pathname.  This can
1981            ;; happen if the pathspec is stream, and the stream was opened
1982            ;; with a pathname instead of a logical-pathname.
1983            (check-type res logical-pathname)
1984          res)))          res)))
1985    
1986    
# Line 1819  a host-structure or string." Line 2006  a host-structure or string."
2006                  ((eq dir :wild-inferiors)                  ((eq dir :wild-inferiors)
2007                   (pieces "**;"))                   (pieces "**;"))
2008                  (t                  (t
2009                   (error "Invalid directory component: ~S" dir))))))                   (error (intl:gettext "Invalid directory component: ~S") dir))))))
2010      (apply #'concatenate 'simple-string (pieces))))      (apply #'concatenate 'simple-string (pieces))))
2011    
2012    
# Line 1838  a host-structure or string." Line 2025  a host-structure or string."
2025                     (strings "**"))                     (strings "**"))
2026                    ((eq piece :multi-char-wild)                    ((eq piece :multi-char-wild)
2027                     (strings "*"))                     (strings "*"))
2028                    (t (error "Invalid keyword: ~S" piece))))))                    (t (error (intl:gettext "Invalid keyword: ~S") piece))))))
2029         (apply #'concatenate 'simple-string (strings))))))         (apply #'concatenate 'simple-string (strings))))))
2030    
2031  ;;; UNPARSE-ENOUGH-NAMESTRING -- Internal  ;;; UNPARSE-ENOUGH-NAMESTRING -- Internal
2032  ;;;  ;;;
2033  (defun unparse-enough-namestring (pathname defaults)  (defun unparse-enough-namestring (pathname defaults)
2034    (let* ((path-dir (pathname-directory pathname))    (let* ((path-dir (pathname-directory pathname))
2035          (def-dir (pathname-directory defaults))           (def-dir (pathname-directory defaults))
2036          (enough-dir           (enough-dir
2037           ;; Go down the directory lists to see what matches.  What's            ;; Go down the directory lists to see what matches.  What's
2038           ;; left is what we want, more or less.            ;; left is what we want, more or less.  But there has to be
2039           (cond ((and (eq (first path-dir) (first def-dir))            ;; something in common.
2040                       (eq (first path-dir) :absolute))            (cond ((and (eq (first path-dir) (first def-dir))
2041                  ;; Both paths are :absolute, so find where the common                        (eq (first path-dir) :absolute)
2042                  ;; parts end and return what's left                        (second path-dir)
2043                  (do* ((p (rest path-dir) (rest p))                        (second def-dir)
2044                        (d (rest def-dir) (rest d)))                        (equal (second path-dir) (second def-dir)))
2045                       ((or (endp p) (endp d)                   ;; Both paths are :absolute, so find where the common
2046                            (not (equal (first p) (first d))))                   ;; parts end and return what's left
2047                        `(:relative ,@p))))                   (do* ((p (rest path-dir) (rest p))
2048                 (t                         (d (rest def-dir) (rest d)))
2049                  ;; At least one path is :relative, so just return the                        ((or (endp p) (endp d)
2050                  ;; original path.  If the original path is :relative,                             (not (equal (first p) (first d))))
2051                  ;; then that's the right one.  If PATH-DIR is                         `(:relative ,@p))))
2052                  ;; :absolute, we want to return that except when                  (t
2053                  ;; DEF-DIR is :absolute, as handled above. so return                   ;; Both paths are absolute, but there's nothing in
2054                  ;; the original directory.                   ;; common, so return the original.  Or one path is
2055                  path-dir))))                   ;; :relative, so just return the original path.  If
2056      (make-pathname :host (%pathname-host pathname)                   ;; the original path is :relative, then that's the
2057                    :directory enough-dir                   ;; right one.  If PATH-DIR is :absolute, we want to
2058                    :name (pathname-name pathname)                   ;; return that except when DEF-DIR is :absolute, as
2059                    :type (pathname-type pathname)                   ;; handled above. so return the original directory.
2060                    :version (pathname-version pathname))))                   path-dir))))
2061        (namestring (make-pathname :host (%pathname-host pathname)
2062                                   :directory enough-dir
2063                                   :name (pathname-name pathname)
2064                                   :type (pathname-type pathname)
2065                                   :version (pathname-version pathname)))))
2066    
2067  ;;; UNPARSE-LOGICAL-NAMESTRING -- Internal  ;;; UNPARSE-LOGICAL-NAMESTRING -- Internal
2068  ;;;  ;;;
# Line 1896  a host-structure or string." Line 2088  a host-structure or string."
2088    (collect ((res))    (collect ((res))
2089      (dolist (tr transl-list)      (dolist (tr transl-list)
2090        (unless (and (consp tr) (= (length tr) 2))        (unless (and (consp tr) (= (length tr) 2))
2091          (error "Logical pathname translation is not a two-list:~%  ~S"          (error (intl:gettext "Logical pathname translation is not a two-list:~%  ~S")
2092                 tr))                 tr))
2093        (let ((from (first tr)))        (let ((from (first tr)))
2094          (res (list (if (typep from 'logical-pathname)          (res (list (if (typep from 'logical-pathname)
# Line 1923  a host-structure or string." Line 2115  a host-structure or string."
2115             (type list translations)             (type list translations)
2116             (values list))             (values list))
2117    
2118      (let ((maybe-search-list-host (concatenate 'string host ":")))
2119        (when (and (not (logical-pathname-p (pathname maybe-search-list-host)))
2120                   (search-list-defined-p maybe-search-list-host))
2121          (cerror (intl:gettext "Clobber search-list host with logical pathname host")
2122                  (intl:gettext "~S names a CMUCL search-list")
2123                  host)))
2124    (let ((host (intern-logical-host host)))    (let ((host (intern-logical-host host)))
2125      (setf (logical-host-canon-transls host)      (setf (logical-host-canon-transls host)
2126            (canonicalize-logical-pathname-translations translations host))            (canonicalize-logical-pathname-translations translations host))
# Line 1951  a host-structure or string." Line 2149  a host-structure or string."
2149                                               :type "translations"))                                               :type "translations"))
2150          (if *load-verbose*          (if *load-verbose*
2151              (format *error-output*              (format *error-output*
2152                      ";; Loading pathname translations from ~A~%"                      (intl:gettext ";; Loading pathname translations from ~A~%")
2153                      (namestring (truename in-str))))                      (namestring (truename in-str))))
2154          (setf (logical-pathname-translations host) (read in-str)))          (setf (logical-pathname-translations host) (read in-str)))
2155        t)))        t)))
# Line 1967  a host-structure or string." Line 2165  a host-structure or string."
2165       (dolist (x (logical-host-canon-transls (%pathname-host pathname))       (dolist (x (logical-host-canon-transls (%pathname-host pathname))
2166                  (error 'simple-file-error                  (error 'simple-file-error
2167                         :pathname pathname                         :pathname pathname
2168                         :format-control "No translation for ~S"                         :format-control (intl:gettext "No translation for ~S")
2169                         :format-arguments (list pathname)))                         :format-arguments (list pathname)))
2170         (destructuring-bind (from to) x         (destructuring-bind (from to) x
2171           (when (pathname-match-p pathname from)           (when (pathname-match-p pathname from)

Legend:
Removed from v.1.59.2.1  
changed lines
  Added in v.1.92

  ViewVC Help
Powered by ViewVC 1.1.5