#!-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)
(def!method make-load-form ((pathname pathname) &optional environment)
(make-load-form-saving-slots pathname :environment environment))
-;;; The potential conflict with search-lists requires isolating the printed
-;;; representation to use the i/o macro #.(logical-pathname <path-designator>).
+;;; The potential conflict with search lists requires isolating the
+;;; printed representation to use the i/o macro #.(logical-pathname
+;;; <path-designator>).
;;;
-;;; FIXME: We don't use search lists any more, so that comment is stale, right?
+;;; FIXME: We don't use search lists any more, so that comment is
+;;; stale, right?
(def!method print-object ((pathname logical-pathname) stream)
(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))))))
\f
-;;; A pathname is logical if the host component is a logical-host.
+;;; A pathname is logical if the host component is a logical host.
;;; This constructor is used to make an instance of the correct type
;;; from parsed arguments.
-(defun %make-pathname-object (host device directory name type version)
- (if (typep host 'logical-host)
- (%make-logical-pathname host :unspecific directory name type version)
- (%make-pathname host device directory name type version)))
-
-;;; Hash table searching maps a logical-pathname's host to their physical
-;;; pathname translation.
+(defun %make-maybe-logical-pathname (host device directory name type version)
+ ;; We canonicalize logical pathname components to uppercase. ANSI
+ ;; doesn't strictly require this, leaving it up to the implementor;
+ ;; 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 (logical-word-or-lose x)) (t x))))
+ (if (typep host 'logical-host)
+ (%make-logical-pathname host
+ :unspecific
+ (mapcar #'upcase-maybe directory)
+ (upcase-maybe name)
+ (upcase-maybe type)
+ version)
+ (%make-pathname host device directory name type version))))
+
+;;; Hash table searching maps a logical pathname's host to its
+;;; physical pathname translation.
(defvar *logical-hosts* (make-hash-table :test 'equal))
\f
;;;; patterns
(matches (pattern-pieces pattern) 0 nil nil nil)
(values won (reverse subs))))))
-;;; Pathname-match-p for directory components.
+;;; PATHNAME-MATCH-P for directory components
(defun directory-components-match (thing wild)
(or (eq thing wild)
(eq wild :wild)
+ ;; If THING has a null directory, assume that it matches
+ ;; (:ABSOLUTE :WILD-INFERIORS) or (:RELATIVE :WILD-INFERIORS).
+ (and (consp wild)
+ (null thing)
+ (member (first wild) '(:absolute :relative))
+ (eq (second wild) :wild-inferiors))
(and (consp wild)
(let ((wild1 (first wild)))
(if (eq wild1 :wild-inferiors)
;; A pattern is only matched by an identical pattern.
(and (pattern-p wild) (pattern= thing wild)))
(integer
- ;; an integer (version number) is matched by :WILD or the same
- ;; integer. This branch will actually always be NIL as long as the
- ;; version is a fixnum.
+ ;; An integer (version number) is matched by :WILD or the
+ ;; same integer. This branch will actually always be NIL as
+ ;; long as the version is a fixnum.
(eql thing wild)))))
-;;; A predicate for comparing two pathname slot component sub-entries.
+;;; a predicate for comparing two pathname slot component sub-entries
(defun compare-component (this that)
(or (eql this that)
(typecase this
\f
;;;; pathname functions
-;;; implementation-determined defaults to pathname slots
-(defvar *default-pathname-defaults*)
-
(defun pathname= (pathname1 pathname2)
(declare (type pathname pathname1)
(type pathname pathname2))
(stream (file-name ,pd0)))))
,@body)))
-;;; Converts the var, a host or string name for a host, into a logical-host
-;;; structure or nil if not defined.
+;;; Convert the var, a host or string name for a host, into a
+;;; LOGICAL-HOST structure or nil if not defined.
;;;
;;; pw notes 1/12/97 this potentially useful macro is not used anywhere
;;; and 'find-host' is not defined. 'find-logical-host' seems to be needed.
(and default-host pathname-host
(not (eq (host-customary-case default-host)
(host-customary-case pathname-host))))))
- (%make-pathname-object
+ (%make-maybe-logical-pathname
(or pathname-host default-host)
(or (%pathname-device pathname)
(maybe-diddle-case (%pathname-device defaults)
((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))
#!+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
;; toy@rtp.ericsson.se: CLHS says make-pathname can take a
;; string (as a logical-host) for the host part. We map that
;; string into the corresponding logical host structure.
-
+ ;;
;; pw@snoopy.mv.com:
;; HyperSpec says for the arg to MAKE-PATHNAME;
;; "host---a valid physical pathname host. ..."
;; that is recognized by the implementation as the name of a host."
;; "valid logical pathname host n. a string that has been defined
;; as the name of a logical host. ..."
- ;; HS is silent on what happens if the :host arg is NOT one of these.
+ ;; HS is silent on what happens if the :HOST arg is NOT one of these.
;; It seems an error message is appropriate.
(host (typecase host
(host host) ; A valid host, use it.
diddle-defaults))
(t
nil))))
- (%make-pathname-object host
- dev ; forced to :unspecific when logical-host
- dir
- (pick name namep %pathname-name)
- (pick type typep %pathname-type)
- ver))))
+ (%make-maybe-logical-pathname host
+ dev ; forced to :UNSPECIFIC when logical
+ dir
+ (pick name namep %pathname-name)
+ (pick type typep %pathname-type)
+ ver))))
(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)
(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)
(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)
: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)
(%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)
(%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)))
\f
;;;; namestrings
-(defun %print-namestring-parse-error (condition stream)
- (format stream "Parse error in namestring: ~?~% ~A~% ~V@T^"
- (namestring-parse-error-complaint condition)
- (namestring-parse-error-arguments condition)
- (namestring-parse-error-namestring condition)
- (namestring-parse-error-offset condition)))
-
-;;; Handle the case where parse-namestring is actually parsing a namestring.
-;;; We pick off the :JUNK-ALLOWED case then find a host to use for parsing,
-;;; call the parser, then check whether the host matches.
+;;; Handle the case where PARSE-NAMESTRING is actually parsing a
+;;; namestring. We pick off the :JUNK-ALLOWED case then find a host to
+;;; use for parsing, call the parser, then check whether the host matches.
(defun %parse-namestring (namestr host defaults start end junk-allowed)
- (declare (type (or host null) host) (type string namestr)
- (type index start) (type (or index null) end))
+ (declare (type (or host null) host)
+ (type string namestr)
+ (type index start)
+ (type (or index null) end))
(if junk-allowed
(handler-case
(%parse-namestring namestr host defaults start end nil)
(extract-logical-host-prefix namestr start end)
(pathname-host defaults))))
(unless parse-host
- (error "When HOST argument is not supplied, DEFAULTS arg must ~
- have a non-null PATHNAME-HOST."))
+ (error "When no HOST argument is supplied, the DEFAULTS argument ~
+ must have a non-null PATHNAME-HOST."))
(multiple-value-bind (new-host device directory file type version)
(funcall (host-parse parse-host) namestr start end)
(when (and host new-host (not (eq new-host host)))
- (error "Host in namestring: ~S~@
- does not match explicit host argument: ~S"
- host))
+ (error 'simple-type-error
+ :datum new-host
+ ;; Note: ANSI requires that this be a TYPE-ERROR,
+ ;; but there seems to be no completely correct
+ ;; value to use for TYPE-ERROR-EXPECTED-TYPE.
+ ;; Instead, we return a sort of "type error allowed
+ ;; type", trying to say "it would be OK if you
+ ;; passed NIL as the host value" but not mentioning
+ ;; that a matching string would be OK too.
+ :expected-type 'null
+ :format-control
+ "The host in the namestring, ~S,~@
+ does not match the explicit HOST argument, ~S."
+ :format-arguments (list new-host host)))
(let ((pn-host (or new-host parse-host)))
- (values (%make-pathname-object
+ (values (%make-maybe-logical-pathname
pn-host device directory file type version)
end))))))
-;;; If namestr begins with a colon-terminated, defined, logical host, then
-;;; return that host, otherwise return NIL.
+;;; If NAMESTR begins with a colon-terminated, defined, logical host,
+;;; then return that host, otherwise return NIL.
(defun extract-logical-host-prefix (namestr start end)
(declare (type simple-base-string namestr)
(type index start end)
nil)))
(defun parse-namestring (thing
- &optional host (defaults *default-pathname-defaults*)
+ &optional
+ host
+ (defaults *default-pathname-defaults*)
&key (start 0) end junk-allowed)
- #!+sb-doc
- "Converts pathname, a pathname designator, into a pathname structure,
- for a physical pathname, returns the printed representation. Host may be
- a physical host structure or host namestring."
(declare (type pathname-designator thing)
- (type (or null host) host)
+ (type (or list host string (member :unspecific)) host)
(type pathname defaults)
(type index start)
(type (or index null) end)
(type (or t null) junk-allowed)
(values (or null pathname) (or null index)))
- (typecase thing
+ ;; Generally, redundant specification of information in software,
+ ;; whether in code or in comments, is bad. However, the ANSI spec
+ ;; for this is messy enough that it's hard to hold in short-term
+ ;; memory, so I've recorded these redundant notes on the
+ ;; implications of the ANSI spec.
+ ;;
+ ;; According to the ANSI spec, HOST can be a valid pathname host, or
+ ;; a logical host, or NIL.
+ ;;
+ ;; A valid pathname host can be a valid physical pathname host or a
+ ;; valid logical pathname host.
+ ;;
+ ;; A valid physical pathname host is "any of a string, a list of
+ ;; strings, or the symbol :UNSPECIFIC, that is recognized by the
+ ;; implementation as the name of a host". In SBCL as of 0.6.9.8,
+ ;; that means :UNSPECIFIC: though someday we might want to
+ ;; generalize it to allow strings like "RTFM.MIT.EDU" or lists like
+ ;; '("RTFM" "MIT" "EDU"), that's not supported now.
+ ;;
+ ;; A valid logical pathname host is a string which has been defined as
+ ;; the name of a logical host, as with LOAD-LOGICAL-PATHNAME-TRANSLATIONS.
+ ;;
+ ;; A logical host is an object of implementation-dependent nature. In
+ ;; SBCL, it's a member of the HOST class (a subclass of STRUCTURE-OBJECT).
+ (let ((found-host (etypecase host
+ (string
+ ;; In general ANSI-compliant Common Lisps, a
+ ;; string might also be a physical pathname host,
+ ;; but ANSI leaves this up to the implementor,
+ ;; and in SBCL we don't do it, so it must be a
+ ;; logical host.
+ (find-logical-host host))
+ ((or null (member :unspecific))
+ ;; CLHS says that HOST=:UNSPECIFIC has
+ ;; implementation-defined behavior. We
+ ;; just turn it into NIL.
+ nil)
+ (list
+ ;; ANSI also allows LISTs to designate hosts,
+ ;; but leaves its interpretation
+ ;; implementation-defined. Our interpretation
+ ;; is that it's unsupported.:-|
+ (error "A LIST representing a pathname host is not ~
+ supported in this implementation:~% ~S"
+ host))
+ (host
+ host))))
+ (declare (type (or null host) found-host))
+ (etypecase thing
(simple-string
- (%parse-namestring thing host defaults start end junk-allowed))
+ (%parse-namestring thing found-host defaults start end junk-allowed))
(string
(%parse-namestring (coerce thing 'simple-string)
- host defaults start end junk-allowed))
+ found-host defaults start end junk-allowed))
(pathname
- (let ((host (if host host (%pathname-host defaults))))
- (unless (eq host (%pathname-host thing))
- (error "Hosts do not match: ~S and ~S."
- host (%pathname-host thing))))
+ (let ((defaulted-host (or found-host (%pathname-host defaults))))
+ (declare (type host defaulted-host))
+ (unless (eq defaulted-host (%pathname-host thing))
+ (error "The HOST argument doesn't match the pathname host:~% ~
+ ~S and ~S."
+ defaulted-host (%pathname-host thing))))
(values thing start))
(stream
(let ((name (file-name thing)))
(unless name
- (error "Can't figure out the file associated with stream:~% ~S"
+ (error "can't figure out the file associated with stream:~% ~S"
thing))
- name))))
+ (values name nil))))))
(defun namestring (pathname)
#!+sb-doc
(when pathname
(let ((host (%pathname-host pathname)))
(unless host
- (error "Cannot determine the namestring for pathnames with no ~
+ (error "can't determine the namestring for pathnames with no ~
host:~% ~S" pathname))
(funcall (host-unparse host) pathname)))))
(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)
(if host
(funcall (host-unparse-host host) pathname)
(error
- "Cannot determine the namestring for pathnames with no host:~% ~S"
+ "can't determine the namestring for pathnames with no host:~% ~S"
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)
(if host
(funcall (host-unparse-directory host) pathname)
(error
- "Cannot determine the namestring for pathnames with no host:~% ~S"
+ "can't determine the namestring for pathnames with no host:~% ~S"
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)
(if host
(funcall (host-unparse-file host) pathname)
(error
- "Cannot determine the namestring for pathnames with no host:~% ~S"
+ "can't determine the namestring for pathnames with no host:~% ~S"
pathname)))))
(defun enough-namestring (pathname
- &optional (defaults *default-pathname-defaults*))
+ &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)
(with-pathname (defaults defaults)
(funcall (host-unparse-enough host) pathname defaults))
(error
- "Cannot determine the namestring for pathnames with no host:~% ~S"
+ "can't determine the namestring for pathnames with no host:~% ~S"
pathname)))))
\f
;;;; wild pathnames
(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))
(t
(setf in-wildcard t)
(unless subs
- (error "Not enough wildcards in FROM pattern to match ~
+ (error "not enough wildcards in FROM pattern to match ~
TO pattern:~% ~S"
pattern))
(let ((sub (pop subs)))
(simple-string
(push sub strings))
(t
- (error "Can't substitute this into the middle of a word:~
+ (error "can't substitute this into the middle of a word:~
~% ~S"
sub)))))))
(didnt-match-error orig-source orig-from)))))
(subs))))
-;;; Called by TRANSLATE-PATHNAME on the directory components of its argument
-;;; pathanames to produce the result directory component. If any leaves the
-;;; directory NIL, we return the source directory. The :RELATIVE or :ABSOLUTE
-;;; is always taken from the source directory.
+;;; This is called by TRANSLATE-PATHNAME on the directory components
+;;; of its argument pathnames to produce the result directory
+;;; component. If this leaves the directory NIL, we return the source
+;;; directory. The :RELATIVE or :ABSOLUTE is taken from the source
+;;; directory, except if TO is :ABSOLUTE, in which case the result
+;;; will be :ABSOLUTE.
(defun translate-directories (source from to diddle-case)
(if (not (and source to from))
- (or to
- (mapcar #'(lambda (x) (maybe-diddle-case x diddle-case)) source))
+ (or (and to (null source) (remove :wild-inferiors to))
+ (mapcar (lambda (x) (maybe-diddle-case x diddle-case)) source))
(collect ((res))
- (res (first source))
+ ;; If TO is :ABSOLUTE, the result should still be :ABSOLUTE.
+ (res (if (eq (first to) :absolute)
+ :absolute
+ (first source)))
(let ((subs-left (compute-directory-substitutions (rest source)
(rest from))))
(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 not paired in from and to ~
+ (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 ~
(dolist (x match)
(res (maybe-diddle-case x diddle-case)))))
(pattern
- (multiple-value-bind (new new-subs-left)
+ (multiple-value-bind
+ (new new-subs-left)
(substitute-into to-part subs-left diddle-case)
(setf subs-left new-subs-left)
(res new)))
(if (eq result :error)
(error "~S doesn't match ~S." source from)
result))))
- (%make-pathname-object
+ (%make-maybe-logical-pathname
(or to-host source-host)
(frob %pathname-device)
(frob %pathname-directory translate-directories)
(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)))
-
-;;; Again, 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)))))))
-\f
;;;; logical pathname support. ANSI 92-102 specification.
-;;;; As logical-pathname translations are loaded they are canonicalized as
-;;;; patterns to enable rapid efficent translation into physical pathnames.
+;;;;
+;;;; As logical-pathname translations are loaded they are
+;;;; 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))
(let ((ch (schar word i)))
(unless (or (alpha-char-p ch) (digit-char-p ch) (char= ch #\-))
(error 'namestring-parse-error
- :complaint "Logical namestring character ~
+ :complaint "logical namestring character which ~
is not alphanumeric or hyphen:~% ~S"
:arguments (list ch)
:namestring word :offset i))))
word))
-;;; Given a logical host or string, return a logical host. If Error-p is
-;;; NIL, then return NIL when no such host exists.
+;;; Given a logical host or string, return a logical host. If ERROR-P
+;;; is NIL, then return NIL when no such host exists.
(defun find-logical-host (thing &optional (errorp t))
(etypecase thing
(string
*logical-hosts*)))
(if (or found (not errorp))
found
- (error 'simple-file-error
- :pathname thing
- :format-control "Logical host not yet defined: ~S"
+ ;; This is the error signalled from e.g.
+ ;; LOGICAL-PATHNAME-TRANSLATIONS when host is not a defined
+ ;; host, and ANSI specifies that that's a TYPE-ERROR.
+ (error 'simple-type-error
+ :datum thing
+ ;; God only knows what ANSI expects us to use for
+ ;; the EXPECTED-TYPE here. Maybe this will be OK..
+ :expected-type
+ '(and string (satisfies logical-pathname-translations))
+ :format-control "logical host not yet defined: ~S"
:format-arguments (list thing)))))
(logical-host thing)))
-;;; Given a logical host name or host, return a logical host, creating a new
-;;; one if necessary.
+;;; Given a logical host name or host, return a logical host, creating
+;;; a new one if necessary.
(defun intern-logical-host (thing)
(declare (values logical-host))
(or (find-logical-host thing nil)
(if (= pos last-pos)
(when (pattern)
(error 'namestring-parse-error
- :complaint "Double asterisk inside of logical ~
+ :complaint "double asterisk inside of logical ~
word: ~S"
:arguments (list chunk)
:namestring namestring
(return)
(pattern :multi-char-wild))
(setq last-pos (1+ pos)))))
- (assert (pattern))
+ (aver (pattern))
(if (cdr (pattern))
(make-pattern (pattern))
(let ((x (car (pattern))))
:wild
x))))))
-;;; Return a list of conses where the cdr is the start position and the car
-;;; is a string (token) or character (punctuation.)
+;;; Return a list of conses where the CDR is the start position and
+;;; the CAR is a string (token) or character (punctuation.)
(defun logical-chunkify (namestr start end)
(collect ((chunks))
(do ((i start (1+ i))
(setq prev (1+ i))
(unless (member ch '(#\; #\: #\.))
(error 'namestring-parse-error
- :complaint "Illegal character for logical pathname:~% ~S"
+ :complaint "illegal character for logical pathname:~% ~S"
:arguments (list ch)
:namestring namestr
:offset i))
(chunks (cons ch i)))))
(chunks)))
-;;; Break up a logical-namestring, always a string, into its constituent parts.
+;;; Break up a logical-namestring, always a string, into its
+;;; constituent parts.
(defun parse-logical-namestring (namestr start end)
(declare (type simple-base-string namestr)
(type index start end))
(labels ((expecting (what chunks)
(unless (and chunks (simple-string-p (caar chunks)))
(error 'namestring-parse-error
- :complaint "Expecting ~A, got ~:[nothing~;~S~]."
- :arguments (list what (caar chunks))
+ :complaint "expecting ~A, got ~:[nothing~;~S~]."
+ :arguments (list what (caar chunks) (caar chunks))
:namestring namestr
:offset (if chunks (cdar chunks) end)))
(caar chunks))
(when chunks
(unless (eql (caar chunks) #\.)
(error 'namestring-parse-error
- :complaint "Expecting a dot, got ~S."
+ :complaint "expecting a dot, got ~S."
:arguments (list (caar chunks))
:namestring namestr
:offset (cdar chunks)))
(parse-integer str :junk-allowed t)
(unless (and res (plusp res))
(error 'namestring-parse-error
- :complaint "Expected a positive integer, ~
+ :complaint "expected a positive integer, ~
got ~S"
:arguments (list str)
:namestring namestr
(setq version res)))))
(when (cdr chunks)
(error 'namestring-parse-error
- :complaint "Extra stuff after end of file name."
+ :complaint "extra stuff after end of file name"
: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))))
-;;; can't defvar here because not all host methods are loaded yet
-(declaim (special *logical-pathname-defaults*))
+;;; We can't initialize this yet because not all host methods are
+;;; loaded yet.
+(defvar *logical-pathname-defaults*)
(defun logical-pathname (pathspec)
#!+sb-doc
(let ((res (parse-namestring pathspec nil *logical-pathname-defaults*)))
(when (eq (%pathname-host res)
(%pathname-host *logical-pathname-defaults*))
- (error "Logical namestring does not specify a host:~% ~S"
+ (error "This logical namestring does not specify a host:~% ~S"
pathspec))
res)))
\f
(let ((directory (%pathname-directory pathname)))
(when directory
(ecase (pop directory)
- (:absolute) ;; Nothing special.
+ (:absolute) ; nothing special
(:relative (pieces ";")))
(dolist (dir directory)
(cond ((or (stringp dir) (pattern-p dir))
((eq dir :wild-inferiors)
(pieces "**;"))
(t
- (error "Invalid directory component: ~S" dir))))))
+ (error "invalid directory component: ~S" dir))))))
(apply #'concatenate 'simple-string (pieces))))
(defun unparse-logical-piece (thing)
(strings "**"))
((eq piece :multi-char-wild)
(strings "*"))
- (t (error "Invalid keyword: ~S" piece))))))
+ (t (error "invalid keyword: ~S" piece))))))
(apply #'concatenate 'simple-string (strings))))))
+;;; Unparse a logical pathname string.
+(defun unparse-enough-namestring (pathname defaults)
+ (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-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-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-DIRECTORY is
+ ;; :ABSOLUTE, we want to return that except when
+ ;; DEF-DIRECTORY is :ABSOLUTE, as handled above. so return
+ ;; the original directory.
+ path-directory))))
+ (make-pathname :host (pathname-host pathname)
+ :directory enough-directory
+ :name (pathname-name pathname)
+ :type (pathname-type pathname)
+ :version (pathname-version pathname))))
+
(defun unparse-logical-namestring (pathname)
(declare (type logical-pathname pathname))
(concatenate 'simple-string
;;;; logical pathname translations
;;; Verify that the list of translations consists of lists and prepare
-;;; canonical translations (parse pathnames and expand out wildcards into
-;;; patterns).
-(defun canonicalize-logical-pathname-translations (transl-list host)
- (declare (type list transl-list) (type host host)
+;;; canonical translations. (Parse pathnames and expand out wildcards
+;;; into patterns.)
+(defun canonicalize-logical-pathname-translations (translation-list host)
+ (declare (type list translation-list) (type host host)
(values list))
- (collect ((res))
- (dolist (tr transl-list)
- (unless (and (consp tr) (= (length tr) 2))
- (error "Logical pathname translation is not a two-list:~% ~S"
- tr))
- (let ((from (first tr)))
- (res (list (if (typep from 'logical-pathname)
- from
- (parse-namestring from host))
- (pathname (second tr))))))
- (res)))
+ (mapcar (lambda (translation)
+ (destructuring-bind (from to) translation
+ (list (if (typep from 'logical-pathname)
+ from
+ (parse-namestring from host))
+ (pathname to))))
+ translation-list))
(defun logical-pathname-translations (host)
#!+sb-doc
(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))
-
(let ((host (intern-logical-host host)))
(setf (logical-host-canon-transls host)
(canonicalize-logical-pathname-translations translations host))
(setf (logical-host-translations host) translations)))
-;;; The search mechanism for loading pathname translations uses the CMU CL
-;;; extension of search-lists. The user can add to the "library:" search-list
-;;; using setf. The file for translations should have the name defined by
-;;; the hostname (a string) and with type component "translations".
-
-(defun load-logical-pathname-translations (host)
- #!+sb-doc
- "Search for a logical pathname named host, if not already defined. If already
- defined no attempt to find or load a definition is attempted and NIL is
- returned. If host is not already defined, but definition is found and loaded
- successfully, T is returned, else error."
- (declare (type string host)
- (values (member t nil)))
- (unless (find-logical-host host nil)
- (with-open-file (in-str (make-pathname :defaults "library:"
- :name host
- :type "translations"))
- (if *load-verbose*
- (format *error-output*
- ";; loading pathname translations from ~A~%"
- (namestring (truename in-str))))
- (setf (logical-pathname-translations host) (read in-str)))
- t))
-
-(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
(dolist (x (logical-host-canon-transls (%pathname-host pathname))
(error 'simple-file-error
:pathname pathname
- :format-control "No translation for ~S"
+ :format-control "no translation for ~S"
:format-arguments (list pathname)))
(destructuring-bind (from to) x
(when (pathname-match-p pathname from)
(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
nil
nil
nil))
+
+(defun load-logical-pathname-translations (host)
+ #!+sb-doc
+ (declare (type string host)
+ (values (member t nil)))
+ (if (find-logical-host host nil)
+ ;; This host is already defined, all is well and good.
+ t
+ ;; ANSI: "The specific nature of the search is
+ ;; implementation-defined." SBCL: doesn't search at all
+ (error "logical host ~S not found" host)))
projects / sbcl.git / blobdiff