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

Diff of /src/code/filesys.lisp

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

revision 1.9 by ram, Thu Apr 25 13:25:48 1991 UTC revision 1.10 by ram, Tue May 28 17:50:35 1991 UTC
# Line 82  Line 82 
82    "Create a pathname from :host, :device, :directory, :name, :type and :version.    "Create a pathname from :host, :device, :directory, :name, :type and :version.
83    If any field is ommitted, it is obtained from :defaults as though by    If any field is ommitted, it is obtained from :defaults as though by
84    merge-pathnames."    merge-pathnames."
85      (flet ((make-it (host device directory name type version)
86               (%make-pathname
87                (if host
88                    (if (stringp host) (coerce host 'simple-string) host)
89                    (%pathname-host *default-pathname-defaults*))
90                (if (stringp device) (coerce device 'simple-string) device)
91                (if (stringp directory)
92                    (%pathname-directory (parse-namestring directory))
93                    directory)
94                (if (stringp name) (coerce name 'simple-string) name)
95                (if (stringp type) (coerce type 'simple-string) type)
96                version)))
97    (if defaults    (if defaults
98        (let ((defaults (pathname defaults)))        (let ((defaults (pathname defaults)))
99          (unless hostp          (make-it (if hostp host (%pathname-host defaults))
100            (setq host (%pathname-host defaults)))                   (if devicep device (%pathname-device defaults))
101          (unless devicep                   (if directoryp directory (%pathname-directory defaults))
102            (setq device (%pathname-device defaults)))                   (if namep name (%pathname-name defaults))
103          (unless directoryp                   (if typep type (%pathname-type defaults))
104            (setq directory (%pathname-directory defaults)))                   (if versionp version (%pathname-version defaults))))
105          (unless namep        (make-it host device directory name type version))))
           (setq name (%pathname-name defaults)))  
         (unless typep  
           (setq type (%pathname-type defaults)))  
         (unless versionp  
           (setq version (%pathname-version defaults))))  
       (unless hostp  
         (setq host (%pathname-host *default-pathname-defaults*))))  
   
   (when (stringp directory)  
     (setq directory (%pathname-directory (parse-namestring directory))))  
   (%make-pathname  
    (if (stringp host) (coerce host 'simple-string) host)  
    (if (stringp device) (coerce device 'simple-string) device)  
    directory  
    (if (stringp name) (coerce name 'simple-string) name)  
    (if (stringp type) (coerce type 'simple-string) type)  
    version))  
106    
107    
108  ;;; These can not be done by the accessors because the pathname arg may be  ;;; These can not be done by the accessors because the pathname arg may be
# Line 228  Line 223 
223                                  :name name                                  :name name
224                                  :type type))))                                  :type type))))
225              (pathname              (pathname
              (setf end start)  
226               thing)               thing)
227              (stream              (stream
              (setf end start)  
228               (pathname (file-name thing))))))               (pathname (file-name thing))))))
229      (unless (or (null host)      (unless (or (null host)
230                  (null (pathname-host pathname))                  (null (pathname-host pathname))
# Line 241  Line 234 
234                'parse-namestring                'parse-namestring
235                (pathname-host pathname)                (pathname-host pathname)
236                host))                host))
237      (values pathname end)))      ;;
238        ;; ### ??? what should the second value be???
239        (values pathname (or end start))))
240    
241    
242  (defun pathname (thing)  (defun pathname (thing)
# Line 265  Line 260 
260    gets it from Default-Version."    gets it from Default-Version."
261    ;;    ;;
262    ;; finish hairy argument defaulting    ;; finish hairy argument defaulting
263    (setq pathname (pathname pathname))    (let ((pathname (pathname pathname))
264    (setq defaults (pathname defaults))          (defaults (pathname defaults)))
265    ;;      ;;
266    ;; make a new pathname      ;; make a new pathname
267    (let ((name (%pathname-name pathname))      (let ((name (%pathname-name pathname))
268          (device (%pathname-device pathname)))            (device (%pathname-device pathname)))
269      (%make-pathname        (%make-pathname
270       (or (%pathname-host pathname) (%pathname-host defaults))         (or (%pathname-host pathname) (%pathname-host defaults))
271       (or device (%pathname-device defaults))         (or device (%pathname-device defaults))
272       (or (%pathname-directory pathname) (%pathname-directory defaults))         (or (%pathname-directory pathname) (%pathname-directory defaults))
273       (or name (%pathname-name defaults))         (or name (%pathname-name defaults))
274       (or (%pathname-type pathname) (%pathname-type defaults))         (or (%pathname-type pathname) (%pathname-type defaults))
275       (or (%pathname-version pathname)         (or (%pathname-version pathname)
276           (if name             (if name
277               default-version                 default-version
278               (or (%pathname-version defaults) default-version))))))                 (or (%pathname-version defaults) default-version)))))))
279    
280    
281  ;;;; NAMESTRING and other stringification stuff.  ;;;; NAMESTRING and other stringification stuff.
# Line 450  Line 445 
445  (defun enough-namestring (pathname &optional  (defun enough-namestring (pathname &optional
446                                     (defaults *default-pathname-defaults*))                                     (defaults *default-pathname-defaults*))
447    "Returns a string which uniquely identifies PATHNAME w.r.t. DEFAULTS."    "Returns a string which uniquely identifies PATHNAME w.r.t. DEFAULTS."
448    (setq pathname (pathname pathname))    (let* ((pathname (pathname pathname))
449    (setq defaults (pathname defaults))           (defaults (pathname defaults))
450    (let* ((device (%pathname-device pathname))           (device (%pathname-device pathname))
451           (directory (%pathname-directory pathname))           (directory (%pathname-directory pathname))
452           (name (%pathname-name pathname))           (name (%pathname-name pathname))
453           (type (%pathname-type pathname))           (type (%pathname-type pathname))

Legend:
Removed from v.1.9  
changed lines
  Added in v.1.10

  ViewVC Help
Powered by ViewVC 1.1.5