#!-sb-fluid (declaim (freeze-type logical-pathname logical-host))
\f
-;;; 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))
\f
;;; pathname methods
(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)
((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))
(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)
(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)
(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)
&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)
(frob %pathname-type)
(frob %pathname-version))))))))
\f
-;;;; 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)
- (let* ((pathname (if (typep pathname 'logical-pathname)
- (translate-logical-pathname pathname)
- pathname))
- (search-list (extract-search-list pathname nil)))
- (cond
- ((not search-list)
- (funcall function pathname))
- ((not (search-list-defined search-list))
- (error "undefined search list: ~A"
- (search-list-name search-list)))
- (t
- (let ((tail (cddr (pathname-directory pathname))))
- (dolist (expansion
- (search-list-expansions search-list))
- (%enumerate-search-list (make-pathname :defaults pathname
- :directory
- (cons :absolute
- (append expansion
- tail)))
- function)))))))
-\f
;;;; 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
: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)
(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))
(canonicalize-logical-pathname-translations translations host))
(setf (logical-host-translations host) translations)))
-(defun translate-logical-pathname (pathname &key)
- #!+sb-doc
- "Translate 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
(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
projects / sbcl.git / blobdiff