X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-pathname.lisp;h=6ae6f41909cc41bad1b1cf70628b05c66a1d0553;hb=a7c2a16d0c2be6709becc962be1cb5e0aeda68c6;hp=1e12f0a618be6293dfe80b5b3e9109cfaf318914;hpb=cea4896b2482b7b2b429c1631d774b4cfbc0efba;p=sbcl.git diff --git a/src/code/target-pathname.lisp b/src/code/target-pathname.lisp index 1e12f0a..6ae6f41 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) @@ -41,34 +59,48 @@ (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 ). +;;; The potential conflict with search lists requires isolating the +;;; printed representation to use the i/o macro #.(logical-pathname +;;; ). ;;; -;;; 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)))))) -;;; 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)) ;;;; patterns @@ -88,22 +120,22 @@ (let ((pieces1 (pattern-pieces pattern1)) (pieces2 (pattern-pieces pattern2))) (and (= (length pieces1) (length pieces2)) - (every #'(lambda (piece1 piece2) - (typecase piece1 - (simple-string - (and (simple-string-p piece2) - (string= piece1 piece2))) - (cons - (and (consp piece2) - (eq (car piece1) (car piece2)) - (string= (cdr piece1) (cdr piece2)))) - (t - (eq piece1 piece2)))) + (every (lambda (piece1 piece2) + (typecase piece1 + (simple-string + (and (simple-string-p piece2) + (string= piece1 piece2))) + (cons + (and (consp piece2) + (eq (car piece1) (car piece2)) + (string= (cdr piece1) (cdr piece2)))) + (t + (eq piece1 piece2)))) pieces1 pieces2)))) -;;; If the string matches the pattern returns the multiple values T and a -;;; list of the matched strings. +;;; If the string matches the pattern returns the multiple values T +;;; and a list of the matched strings. (defun pattern-matches (pattern string) (declare (type pattern pattern) (type simple-string string)) @@ -157,10 +189,16 @@ (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) @@ -194,12 +232,12 @@ ;; 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 @@ -216,9 +254,6 @@ ;;;; pathname functions -;;; implementation-determined defaults to pathname slots -(defvar *default-pathname-defaults*) - (defun pathname= (pathname1 pathname2) (declare (type pathname pathname1) (type pathname pathname2)) @@ -247,11 +282,11 @@ (,pathname (etypecase ,pd0 (pathname ,pd0) (string (parse-namestring ,pd0)) - (stream (file-name ,pd0))))) + (file-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. @@ -283,9 +318,9 @@ (simple-string (check-for pred piece)) (cons - (case (car in) + (case (car piece) (:character-set - (check-for pred (cdr in)))))) + (check-for pred (cdr piece)))))) (return t)))) (list (dolist (x in) @@ -300,19 +335,19 @@ (typecase thing (pattern (make-pattern - (mapcar #'(lambda (piece) - (typecase piece - (simple-base-string - (funcall fun piece)) - (cons - (case (car piece) - (:character-set - (cons :character-set - (funcall fun (cdr piece)))) - (t - piece))) - (t - piece))) + (mapcar (lambda (piece) + (typecase piece + (simple-base-string + (funcall fun piece)) + (cons + (case (car piece) + (:character-set + (cons :character-set + (funcall fun (cdr piece)))) + (t + piece))) + (t + piece))) (pattern-pieces thing)))) (list (mapcar fun thing)) @@ -323,20 +358,20 @@ (let ((any-uppers (check-for #'upper-case-p thing)) (any-lowers (check-for #'lower-case-p thing))) (cond ((and any-uppers any-lowers) - ;; Mixed case, stays the same. + ;; mixed case, stays the same thing) (any-uppers - ;; All uppercase, becomes all lower case. - (diddle-with #'(lambda (x) (if (stringp x) - (string-downcase x) - x)) thing)) + ;; all uppercase, becomes all lower case + (diddle-with (lambda (x) (if (stringp x) + (string-downcase x) + x)) thing)) (any-lowers - ;; All lowercase, becomes all upper case. - (diddle-with #'(lambda (x) (if (stringp x) - (string-upcase x) - x)) thing)) + ;; all lowercase, becomes all upper case + (diddle-with (lambda (x) (if (stringp x) + (string-upcase x) + x)) thing)) (t - ;; No letters? I guess just leave it. + ;; no letters? I guess just leave it. thing)))) thing)) @@ -376,7 +411,7 @@ (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) @@ -400,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)) @@ -437,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 @@ -449,11 +479,11 @@ a host-structure or string." (default-host (if defaults (%pathname-host defaults) (pathname-host *default-pathname-defaults*))) - ;; toy@rtp.ericsson.se: CLHS says make-pathname can take a + ;; Raymond Toy writes: 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: + ;; + ;; Paul Werkowski writes: ;; HyperSpec says for the arg to MAKE-PATHNAME; ;; "host---a valid physical pathname host. ..." ;; where it probably means -- a valid pathname host. @@ -465,10 +495,11 @@ a host-structure or string." ;; 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. + ((string 0) *unix-host*) ; "" cannot be a logical host (string (find-logical-host host t)) ; logical-host or lose. (t default-host))) ; unix-host (diddle-args (and (eq (host-customary-case host) :lower) @@ -502,16 +533,16 @@ a host-structure or string." 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) @@ -521,7 +552,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) @@ -533,7 +564,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) @@ -544,7 +575,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) @@ -554,10 +585,9 @@ a host-structure or string." (%pathname-host pathname)) :lower))))) -;;; PATHNAME-TYPE (defun pathname-type (pathname &key (case :local)) #!+sb-doc - "Accessor for the pathname's name." + "Return PATHNAME's type." (declare (type pathname-designator pathname) (type (member :local :common) case)) (with-pathname (pathname pathname) @@ -567,55 +597,124 @@ a host-structure or string." (%pathname-host pathname)) :lower))))) -;;; PATHNAME-VERSION (defun pathname-version (pathname) #!+sb-doc - "Accessor for the pathname's version." + "Return PATHNAME's version." (declare (type pathname-designator pathname)) (with-pathname (pathname pathname) (%pathname-version pathname))) ;;;; 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 for PARSE-NAMESTRING parsing a potentially +;;; syntactically valid logical namestring with an explicit host. +;;; +;;; This then isn't fully general -- we are relying on the fact that +;;; we will only pass to parse-namestring namestring with an explicit +;;; logical host, so that we can pass the host return from +;;; parse-logical-namestring through to %PARSE-NAMESTRING as a truth +;;; value. Yeah, this is probably a KLUDGE - CSR, 2002-04-18 +(defun parseable-logical-namestring-p (namestr start end) + (catch 'exit + (handler-bind + ((namestring-parse-error (lambda (c) + (declare (ignore c)) + (throw 'exit nil)))) + (let ((colon (position #\: namestr :start start :end end))) + (when colon + (let ((potential-host + (logical-word-or-lose (subseq namestr start colon)))) + ;; depending on the outcome of CSR comp.lang.lisp post + ;; "can PARSE-NAMESTRING create logical hosts", we may need + ;; to do things with potential-host (create it + ;; temporarily, parse the namestring and unintern the + ;; logical host potential-host on failure. + (declare (ignore potential-host)) + (let ((result + (handler-bind + ((simple-type-error (lambda (c) + (declare (ignore c)) + (throw 'exit nil)))) + (parse-logical-namestring namestr start end)))) + ;; if we got this far, we should have an explicit host + ;; (first return value of parse-logical-namestring) + (aver result) + result))))))) + +;;; 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) (namestring-parse-error (condition) (values nil (namestring-parse-error-offset condition)))) - (let* ((end (or end (length namestr))) - (parse-host (or host - (extract-logical-host-prefix namestr start end) - (pathname-host defaults)))) - (unless parse-host - (error "When Host arg is not supplied, Defaults arg must ~ - have a non-null PATHNAME-HOST.")) - + (let* ((end (or end (length namestr)))) (multiple-value-bind (new-host device directory file type version) - (funcall (host-parse parse-host) namestr start end) + ;; Comments below are quotes from the HyperSpec + ;; PARSE-NAMESTRING entry, reproduced here to demonstrate + ;; that we actually have to do things this way rather than + ;; some possibly more logical way. - CSR, 2002-04-18 + (cond + ;; "If host is a logical host then thing is parsed as a + ;; logical pathname namestring on the host." + (host (funcall (host-parse host) namestr start end)) + ;; "If host is nil and thing is a syntactically valid + ;; logical pathname namestring containing an explicit + ;; host, then it is parsed as a logical pathname + ;; namestring." + ((parseable-logical-namestring-p namestr start end) + (parse-logical-namestring namestr start end)) + ;; "If host is nil, default-pathname is a logical + ;; pathname, and thing is a syntactically valid logical + ;; pathname namestring without an explicit host, then it + ;; is parsed as a logical pathname namestring on the + ;; host that is the host component of default-pathname." + ;; + ;; "Otherwise, the parsing of thing is + ;; implementation-defined." + ;; + ;; Both clauses are handled here, as the default + ;; *DEFAULT-PATHNAME-DEFAULTS has a SB-IMPL::UNIX-HOST + ;; for a host. + ((pathname-host defaults) + (funcall (host-parse (pathname-host defaults)) + namestr + start + end)) + ;; I don't think we should ever get here, as the default + ;; host will always have a non-null HOST, given that we + ;; can't create a new pathname without going through + ;; *DEFAULT-PATHNAME-DEFAULTS*, which has a non-null + ;; host... + (t (bug "Fallen through COND in %PARSE-NAMESTRING"))) (when (and host new-host (not (eq new-host host))) - (error "Host in namestring: ~S~@ - does not match explicit host argument: ~S" - host)) - (let ((pn-host (or new-host parse-host))) - (values (%make-pathname-object + (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 host (pathname-host defaults)))) + (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) @@ -627,37 +726,91 @@ a host-structure or string." 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 0) + ;; This is a special host. It's not valid as a + ;; logical host, so it is a sensible thing to + ;; designate the physical Unix host object. So + ;; we do that. + *unix-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 @@ -668,13 +821,13 @@ a host-structure or string." (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) @@ -682,12 +835,12 @@ a host-structure or string." (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) @@ -695,12 +848,12 @@ a host-structure or string." (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) @@ -708,13 +861,14 @@ a host-structure or string." (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) @@ -723,7 +877,7 @@ a host-structure or string." (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))))) ;;;; wild pathnames @@ -758,7 +912,7 @@ a host-structure or string." (declare (type pathname-designator in-pathname)) (with-pathname (pathname in-pathname) (with-pathname (wildname in-wildname) - (macrolet ((frob (field &optional (op 'components-match )) + (macrolet ((frob (field &optional (op 'components-match)) `(or (null (,field wildname)) (,op (,field pathname) (,field wildname))))) (and (or (null (%pathname-host wildname)) @@ -778,7 +932,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)) @@ -790,7 +944,7 @@ a host-structure or string." (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))) @@ -805,7 +959,7 @@ a host-structure or string." (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))))))) @@ -867,7 +1021,7 @@ a host-structure or string." (collect ((subs)) (loop (unless source - (unless (every #'(lambda (x) (eq x :wild-inferiors)) from) + (unless (every (lambda (x) (eq x :wild-inferiors)) from) (didnt-match-error orig-source orig-from)) (subs ()) (return)) @@ -911,29 +1065,34 @@ a host-structure or string." (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 ~ @@ -941,7 +1100,8 @@ a host-structure or string." (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))) @@ -970,7 +1130,7 @@ a host-structure or string." (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) @@ -978,199 +1138,37 @@ 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))) - -;;; 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))))))) - ;;;; 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)) + (when (string= word "") + (error 'namestring-parse-error + :complaint "Attempted to treat invalid logical hostname ~ + as a logical host:~% ~S" + :args (list word) + :namestring word :offset 0)) (let ((word (string-upcase word))) (dotimes (i (length 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) + :args (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 @@ -1178,14 +1176,21 @@ a host-structure or 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) @@ -1209,9 +1214,9 @@ a host-structure or string." (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) + :args (list chunk) :namestring namestring :offset (+ (cdar chunks) pos))) (pattern (subseq chunk last-pos pos))) @@ -1219,7 +1224,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)))) @@ -1227,8 +1232,8 @@ a host-structure or string." :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)) @@ -1244,14 +1249,15 @@ a host-structure or string." (setq prev (1+ i)) (unless (member ch '(#\; #\: #\.)) (error 'namestring-parse-error - :complaint "Illegal character for logical pathname:~% ~S" - :arguments (list ch) + :complaint "illegal character for logical pathname:~% ~S" + :args (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)) @@ -1263,8 +1269,8 @@ a host-structure or string." (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~]." + :args (list what (caar chunks) (caar chunks)) :namestring namestr :offset (if chunks (cdar chunks) end))) (caar chunks)) @@ -1305,8 +1311,8 @@ a host-structure or string." (when chunks (unless (eql (caar chunks) #\.) (error 'namestring-parse-error - :complaint "Expecting a dot, got ~S." - :arguments (list (caar chunks)) + :complaint "expecting a dot, got ~S." + :args (list (caar chunks)) :namestring namestr :offset (cdar chunks))) (if type @@ -1327,24 +1333,23 @@ a host-structure or string." (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) + :args (list str) :namestring namestr :offset (+ pos (cdar chunks)))) (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 @@ -1356,7 +1361,7 @@ a host-structure or string." (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))) @@ -1368,7 +1373,7 @@ a host-structure or string." (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)) @@ -1379,7 +1384,7 @@ a host-structure or string." ((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) @@ -1395,9 +1400,39 @@ a host-structure or string." (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 @@ -1408,22 +1443,18 @@ a host-structure or 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 @@ -1434,44 +1465,18 @@ 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)) - (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." + "Translate PATHNAME to a physical pathname, which is returned." (declare (type pathname-designator pathname) (values (or null pathname))) (typecase pathname @@ -1479,15 +1484,14 @@ a host-structure or string." (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) (return (translate-logical-pathname (translate-pathname pathname from to))))))) (pathname pathname) - (stream (translate-logical-pathname (pathname pathname))) - (t (translate-logical-pathname (logical-pathname pathname))))) + (t (translate-logical-pathname (pathname pathname))))) (defvar *logical-pathname-defaults* (%make-logical-pathname (make-logical-host :name "BOGUS") @@ -1496,3 +1500,14 @@ a host-structure or string." 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)))