(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))))
(%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.
+ ;; 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 (string-upcase 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)
\f
;;;; pathname functions
-;;; implementation-determined defaults to pathname slots
-(defvar *default-pathname-defaults*)
-
(defun pathname= (pathname1 pathname2)
(declare (type pathname pathname1)
(type pathname pathname2))
\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"
+ (error "The host in the namestring, ~S,~@
+ does not match the explicit host argument: ~S"
host))
(let ((pn-host (or new-host parse-host)))
(values (%make-pathname-object
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)))))
(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)
(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)
(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
to the defaults."
(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
(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))
(assert 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)
(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)))
(funcall function pathname))
((not (search-list-defined search-list))
(/show0 "undefined search list")
- (error "Undefined search list: ~A"
+ (error "undefined search list: ~A"
(search-list-name search-list)))
(t
(/show0 "general case")
(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
(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))
(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)))
(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
((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-dir (pathname-directory pathname))
+ (def-dir (pathname-directory defaults))
+ (enough-dir
+ ;; 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))
+ ;; 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)))
+ ((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
+ ;; :absolute, we want to return that except when
+ ;; DEF-DIR is :absolute, as handled above. so return
+ ;; the original directory.
+ path-dir))))
+ (make-pathname :host (pathname-host pathname)
+ :directory enough-dir
+ :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
(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."
(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)
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)))