/[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.35 by dtc, Tue Dec 29 17:55:51 1998 UTC revision 1.36 by dtc, Sat Jan 9 11:20:30 1999 UTC
# Line 63  Line 63 
63                         #'(lambda (x) (logical-host-name (%pathname-host x))))                         #'(lambda (x) (logical-host-name (%pathname-host x))))
64                        (:unparse-directory #'unparse-logical-directory)                        (:unparse-directory #'unparse-logical-directory)
65                        (:unparse-file #'unparse-unix-file)                        (:unparse-file #'unparse-unix-file)
66                        (:unparse-enough #'identity)                        (:unparse-enough #'unparse-enough-namestring)
67                        (:customary-case :upper)))                        (:customary-case :upper)))
68    (name "" :type simple-base-string)    (name "" :type simple-base-string)
69    (translations nil :type list)    (translations nil :type list)
# Line 1151  a host-structure or string." Line 1151  a host-structure or string."
1151  ;;;    Called by TRANSLATE-PATHNAME on the directory components of its argument  ;;;    Called by TRANSLATE-PATHNAME on the directory components of its argument
1152  ;;; pathanames to produce the result directory component.  If any leaves the  ;;; pathanames to produce the result directory component.  If any leaves the
1153  ;;; directory NIL, we return the source directory.  The :RELATIVE or :ABSOLUTE  ;;; directory NIL, we return the source directory.  The :RELATIVE or :ABSOLUTE
1154  ;;; is always taken from the source directory. If TO is :absolute, the result  ;;; is taken from the source directory, except if TO is :ABSOLUTE, in which
1155  ;;; will be :absolute  ;;; case the result will be :ABSOLUTE.
1156  ;;;  ;;;
1157  (defun translate-directories (source from to diddle-case)  (defun translate-directories (source from to diddle-case)
1158    (if (not (and source to from))    (if (not (and source to from))
# Line 1712  a host-structure or string." Line 1712  a host-structure or string."
1712                    (t (error "Invalid keyword: ~S" piece))))))                    (t (error "Invalid keyword: ~S" piece))))))
1713         (apply #'concatenate 'simple-string (strings))))))         (apply #'concatenate 'simple-string (strings))))))
1714    
1715    ;;; UNPARSE-ENOUGH-NAMESTRING -- Internal
1716    ;;;
1717    (defun unparse-enough-namestring (pathname defaults)
1718      (let* ((path-dir (pathname-directory pathname))
1719            (def-dir (pathname-directory defaults))
1720            (enough-dir
1721             ;; Go down the directory lists to see what matches.  What's
1722             ;; left is what we want, more or less.
1723             (cond ((and (eq (first path-dir) (first def-dir))
1724                         (eq (first path-dir) :absolute))
1725                    ;; Both paths are :absolute, so find where the common
1726                    ;; parts end and return what's left
1727                    (do* ((p (rest path-dir) (rest p))
1728                          (d (rest def-dir) (rest d)))
1729                         ((or (endp p) (endp d)
1730                              (not (equal (first p) (first d))))
1731                          `(:relative ,@p))))
1732                   (t
1733                    ;; At least one path is :relative, so just return the
1734                    ;; original path.  If the original path is :relative,
1735                    ;; then that's the right one.  If PATH-DIR is
1736                    ;; :absolute, we want to return that except when
1737                    ;; DEF-DIR is :absolute, as handled above. so return
1738                    ;; the original directory.
1739                    path-dir))))
1740        (make-pathname :host (pathname-host pathname)
1741                      :directory enough-dir
1742                      :name (pathname-name pathname)
1743                      :type (pathname-type pathname)
1744                      :version (pathname-version pathname))))
1745    
1746  ;;; UNPARSE-LOGICAL-NAMESTRING -- Internal  ;;; UNPARSE-LOGICAL-NAMESTRING -- Internal
1747  ;;;  ;;;

Legend:
Removed from v.1.35  
changed lines
  Added in v.1.36

  ViewVC Help
Powered by ViewVC 1.1.5