/[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.27 by ram, Sat Jan 18 14:30:44 1997 UTC revision 1.28 by pw, Wed Feb 5 16:15:56 1997 UTC
# Line 112  Line 112 
112             (error "~S Cannot be printed readably." pathname))             (error "~S Cannot be printed readably." pathname))
113            (t            (t
114             (funcall (formatter "#<Unprintable pathname, Host=~S, Device=~S, ~             (funcall (formatter "#<Unprintable pathname, Host=~S, Device=~S, ~
115                                  Directory=~S, File=~S, Name=~S, Version=~S>")                                  Directory=~S, Name=~S, Type=~S, Version=~S>")
116                      stream                      stream
117                      (%pathname-host pathname)                      (%pathname-host pathname)
118                      (%pathname-device pathname)                      (%pathname-device pathname)
# Line 178  Line 178 
178                      (%pathname-type pathname)                      (%pathname-type pathname)
179                      (%pathname-version pathname))))))                      (%pathname-version pathname))))))
180    
181    ;;; %MAKE-PATHNAME-OBJECT -- internal
182    ;;;
183    ;;; A pathname is logical if the host component is a logical-host.
184    ;;; This constructor is used to make an instance of the correct type
185    ;;; from parsed arguments.
186    
187    (defun %make-pathname-object (host device directory name type version)
188      (if (typep host 'logical-host)
189          (%make-logical-pathname host :unspecific directory name type version)
190          (%make-pathname         host device      directory name type version)))
191    
192  ;;; *LOGICAL-HOSTS* --internal.  ;;; *LOGICAL-HOSTS* --internal.
193  ;;;  ;;;
194  ;;; Hash table searching maps a logical-pathname's host to their physical  ;;; Hash table searching maps a logical-pathname's host to their physical
# Line 405  Line 416 
416  ;;; Converts the var, a host or string name for a host, into a logical-host  ;;; Converts the var, a host or string name for a host, into a logical-host
417  ;;; structure or nil if not defined.  ;;; structure or nil if not defined.
418  ;;;  ;;;
419    ;;; pw notes 1/12/97 this potentially useful macro is not used anywhere
420    ;;; and 'find-host' is not defined. 'find-logical-host' seems to be needed.
421    ;;;
422  (defmacro with-host ((var expr) &body body)  (defmacro with-host ((var expr) &body body)
423    `(let ((,var (let ((,var ,expr))    `(let ((,var (let ((,var ,expr))
424                   (typecase ,var                   (typecase ,var
425                     (logical-host ,var)                     (logical-host ,var)
426                     (string (find-host ,var))                     (string (find-logical-host ,var nil))
427                     (t nil)))))                     (t nil)))))
428       ,@body))       ,@body))
429    
# Line 532  Line 546 
546                (and default-host pathname-host                (and default-host pathname-host
547                     (not (eq (host-customary-case default-host)                     (not (eq (host-customary-case default-host)
548                              (host-customary-case pathname-host))))))                              (host-customary-case pathname-host))))))
549          (make-pathname :host (or pathname-host default-host)          (%make-pathname-object
550                         :device           (or pathname-host default-host)
551                         (or (%pathname-device pathname)           (or (%pathname-device pathname)
552                              (maybe-diddle-case (%pathname-device defaults)               (maybe-diddle-case (%pathname-device defaults)
553                                                 diddle-case))                                  diddle-case))
554                         :directory           (merge-directories (%pathname-directory pathname)
555                          (merge-directories (%pathname-directory pathname)                              (%pathname-directory defaults)
556                                             (%pathname-directory defaults)                              diddle-case)
557                                             diddle-case)           (or (%pathname-name pathname)
558                          :name               (maybe-diddle-case (%pathname-name defaults)
559                          (or (%pathname-name pathname)                                  diddle-case))
560                              (maybe-diddle-case (%pathname-name defaults)           (or (%pathname-type pathname)
561                                                 diddle-case))               (maybe-diddle-case (%pathname-type defaults)
562                          :type                                  diddle-case))
563                          (or (%pathname-type pathname)           (or (%pathname-version pathname)
564                              (maybe-diddle-case (%pathname-type defaults)               default-version))))))
                                                diddle-case))  
                         :version  
                         (or (%pathname-version pathname)  
                             default-version))))))  
