X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-pathname.lisp;h=25cf000c5c1c4294ec8c6e903fd899f190ff0992;hb=cd176690400f8b6fa23faa4dc6fa8494bcbce480;hp=39dadfb15d47981b4256e43193bcc32fa6425248;hpb=cbaa1997bb097a55d108df592ac3b7eb4a703fff;p=sbcl.git diff --git a/src/code/target-pathname.lisp b/src/code/target-pathname.lisp index 39dadfb..25cf000 100644 --- a/src/code/target-pathname.lisp +++ b/src/code/target-pathname.lisp @@ -13,10 +13,30 @@ #!-sb-fluid (declaim (freeze-type logical-pathname logical-host)) -;;; host methods - -(def!method print-object ((host host) stream) - (print-unreadable-object (host stream :type t :identity t))) +;;;; UNIX-HOST stuff + +(def!struct (unix-host + (:make-load-form-fun make-unix-host-load-form) + (:include host + (parse #'parse-unix-namestring) + (unparse #'unparse-unix-namestring) + (unparse-host #'unparse-unix-host) + (unparse-directory #'unparse-unix-directory) + (unparse-file #'unparse-unix-file) + (unparse-enough #'unparse-unix-enough) + (customary-case :lower)))) + +(defvar *unix-host* (make-unix-host)) + +(defun make-unix-host-load-form (host) + (declare (ignore host)) + '*unix-host*) + +;;; Return a value suitable, e.g., for preinitializing +;;; *DEFAULT-PATHNAME-DEFAULTS* before *DEFAULT-PATHNAME-DEFAULTS* is +;;; initialized (at which time we can't safely call e.g. #'PATHNAME). +(defun make-trivial-default-pathname () + (%make-pathname *unix-host* nil nil nil nil :newest)) ;;; pathname methods @@ -25,12 +45,10 @@ (error nil)))) (if namestring (format stream "#P~S" namestring) - ;; FIXME: This code was rewritten and should be tested. (How does - ;; control get to this case anyhow? Perhaps we could just punt it?) (print-unreadable-object (pathname stream :type t) (format stream - "(with no namestring) :HOST ~S :DEVICE ~S :DIRECTORY ~S ~ - :NAME ~S :TYPE ~S :VERSION ~S" + "~@<(with no namestring) ~_:HOST ~S ~_:DEVICE ~S ~_:DIRECTORY ~S ~ + ~_:NAME ~S ~_:TYPE ~S ~_:VERSION ~S~:>" (%pathname-host pathname) (%pathname-device pathname) (%pathname-directory pathname) @@ -51,15 +69,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 +89,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 @@ -416,13 +435,7 @@ ((member :unspecific) '(:relative)) (list (collect ((results)) - (ecase (pop directory) - (:absolute - (results :absolute) - (when (search-list-p (car directory)) - (results (pop directory)))) - (:relative - (results :relative))) + (results (pop directory)) (dolist (piece directory) (cond ((member piece '(:wild :wild-inferiors :up :back)) (results piece)) @@ -453,11 +466,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 +541,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 +551,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 +563,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 +574,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) @@ -572,7 +586,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) @@ -584,7 +598,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))) @@ -742,7 +756,7 @@ a host-structure or string." (defun host-namestring (pathname) #!+sb-doc - "Returns a string representation of the name of the host in the pathname." + "Return a string representation of the name of the host in the pathname." (declare (type pathname-designator pathname) (values (or null simple-base-string))) (with-pathname (pathname pathname) @@ -755,7 +769,7 @@ a host-structure or string." (defun directory-namestring (pathname) #!+sb-doc - "Returns a string representation of the directories used in the pathname." + "Return a string representation of the directories used in the pathname." (declare (type pathname-designator pathname) (values (or null simple-base-string))) (with-pathname (pathname pathname) @@ -768,7 +782,7 @@ a host-structure or string." (defun file-namestring (pathname) #!+sb-doc - "Returns a string representation of the name used in the pathname." + "Return a string representation of the name used in the pathname." (declare (type pathname-designator pathname) (values (or null simple-base-string))) (with-pathname (pathname pathname) @@ -783,7 +797,7 @@ a host-structure or string." &optional (defaults *default-pathname-defaults*)) #!+sb-doc - "Returns an abbreviated pathname sufficent to identify the pathname relative + "Return an abbreviated pathname sufficent to identify the pathname relative to the defaults." (declare (type pathname-designator pathname)) (with-pathname (pathname pathname) @@ -847,7 +861,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)) @@ -1000,14 +1014,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 ~ @@ -1053,186 +1067,15 @@ a host-structure or string." (frob %pathname-type) (frob %pathname-version)))))))) -;;;; search lists - -(def!struct (search-list (:make-load-form-fun - (lambda (s) - (values `(intern-search-list - ',(search-list-name s)) - nil)))) - ;; The name of this search-list. Always stored in lowercase. - (name (required-argument) :type simple-string) - ;; T if this search-list has been defined. Otherwise NIL. - (defined nil :type (member t nil)) - ;; the list of expansions for this search-list. Each expansion is - ;; the list of directory components to use in place of this - ;; search-list. - (expansions nil :type list)) -(def!method print-object ((sl search-list) stream) - (print-unreadable-object (sl stream :type t) - (write-string (search-list-name sl) stream))) - -;;; a hash table mapping search-list names to search-list structures -(defvar *search-lists* (make-hash-table :test 'equal)) - -;;; When search-lists are encountered in namestrings, they are -;;; converted to search-list structures right then, instead of waiting -;;; until the search list used. This allows us to verify ahead of time -;;; that there are no circularities and makes expansion much quicker. -(defun intern-search-list (name) - (let ((name (string-downcase name))) - (or (gethash name *search-lists*) - (let ((new (make-search-list :name name))) - (setf (gethash name *search-lists*) new) - new)))) - -;;; Clear the definition. Note: we can't remove it from the hash-table -;;; because there may be pathnames still refering to it. So we just -;;; clear out the expansions and ste defined to NIL. -(defun clear-search-list (name) - #!+sb-doc - "Clear the current definition for the search-list NAME. Returns T if such - a definition existed, and NIL if not." - (let* ((name (string-downcase name)) - (search-list (gethash name *search-lists*))) - (when (and search-list (search-list-defined search-list)) - (setf (search-list-defined search-list) nil) - (setf (search-list-expansions search-list) nil) - t))) - -;;; As in CLEAR-SEARCH-LIST, we can't actually remove the entries from -;;; the hash-table, so we just mark them as being undefined. -(defun clear-all-search-lists () - #!+sb-doc - "Clear the definition for all search-lists. Only use this if you know - what you are doing." - (maphash #'(lambda (name search-list) - (declare (ignore name)) - (setf (search-list-defined search-list) nil) - (setf (search-list-expansions search-list) nil)) - *search-lists*) - nil) - -;;; Extract the search-list from PATHNAME and return it. If PATHNAME -;;; doesn't start with a search-list, then either error (if -;;; FLAME-IF-NONE is true) or return NIL (if FLAME-IF-NONE is false). -(defun extract-search-list (pathname flame-if-none) - (with-pathname (pathname pathname) - (let* ((directory (%pathname-directory pathname)) - (search-list (cadr directory))) - (cond ((search-list-p search-list) - search-list) - (flame-if-none - (error "~S doesn't start with a search-list." pathname)) - (t - nil))))) - -;;; We have to convert the internal form of the search-list back into -;;; a bunch of pathnames. -(defun search-list (pathname) - #!+sb-doc - "Return the expansions for the search-list starting PATHNAME. If PATHNAME - does not start with a search-list, then an error is signaled. If - the search-list has not been defined yet, then an error is signaled. - The expansion for a search-list can be set with SETF." - (with-pathname (pathname pathname) - (let ((search-list (extract-search-list pathname t)) - (host (pathname-host pathname))) - (if (search-list-defined search-list) - (mapcar #'(lambda (directory) - (make-pathname :host host - :directory (cons :absolute directory))) - (search-list-expansions search-list)) - (error "Search list ~S has not been defined yet." pathname))))) - -(defun search-list-defined-p (pathname) - #!+sb-doc - "Returns T if the search-list starting PATHNAME is currently defined, and - NIL otherwise. An error is signaled if PATHNAME does not start with a - search-list." - (with-pathname (pathname pathname) - (search-list-defined (extract-search-list pathname t)))) - -;;; Set the expansion for the search list in PATHNAME. If this would -;;; result in any circularities, we flame out. If anything goes wrong, -;;; we leave the old definition intact. -(defun %set-search-list (pathname values) - (let ((search-list (extract-search-list pathname t))) - (labels - ((check (target-list path) - (when (eq search-list target-list) - (error "That would result in a circularity:~% ~ - ~A~{ -> ~A~} -> ~A" - (search-list-name search-list) - (reverse path) - (search-list-name target-list))) - (when (search-list-p target-list) - (push (search-list-name target-list) path) - (dolist (expansion (search-list-expansions target-list)) - (check (car expansion) path)))) - (convert (pathname) - (with-pathname (pathname pathname) - (when (or (pathname-name pathname) - (pathname-type pathname) - (pathname-version pathname)) - (error "Search-lists cannot expand into pathnames that have ~ - a name, type, or ~%version specified:~% ~S" - pathname)) - (let ((directory (pathname-directory pathname))) - (let ((expansion - (if directory - (ecase (car directory) - (:absolute (cdr directory)) - (:relative (cons (intern-search-list "default") - (cdr directory)))) - (list (intern-search-list "default"))))) - (check (car expansion) nil) - expansion))))) - (setf (search-list-expansions search-list) - (if (listp values) - (mapcar #'convert values) - (list (convert values))))) - (setf (search-list-defined search-list) t)) - 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 - (append expansion - tail))) - function))))))) - ;;;; logical pathname support. ANSI 92-102 specification. ;;;; ;;;; As logical-pathname translations are loaded they are -;;;; canonicalized as patterns to enable rapid efficent translation +;;;; canonicalized as patterns to enable rapid efficient translation ;;;; into physical pathnames. ;;;; 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)) @@ -1304,7 +1147,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)))) @@ -1425,11 +1268,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) @@ -1486,30 +1328,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)))) @@ -1546,8 +1388,7 @@ a host-structure or string." (defun (setf logical-pathname-translations) (translations host) #!+sb-doc - "Set the translations list for the logical host argument. - Return translations." + "Set the translations list for the logical host argument." (declare (type (or string logical-host) host) (type list translations) (values list)) @@ -1556,9 +1397,15 @@ a host-structure or string." (canonicalize-logical-pathname-translations translations host)) (setf (logical-host-translations host) translations))) -(defun translate-logical-pathname (pathname &key) - #!+sb-doc - "Translates pathname to a physical pathname, which is returned." +;;; KLUDGE: Ordinarily known functions aren't defined recursively, and +;;; it's common for compiler problems (e.g. missing/broken +;;; optimization transforms) to cause them to recurse inadvertently, +;;; so the compiler should warn about it. But the natural definition +;;; of TRANSLATE-LOGICAL-PATHNAME *is* recursive; and we don't want +;;; the warning, so we hide the definition of T-L-P in this +;;; differently named function so that the compiler won't warn about +;;; it. -- WHN 2001-09-16 +(defun %translate-logical-pathname (pathname) (declare (type pathname-designator pathname) (values (or null pathname))) (typecase pathname @@ -1576,6 +1423,13 @@ a host-structure or string." (stream (translate-logical-pathname (pathname pathname))) (t (translate-logical-pathname (logical-pathname pathname))))) +(defun translate-logical-pathname (pathname &key) + #!+sb-doc + "Translate PATHNAME to a physical pathname, which is returned." + (declare (type pathname-designator pathname) + (values (or null pathname))) + (%translate-logical-pathname pathname)) + (defvar *logical-pathname-defaults* (%make-logical-pathname (make-logical-host :name "BOGUS") :unspecific