X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-pathname.lisp;h=a63916ff6d4eaa88a653dc0887045589743e2c5f;hb=c8218514d751c4d777892b79bbf1ca6597f731c0;hp=357d7114c60b2425c0b1370cbea8516c50a2ea4f;hpb=64bf93a97814ea1caf62bbdcc7ef43e2fbfc8f73;p=sbcl.git diff --git a/src/code/target-pathname.lisp b/src/code/target-pathname.lisp index 357d711..a63916f 100644 --- a/src/code/target-pathname.lisp +++ b/src/code/target-pathname.lisp @@ -51,15 +51,16 @@ (let ((namestring (handler-case (namestring pathname) (error nil)))) (if namestring - (format stream "#.(logical-pathname ~S)" namestring) + (format stream "#.(CL:LOGICAL-PATHNAME ~S)" namestring) (print-unreadable-object (pathname stream :type t) - (format stream - ":HOST ~S :DIRECTORY ~S :FILE ~S :NAME=~S :VERSION ~S" - (%pathname-host pathname) - (%pathname-directory pathname) - (%pathname-name pathname) - (%pathname-type pathname) - (%pathname-version pathname)))))) + (format + stream + "~_:HOST ~S ~_:DIRECTORY ~S ~_:FILE ~S ~_:NAME ~S ~_:VERSION ~S" + (%pathname-host pathname) + (%pathname-directory pathname) + (%pathname-name pathname) + (%pathname-type pathname) + (%pathname-version pathname)))))) ;;; A pathname is logical if the host component is a logical host. ;;; This constructor is used to make an instance of the correct type @@ -70,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 @@ -453,11 +454,12 @@ #!+sb-doc "Makes a new pathname from the component arguments. Note that host is a host-structure or string." - (declare (type (or string host component-tokens) host) - (type (or string component-tokens) device) - (type (or list string pattern component-tokens) directory) - (type (or string pattern component-tokens) name type) - (type (or integer component-tokens (member :newest)) version) + (declare (type (or string host pathname-component-tokens) host) + (type (or string pathname-component-tokens) device) + (type (or list string pattern pathname-component-tokens) directory) + (type (or string pattern pathname-component-tokens) name type) + (type (or integer pathname-component-tokens (member :newest)) + version) (type (or pathname-designator null) defaults) (type (member :common :local) case)) (let* ((defaults (when defaults @@ -527,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) @@ -537,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) @@ -549,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) @@ -560,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) @@ -570,10 +572,9 @@ a host-structure or string." (%pathname-host pathname)) :lower))))) -;;; PATHNAME-TYPE (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) @@ -583,10 +584,9 @@ a host-structure or string." (%pathname-host pathname)) :lower))))) -;;; PATHNAME-VERSION (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)) @@ -1002,14 +1002,14 @@ a host-structure or string." (dolist (to-part (rest to)) (typecase to-part ((member :wild) - (assert subs-left) + (aver subs-left) (let ((match (pop subs-left))) (when (listp match) (error ":WILD-INFERIORS is not paired in from and to ~ patterns:~% ~S ~S" from to)) (res (maybe-diddle-case match diddle-case)))) ((member :wild-inferiors) - (assert subs-left) + (aver subs-left) (let ((match (pop subs-left))) (unless (listp match) (error ":WILD-INFERIORS not paired in from and to ~ @@ -1198,27 +1198,18 @@ 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)) + (let* ((pathname (physicalize-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 +1225,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)) @@ -1306,7 +1297,7 @@ a host-structure or string." (return) (pattern :multi-char-wild)) (setq last-pos (1+ pos))))) - (assert (pattern)) + (aver (pattern)) (if (cdr (pattern)) (make-pattern (pattern)) (let ((x (car (pattern)))) @@ -1427,11 +1418,10 @@ a host-structure or string." :namestring namestr :offset (cdadr chunks))))) (parse-host (logical-chunkify namestr start end))) - (values host :unspecific - (and (not (equal (directory)'(:absolute)))(directory)) - name type version)))) + (values host :unspecific (directory) name type version)))) -;;; We can't initialize this yet because not all host methods are loaded yet. +;;; We can't initialize this yet because not all host methods are +;;; loaded yet. (defvar *logical-pathname-defaults*) (defun logical-pathname (pathspec) @@ -1488,30 +1478,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)))) @@ -1560,7 +1550,7 @@ a host-structure or string." (defun translate-logical-pathname (pathname &key) #!+sb-doc - "Translates pathname to a physical pathname, which is returned." + "Translate PATHNAME to a physical pathname, which is returned." (declare (type pathname-designator pathname) (values (or null pathname))) (typecase pathname