565    
566  ;;; IMPORT-DIRECTORY -- Internal  ;;; IMPORT-DIRECTORY -- Internal
567  ;;;  ;;;
# Line 615  a host-structure or string." Line 625  a host-structure or string."
625           ;; toy@rtp.ericsson.se: CLHS says make-pathname can take a           ;; toy@rtp.ericsson.se: CLHS says make-pathname can take a
626           ;; string (as a logical-host) for the host part.  We map that           ;; string (as a logical-host) for the host part.  We map that
627           ;; string into the corresponding logical host structure.           ;; string into the corresponding logical host structure.
628           (host (or (gethash host *logical-hosts*) host default-host))  
629             ;; pw@snoopy.mv.com:
630             ;; HyperSpec says for the arg to MAKE-PATHNAME;
631             ;; "host---a valid physical pathname host. ..."
632             ;; where it probably means -- a valid pathname host.
633             ;; "valid pathname host n. a valid physical pathname host or
634             ;; a valid logical pathname host."
635             ;; and defines
636             ;; "valid physical pathname host n. any of a string,
637             ;; a list of strings, or the symbol :unspecific,
638             ;; that is recognized by the implementation as the name of a host."
639             ;; "valid logical pathname host n. a string that has been defined
640             ;; as the name of a logical host. ..."
641             ;; HS is silent on what happens if the :host arg is NOT one of these.
642             ;; It seems an error message is appropriate.
643             (host (typecase host
644                     (host host)            ; A valid host, use it.
645                     (string (find-logical-host host t)) ; logical-host or lose.
646                     (t default-host)))     ; unix-host
647           (diddle-args (and (eq (host-customary-case host) :lower)           (diddle-args (and (eq (host-customary-case host) :lower)
648                             (eq case :common)))                             (eq case :common)))
649           (diddle-defaults           (diddle-defaults
# Line 647  a host-structure or string." Line 675  a host-structure or string."
675                                              diddle-defaults))                                              diddle-defaults))
676                          (t                          (t
677                           nil))))                           nil))))
678        (if (logical-host-p host)        (%make-pathname-object host
679            (%make-logical-pathname                               dev ; forced to :unspecific when logical-host
680             host                               dir
681             :unspecific                               (pick name namep %pathname-name)
682             dir                               (pick type typep %pathname-type)
683             (pick name namep %pathname-name)                               ver))))
            (pick type typep %pathname-type)  
            ver)  
           (%make-pathname  
            host  
            dev  
            dir  
            (pick name namep %pathname-name)  
            (pick type typep %pathname-type)  
            ver)))))  
684    
685  ;;; PATHNAME-HOST -- Interface  ;;; PATHNAME-HOST -- Interface
686  ;;;  ;;;
# Line 784  a host-structure or string." Line 803  a host-structure or string."
803                      does not match explicit host argument: ~S"                      does not match explicit host argument: ~S"
804                     host))                     host))
805            (let ((pn-host (or new-host parse-host)))            (let ((pn-host (or new-host parse-host)))
806              (values (funcall (if (typep pn-host 'logical-host)              (values (%make-pathname-object
807                                   #'%make-logical-pathname                       pn-host device directory file type version)
                                  #'%make-pathname)  
                              pn-host device directory file type version)  
808                      end))))))                      end))))))
809    
810    
# Line 1190  a host-structure or string." Line 1207  a host-structure or string."
1207                              (if (eq result :error)                              (if (eq result :error)
1208                                  (error "~S doesn't match ~S" source from)                                  (error "~S doesn't match ~S" source from)
1209                                  result))))                                  result))))
1210                #+nil ;; pw- 1/3/97 This doesn't work.                (%make-pathname-object
1211                (%make-pathname (or to-host source-host)                 (or to-host source-host)
1212                                (frob %pathname-device)                 (frob %pathname-device)
1213                                (frob %pathname-directory translate-directories)                 (frob %pathname-directory translate-directories)
1214                                (frob %pathname-name)                 (frob %pathname-name)
1215                                (frob %pathname-type)                 (frob %pathname-type)
1216                                (frob %pathname-version))                 (frob %pathname-version))))))))
   
               (let ((host      (or to-host source-host))  
                     (device    (frob %pathname-device))  
                     (directory (frob %pathname-directory translate-directories))  
                     (name      (frob %pathname-name))  
                     (type      (frob %pathname-type))  
                     (version   (frob %pathname-version)))  
                 (if (logical-host-p host)  
                      (%make-logical-pathname  
                       host :unspecific directory name type version)  
                      (%make-pathname  
                       host device directory name type version)))))))))  
1217    
1218    
1219  ;;;; Search lists.  ;;;; Search lists.

Legend:
Removed from v.1.27  
changed lines
  Added in v.1.28

  ViewVC Help
Powered by ViewVC 1.1.5