X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-pathname.lisp;h=f3dd15678ef4b8d79ffdd5726bbfb2269aa23f4e;hb=b19093fa94d6e1785abee99c35c9a610e8777671;hp=eea013f48c278a3884d1949f6b5dc4158e57e07d;hpb=1c347eae5ec81b6f41db9d27c1fe6d34abe1d3ca;p=sbcl.git diff --git a/src/code/target-pathname.lisp b/src/code/target-pathname.lisp index eea013f..f3dd156 100644 --- a/src/code/target-pathname.lisp +++ b/src/code/target-pathname.lisp @@ -71,7 +71,7 @@ ;; but the arguments given in the X3J13 cleanup issue ;; PATHNAME-LOGICAL:ADD seem compelling: we should canonicalize the ;; case, and uppercase is the ordinary way to do that. - (flet ((upcase-maybe (x) (typecase x (string (string-upcase x)) (t x)))) + (flet ((upcase-maybe (x) (typecase x (string (logical-word-or-lose x)) (t x)))) (if (typep host 'logical-host) (%make-logical-pathname host :unspecific @@ -529,7 +529,7 @@ a host-structure or string." (defun pathname-host (pathname &key (case :local)) #!+sb-doc - "Accessor for the pathname's host." + "Return PATHNAME's host." (declare (type pathname-designator pathname) (type (member :local :common) case) (values host) @@ -539,7 +539,7 @@ a host-structure or string." (defun pathname-device (pathname &key (case :local)) #!+sb-doc - "Accessor for pathname's device." + "Return PATHNAME's device." (declare (type pathname-designator pathname) (type (member :local :common) case)) (with-pathname (pathname pathname) @@ -551,7 +551,7 @@ a host-structure or string." (defun pathname-directory (pathname &key (case :local)) #!+sb-doc - "Accessor for the pathname's directory list." + "Return PATHNAME's directory." (declare (type pathname-designator pathname) (type (member :local :common) case)) (with-pathname (pathname pathname) @@ -562,7 +562,7 @@ a host-structure or string." :lower))))) (defun pathname-name (pathname &key (case :local)) #!+sb-doc - "Accessor for the pathname's name." + "Return PATHNAME's name." (declare (type pathname-designator pathname) (type (member :local :common) case)) (with-pathname (pathname pathname) @@ -574,7 +574,7 @@ a host-structure or string." (defun pathname-type (pathname &key (case :local)) #!+sb-doc - "Accessor for the pathname's name." + "Return PATHNAME's type." (declare (type pathname-designator pathname) (type (member :local :common) case)) (with-pathname (pathname pathname) @@ -586,7 +586,7 @@ a host-structure or string." (defun pathname-version (pathname) #!+sb-doc - "Accessor for the pathname's version." + "Return PATHNAME's version." (declare (type pathname-designator pathname)) (with-pathname (pathname pathname) (%pathname-version pathname))) @@ -849,7 +849,7 @@ a host-structure or string." (defun substitute-into (pattern subs diddle-case) (declare (type pattern pattern) (type list subs) - (values (or simple-base-string pattern))) + (values (or simple-base-string pattern) list)) (let ((in-wildcard nil) (pieces nil) (strings nil)) @@ -1198,27 +1198,20 @@ a host-structure or string." values) (defun %enumerate-search-list (pathname function) - (/show0 "entering %ENUMERATE-SEARCH-LIST") (let* ((pathname (if (typep pathname 'logical-pathname) (translate-logical-pathname pathname) pathname)) (search-list (extract-search-list pathname nil))) - (/show0 "PATHNAME and SEARCH-LIST computed") (cond ((not search-list) - (/show0 "no search list") (funcall function pathname)) ((not (search-list-defined search-list)) - (/show0 "undefined search list") (error "undefined search list: ~A" (search-list-name search-list))) (t - (/show0 "general case") (let ((tail (cddr (pathname-directory pathname)))) - (/show0 "TAIL computed") (dolist (expansion (search-list-expansions search-list)) - (/show0 "tail recursing in %ENUMERATE-SEARCH-LIST") (%enumerate-search-list (make-pathname :defaults pathname :directory (cons :absolute @@ -1234,7 +1227,7 @@ a host-structure or string." ;;;; utilities -;;; Canonicalize a logical pathanme word by uppercasing it checking that it +;;; Canonicalize a logical pathname word by uppercasing it checking that it ;;; contains only legal characters. (defun logical-word-or-lose (word) (declare (string word)) @@ -1489,30 +1482,30 @@ a host-structure or string." ;;; Unparse a logical pathname string. (defun unparse-enough-namestring (pathname defaults) - (let* ((path-dir (pathname-directory pathname)) - (def-dir (pathname-directory defaults)) - (enough-dir + (let* ((path-directory (pathname-directory pathname)) + (def-directory (pathname-directory defaults)) + (enough-directory ;; Go down the directory lists to see what matches. What's ;; left is what we want, more or less. - (cond ((and (eq (first path-dir) (first def-dir)) - (eq (first path-dir) :absolute)) + (cond ((and (eq (first path-directory) (first def-directory)) + (eq (first path-directory) :absolute)) ;; Both paths are :ABSOLUTE, so find where the ;; common parts end and return what's left - (do* ((p (rest path-dir) (rest p)) - (d (rest def-dir) (rest d))) + (do* ((p (rest path-directory) (rest p)) + (d (rest def-directory) (rest d))) ((or (endp p) (endp d) (not (equal (first p) (first d)))) `(:relative ,@p)))) (t ;; At least one path is :RELATIVE, so just return the ;; original path. If the original path is :RELATIVE, - ;; then that's the right one. If PATH-DIR is + ;; then that's the right one. If PATH-DIRECTORY is ;; :ABSOLUTE, we want to return that except when - ;; DEF-DIR is :ABSOLUTE, as handled above. so return + ;; DEF-DIRECTORY is :ABSOLUTE, as handled above. so return ;; the original directory. - path-dir)))) + path-directory)))) (make-pathname :host (pathname-host pathname) - :directory enough-dir + :directory enough-directory :name (pathname-name pathname) :type (pathname-type pathname) :version (pathname-version pathname))))