1 ;;;; machine/filesystem-independent pathname functions
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
12 (in-package "SB!IMPL")
14 #!-sb-fluid (declaim (freeze-type logical-pathname logical-host))
18 (def!method print-object ((host host) stream)
19 (print-unreadable-object (host stream :type t :identity t)))
23 (def!method print-object ((pathname pathname) stream)
24 (let ((namestring (handler-case (namestring pathname)
27 (format stream "#P~S" namestring)
28 ;; FIXME: This code was rewritten and should be tested. (How does
29 ;; control get to this case anyhow? Perhaps we could just punt it?)
30 (print-unreadable-object (pathname stream :type t)
32 "(with no namestring) :HOST ~S :DEVICE ~S :DIRECTORY ~S ~
33 :NAME ~S :TYPE ~S :VERSION ~S"
34 (%pathname-host pathname)
35 (%pathname-device pathname)
36 (%pathname-directory pathname)
37 (%pathname-name pathname)
38 (%pathname-type pathname)
39 (%pathname-version pathname))))))
41 (def!method make-load-form ((pathname pathname) &optional environment)
42 (make-load-form-saving-slots pathname :environment environment))
44 ;;; The potential conflict with search lists requires isolating the
45 ;;; printed representation to use the i/o macro #.(logical-pathname
46 ;;; <path-designator>).
48 ;;; FIXME: We don't use search lists any more, so that comment is
50 (def!method print-object ((pathname logical-pathname) stream)
51 (let ((namestring (handler-case (namestring pathname)
54 (format stream "#.(logical-pathname ~S)" namestring)
55 (print-unreadable-object (pathname stream :type t)
57 ":HOST ~S :DIRECTORY ~S :FILE ~S :NAME=~S :VERSION ~S"
58 (%pathname-host pathname)
59 (%pathname-directory pathname)
60 (%pathname-name pathname)
61 (%pathname-type pathname)
62 (%pathname-version pathname))))))
64 ;;; A pathname is logical if the host component is a logical host.
65 ;;; This constructor is used to make an instance of the correct type
66 ;;; from parsed arguments.
67 (defun %make-maybe-logical-pathname (host device directory name type version)
68 ;; We canonicalize logical pathname components to uppercase. ANSI
69 ;; doesn't strictly require this, leaving it up to the implementor;
70 ;; but the arguments given in the X3J13 cleanup issue
71 ;; PATHNAME-LOGICAL:ADD seem compelling: we should canonicalize the
72 ;; case, and uppercase is the ordinary way to do that.
73 (flet ((upcase-maybe (x) (typecase x (string (string-upcase x)) (t x))))
74 (if (typep host 'logical-host)
75 (%make-logical-pathname host
77 (mapcar #'upcase-maybe directory)
81 (%make-pathname host device directory name type version))))
83 ;;; Hash table searching maps a logical pathname's host to its
84 ;;; physical pathname translation.
85 (defvar *logical-hosts* (make-hash-table :test 'equal))
89 (def!method make-load-form ((pattern pattern) &optional environment)
90 (make-load-form-saving-slots pattern :environment environment))
92 (def!method print-object ((pattern pattern) stream)
93 (print-unreadable-object (pattern stream :type t)
95 (let ((*print-escape* t))
96 (pprint-fill stream (pattern-pieces pattern) nil))
97 (prin1 (pattern-pieces pattern) stream))))
99 (defun pattern= (pattern1 pattern2)
100 (declare (type pattern pattern1 pattern2))
101 (let ((pieces1 (pattern-pieces pattern1))
102 (pieces2 (pattern-pieces pattern2)))
103 (and (= (length pieces1) (length pieces2))
104 (every #'(lambda (piece1 piece2)
107 (and (simple-string-p piece2)
108 (string= piece1 piece2)))
111 (eq (car piece1) (car piece2))
112 (string= (cdr piece1) (cdr piece2))))
114 (eq piece1 piece2))))
118 ;;; If the string matches the pattern returns the multiple values T and a
119 ;;; list of the matched strings.
120 (defun pattern-matches (pattern string)
121 (declare (type pattern pattern)
122 (type simple-string string))
123 (let ((len (length string)))
124 (labels ((maybe-prepend (subs cur-sub chars)
126 (let* ((len (length chars))
127 (new (make-string len))
130 (setf (schar new (decf index)) char))
133 (matches (pieces start subs cur-sub chars)
136 (values t (maybe-prepend subs cur-sub chars))
138 (let ((piece (car pieces)))
141 (let ((end (+ start (length piece))))
143 (string= piece string
144 :start2 start :end2 end)
145 (matches (cdr pieces) end
146 (maybe-prepend subs cur-sub chars)
152 (let ((char (schar string start)))
153 (if (find char (cdr piece) :test #'char=)
154 (matches (cdr pieces) (1+ start) subs t
155 (cons char chars))))))))
156 ((member :single-char-wild)
158 (matches (cdr pieces) (1+ start) subs t
159 (cons (schar string start) chars))))
160 ((member :multi-char-wild)
161 (multiple-value-bind (won new-subs)
162 (matches (cdr pieces) start subs t chars)
166 (matches pieces (1+ start) subs t
167 (cons (schar string start)
169 (multiple-value-bind (won subs)
170 (matches (pattern-pieces pattern) 0 nil nil nil)
171 (values won (reverse subs))))))
173 ;;; PATHNAME-MATCH-P for directory components
174 (defun directory-components-match (thing wild)
177 ;; If THING has a null directory, assume that it matches
178 ;; (:ABSOLUTE :WILD-INFERIORS) or (:RELATIVE :WILD-INFERIORS).
181 (member (first wild) '(:absolute :relative))
182 (eq (second wild) :wild-inferiors))
184 (let ((wild1 (first wild)))
185 (if (eq wild1 :wild-inferiors)
186 (let ((wild-subdirs (rest wild)))
187 (or (null wild-subdirs)
189 (when (directory-components-match thing wild-subdirs)
192 (unless thing (return nil)))))
194 (components-match (first thing) wild1)
195 (directory-components-match (rest thing)
198 ;;; Return true if pathname component THING is matched by WILD. (not
200 (defun components-match (thing wild)
201 (declare (type (or pattern symbol simple-string integer) thing wild))
206 ;; String is matched by itself, a matching pattern or :WILD.
209 (values (pattern-matches wild thing)))
211 (string= thing wild))))
213 ;; A pattern is only matched by an identical pattern.
214 (and (pattern-p wild) (pattern= thing wild)))
216 ;; An integer (version number) is matched by :WILD or the
217 ;; same integer. This branch will actually always be NIL as
218 ;; long as the version is a fixnum.
221 ;;; a predicate for comparing two pathname slot component sub-entries
222 (defun compare-component (this that)
226 (and (simple-string-p that)
227 (string= this that)))
229 (and (pattern-p that)
230 (pattern= this that)))
233 (compare-component (car this) (car that))
234 (compare-component (cdr this) (cdr that)))))))
236 ;;;; pathname functions
238 (defun pathname= (pathname1 pathname2)
239 (declare (type pathname pathname1)
240 (type pathname pathname2))
241 (and (eq (%pathname-host pathname1)
242 (%pathname-host pathname2))
243 (compare-component (%pathname-device pathname1)
244 (%pathname-device pathname2))
245 (compare-component (%pathname-directory pathname1)
246 (%pathname-directory pathname2))
247 (compare-component (%pathname-name pathname1)
248 (%pathname-name pathname2))
249 (compare-component (%pathname-type pathname1)
250 (%pathname-type pathname2))
251 (compare-component (%pathname-version pathname1)
252 (%pathname-version pathname2))))
254 ;;; Convert PATHNAME-DESIGNATOR (a pathname, or string, or
255 ;;; stream), into a pathname in pathname.
257 ;;; FIXME: was rewritten, should be tested (or rewritten again, this
258 ;;; time using ONCE-ONLY, *then* tested)
259 ;;; FIXME: become SB!XC:DEFMACRO inside EVAL-WHEN (COMPILE EVAL)?
260 (defmacro with-pathname ((pathname pathname-designator) &body body)
261 (let ((pd0 (gensym)))
262 `(let* ((,pd0 ,pathname-designator)
263 (,pathname (etypecase ,pd0
265 (string (parse-namestring ,pd0))
266 (stream (file-name ,pd0)))))
269 ;;; Convert the var, a host or string name for a host, into a
270 ;;; LOGICAL-HOST structure or nil if not defined.
272 ;;; pw notes 1/12/97 this potentially useful macro is not used anywhere
273 ;;; and 'find-host' is not defined. 'find-logical-host' seems to be needed.
275 (defmacro with-host ((var expr) &body body)
276 `(let ((,var (let ((,var ,expr))
279 (string (find-logical-host ,var nil))
284 (defun pathname (thing)
286 "Convert thing (a pathname, string or stream) into a pathname."
287 (declare (type pathname-designator thing))
288 (with-pathname (pathname thing)
291 ;;; Change the case of thing if DIDDLE-P.
292 (defun maybe-diddle-case (thing diddle-p)
293 (if (and diddle-p (not (or (symbolp thing) (integerp thing))))
294 (labels ((check-for (pred in)
297 (dolist (piece (pattern-pieces in))
298 (when (typecase piece
300 (check-for pred piece))
304 (check-for pred (cdr in))))))
308 (when (check-for pred x)
311 (dotimes (i (length in))
312 (when (funcall pred (schar in i))
315 (diddle-with (fun thing)
319 (mapcar #'(lambda (piece)
327 (funcall fun (cdr piece))))
332 (pattern-pieces thing))))
339 (let ((any-uppers (check-for #'upper-case-p thing))
340 (any-lowers (check-for #'lower-case-p thing)))
341 (cond ((and any-uppers any-lowers)
342 ;; Mixed case, stays the same.
345 ;; All uppercase, becomes all lower case.
346 (diddle-with #'(lambda (x) (if (stringp x)
350 ;; All lowercase, becomes all upper case.
351 (diddle-with #'(lambda (x) (if (stringp x)
355 ;; No letters? I guess just leave it.
359 (defun merge-directories (dir1 dir2 diddle-case)
360 (if (or (eq (car dir1) :absolute)
365 (if (and (eq dir :back)
367 (not (eq (car results) :back)))
369 (push dir results))))
370 (dolist (dir (maybe-diddle-case dir2 diddle-case))
372 (dolist (dir (cdr dir1))
376 (defun merge-pathnames (pathname
378 (defaults *default-pathname-defaults*)
379 (default-version :newest))
381 "Construct a filled in pathname by completing the unspecified components
383 (declare (type pathname-designator pathname)
384 (type pathname-designator defaults)
386 (with-pathname (defaults defaults)
387 (let ((pathname (let ((*default-pathname-defaults* defaults))
388 (pathname pathname))))
389 (let* ((default-host (%pathname-host defaults))
390 (pathname-host (%pathname-host pathname))
392 (and default-host pathname-host
393 (not (eq (host-customary-case default-host)
394 (host-customary-case pathname-host))))))
395 (%make-maybe-logical-pathname
396 (or pathname-host default-host)
397 (or (%pathname-device pathname)
398 (maybe-diddle-case (%pathname-device defaults)
400 (merge-directories (%pathname-directory pathname)
401 (%pathname-directory defaults)
403 (or (%pathname-name pathname)
404 (maybe-diddle-case (%pathname-name defaults)
406 (or (%pathname-type pathname)
407 (maybe-diddle-case (%pathname-type defaults)
409 (or (%pathname-version pathname)
410 default-version))))))
412 (defun import-directory (directory diddle-case)
415 ((member :wild) '(:absolute :wild-inferiors))
416 ((member :unspecific) '(:relative))
419 (ecase (pop directory)
422 (when (search-list-p (car directory))
423 (results (pop directory))))
425 (results :relative)))
426 (dolist (piece directory)
427 (cond ((member piece '(:wild :wild-inferiors :up :back))
429 ((or (simple-string-p piece) (pattern-p piece))
430 (results (maybe-diddle-case piece diddle-case)))
432 (results (maybe-diddle-case (coerce piece 'simple-string)
435 (error "~S is not allowed as a directory component." piece))))
439 ,(maybe-diddle-case directory diddle-case)))
442 ,(maybe-diddle-case (coerce directory 'simple-string)
445 (defun make-pathname (&key host
450 (version nil versionp)
454 "Makes a new pathname from the component arguments. Note that host is
455 a host-structure or string."
456 (declare (type (or string host component-tokens) host)
457 (type (or string component-tokens) device)
458 (type (or list string pattern component-tokens) directory)
459 (type (or string pattern component-tokens) name type)
460 (type (or integer component-tokens (member :newest)) version)
461 (type (or pathname-designator null) defaults)
462 (type (member :common :local) case))
463 (let* ((defaults (when defaults
464 (with-pathname (defaults defaults) defaults)))
465 (default-host (if defaults
466 (%pathname-host defaults)
467 (pathname-host *default-pathname-defaults*)))
468 ;; toy@rtp.ericsson.se: CLHS says make-pathname can take a
469 ;; string (as a logical-host) for the host part. We map that
470 ;; string into the corresponding logical host structure.
473 ;; HyperSpec says for the arg to MAKE-PATHNAME;
474 ;; "host---a valid physical pathname host. ..."
475 ;; where it probably means -- a valid pathname host.
476 ;; "valid pathname host n. a valid physical pathname host or
477 ;; a valid logical pathname host."
479 ;; "valid physical pathname host n. any of a string,
480 ;; a list of strings, or the symbol :unspecific,
481 ;; that is recognized by the implementation as the name of a host."
482 ;; "valid logical pathname host n. a string that has been defined
483 ;; as the name of a logical host. ..."
484 ;; HS is silent on what happens if the :HOST arg is NOT one of these.
485 ;; It seems an error message is appropriate.
487 (host host) ; A valid host, use it.
488 (string (find-logical-host host t)) ; logical-host or lose.
489 (t default-host))) ; unix-host
490 (diddle-args (and (eq (host-customary-case host) :lower)
493 (not (eq (host-customary-case host)
494 (host-customary-case default-host))))
495 (dev (if devp device (if defaults (%pathname-device defaults))))
496 (dir (import-directory directory diddle-args))
499 (defaults (%pathname-version defaults))
501 (when (and defaults (not dirp))
503 (merge-directories dir
504 (%pathname-directory defaults)
507 (macrolet ((pick (var varp field)
508 `(cond ((or (simple-string-p ,var)
510 (maybe-diddle-case ,var diddle-args))
512 (maybe-diddle-case (coerce ,var 'simple-string)
515 (maybe-diddle-case ,var diddle-args))
517 (maybe-diddle-case (,field defaults)
521 (%make-maybe-logical-pathname host
522 dev ; forced to :UNSPECIFIC when logical
524 (pick name namep %pathname-name)
525 (pick type typep %pathname-type)
528 (defun pathname-host (pathname &key (case :local))
530 "Accessor for the pathname's host."
531 (declare (type pathname-designator pathname)
532 (type (member :local :common) case)
535 (with-pathname (pathname pathname)
536 (%pathname-host pathname)))
538 (defun pathname-device (pathname &key (case :local))
540 "Accessor for pathname's device."
541 (declare (type pathname-designator pathname)
542 (type (member :local :common) case))
543 (with-pathname (pathname pathname)
544 (maybe-diddle-case (%pathname-device pathname)
545 (and (eq case :common)
546 (eq (host-customary-case
547 (%pathname-host pathname))
550 (defun pathname-directory (pathname &key (case :local))
552 "Accessor for the pathname's directory list."
553 (declare (type pathname-designator pathname)
554 (type (member :local :common) case))
555 (with-pathname (pathname pathname)
556 (maybe-diddle-case (%pathname-directory pathname)
557 (and (eq case :common)
558 (eq (host-customary-case
559 (%pathname-host pathname))
561 (defun pathname-name (pathname &key (case :local))
563 "Accessor for the pathname's name."
564 (declare (type pathname-designator pathname)
565 (type (member :local :common) case))
566 (with-pathname (pathname pathname)
567 (maybe-diddle-case (%pathname-name pathname)
568 (and (eq case :common)
569 (eq (host-customary-case
570 (%pathname-host pathname))
573 (defun pathname-type (pathname &key (case :local))
575 "Accessor for the pathname's name."
576 (declare (type pathname-designator pathname)
577 (type (member :local :common) case))
578 (with-pathname (pathname pathname)
579 (maybe-diddle-case (%pathname-type pathname)
580 (and (eq case :common)
581 (eq (host-customary-case
582 (%pathname-host pathname))
585 (defun pathname-version (pathname)
587 "Accessor for the pathname's version."
588 (declare (type pathname-designator pathname))
589 (with-pathname (pathname pathname)
590 (%pathname-version pathname)))
594 ;;; Handle the case where PARSE-NAMESTRING is actually parsing a
595 ;;; namestring. We pick off the :JUNK-ALLOWED case then find a host to
596 ;;; use for parsing, call the parser, then check whether the host matches.
597 (defun %parse-namestring (namestr host defaults start end junk-allowed)
598 (declare (type (or host null) host)
599 (type string namestr)
601 (type (or index null) end))
604 (%parse-namestring namestr host defaults start end nil)
605 (namestring-parse-error (condition)
606 (values nil (namestring-parse-error-offset condition))))
607 (let* ((end (or end (length namestr)))
609 (extract-logical-host-prefix namestr start end)
610 (pathname-host defaults))))
612 (error "When no HOST argument is supplied, the DEFAULTS argument ~
613 must have a non-null PATHNAME-HOST."))
615 (multiple-value-bind (new-host device directory file type version)
616 (funcall (host-parse parse-host) namestr start end)
617 (when (and host new-host (not (eq new-host host)))
618 (error 'simple-type-error
620 ;; Note: ANSI requires that this be a TYPE-ERROR,
621 ;; but there seems to be no completely correct
622 ;; value to use for TYPE-ERROR-EXPECTED-TYPE.
623 ;; Instead, we return a sort of "type error allowed
624 ;; type", trying to say "it would be OK if you
625 ;; passed NIL as the host value" but not mentioning
626 ;; that a matching string would be OK too.
629 "The host in the namestring, ~S,~@
630 does not match the explicit HOST argument, ~S."
631 :format-arguments (list new-host host)))
632 (let ((pn-host (or new-host parse-host)))
633 (values (%make-maybe-logical-pathname
634 pn-host device directory file type version)
637 ;;; If NAMESTR begins with a colon-terminated, defined, logical host,
638 ;;; then return that host, otherwise return NIL.
639 (defun extract-logical-host-prefix (namestr start end)
640 (declare (type simple-base-string namestr)
641 (type index start end)
642 (values (or logical-host null)))
643 (let ((colon-pos (position #\: namestr :start start :end end)))
645 (values (gethash (nstring-upcase (subseq namestr start colon-pos))
649 (defun parse-namestring (thing
652 (defaults *default-pathname-defaults*)
653 &key (start 0) end junk-allowed)
654 (declare (type pathname-designator thing)
655 (type (or list host string (member :unspecific)) host)
656 (type pathname defaults)
658 (type (or index null) end)
659 (type (or t null) junk-allowed)
660 (values (or null pathname) (or null index)))
661 ;; Generally, redundant specification of information in software,
662 ;; whether in code or in comments, is bad. However, the ANSI spec
663 ;; for this is messy enough that it's hard to hold in short-term
664 ;; memory, so I've recorded these redundant notes on the
665 ;; implications of the ANSI spec.
667 ;; According to the ANSI spec, HOST can be a valid pathname host, or
668 ;; a logical host, or NIL.
670 ;; A valid pathname host can be a valid physical pathname host or a
671 ;; valid logical pathname host.
673 ;; A valid physical pathname host is "any of a string, a list of
674 ;; strings, or the symbol :UNSPECIFIC, that is recognized by the
675 ;; implementation as the name of a host". In SBCL as of 0.6.9.8,
676 ;; that means :UNSPECIFIC: though someday we might want to
677 ;; generalize it to allow strings like "RTFM.MIT.EDU" or lists like
678 ;; '("RTFM" "MIT" "EDU"), that's not supported now.
680 ;; A valid logical pathname host is a string which has been defined as
681 ;; the name of a logical host, as with LOAD-LOGICAL-PATHNAME-TRANSLATIONS.
683 ;; A logical host is an object of implementation-dependent nature. In
684 ;; SBCL, it's a member of the HOST class (a subclass of STRUCTURE-OBJECT).
685 (let ((found-host (etypecase host
687 ;; In general ANSI-compliant Common Lisps, a
688 ;; string might also be a physical pathname host,
689 ;; but ANSI leaves this up to the implementor,
690 ;; and in SBCL we don't do it, so it must be a
692 (find-logical-host host))
693 ((or null (member :unspecific))
694 ;; CLHS says that HOST=:UNSPECIFIC has
695 ;; implementation-defined behavior. We
696 ;; just turn it into NIL.
699 ;; ANSI also allows LISTs to designate hosts,
700 ;; but leaves its interpretation
701 ;; implementation-defined. Our interpretation
702 ;; is that it's unsupported.:-|
703 (error "A LIST representing a pathname host is not ~
704 supported in this implementation:~% ~S"
708 (declare (type (or null host) found-host))
711 (%parse-namestring thing found-host defaults start end junk-allowed))
713 (%parse-namestring (coerce thing 'simple-string)
714 found-host defaults start end junk-allowed))
716 (let ((defaulted-host (or found-host (%pathname-host defaults))))
717 (declare (type host defaulted-host))
718 (unless (eq defaulted-host (%pathname-host thing))
719 (error "The HOST argument doesn't match the pathname host:~% ~
721 defaulted-host (%pathname-host thing))))
722 (values thing start))
724 (let ((name (file-name thing)))
726 (error "can't figure out the file associated with stream:~% ~S"
728 (values name nil))))))
730 (defun namestring (pathname)
732 "Construct the full (name)string form of the pathname."
733 (declare (type pathname-designator pathname)
734 (values (or null simple-base-string)))
735 (with-pathname (pathname pathname)
737 (let ((host (%pathname-host pathname)))
739 (error "can't determine the namestring for pathnames with no ~
740 host:~% ~S" pathname))
741 (funcall (host-unparse host) pathname)))))
743 (defun host-namestring (pathname)
745 "Returns a string representation of the name of the host in the pathname."
746 (declare (type pathname-designator pathname)
747 (values (or null simple-base-string)))
748 (with-pathname (pathname pathname)
749 (let ((host (%pathname-host pathname)))
751 (funcall (host-unparse-host host) pathname)
753 "can't determine the namestring for pathnames with no host:~% ~S"
756 (defun directory-namestring (pathname)
758 "Returns a string representation of the directories used in the pathname."
759 (declare (type pathname-designator pathname)
760 (values (or null simple-base-string)))
761 (with-pathname (pathname pathname)
762 (let ((host (%pathname-host pathname)))
764 (funcall (host-unparse-directory host) pathname)
766 "can't determine the namestring for pathnames with no host:~% ~S"
769 (defun file-namestring (pathname)
771 "Returns a string representation of the name used in the pathname."
772 (declare (type pathname-designator pathname)
773 (values (or null simple-base-string)))
774 (with-pathname (pathname pathname)
775 (let ((host (%pathname-host pathname)))
777 (funcall (host-unparse-file host) pathname)
779 "can't determine the namestring for pathnames with no host:~% ~S"
782 (defun enough-namestring (pathname
784 (defaults *default-pathname-defaults*))
786 "Returns an abbreviated pathname sufficent to identify the pathname relative
788 (declare (type pathname-designator pathname))
789 (with-pathname (pathname pathname)
790 (let ((host (%pathname-host pathname)))
792 (with-pathname (defaults defaults)
793 (funcall (host-unparse-enough host) pathname defaults))
795 "can't determine the namestring for pathnames with no host:~% ~S"
800 (defun wild-pathname-p (pathname &optional field-key)
802 "Predicate for determining whether pathname contains any wildcards."
803 (declare (type pathname-designator pathname)
804 (type (member nil :host :device :directory :name :type :version)
806 (with-pathname (pathname pathname)
808 (or (pattern-p x) (member x '(:wild :wild-inferiors)))))
811 (or (wild-pathname-p pathname :host)
812 (wild-pathname-p pathname :device)
813 (wild-pathname-p pathname :directory)
814 (wild-pathname-p pathname :name)
815 (wild-pathname-p pathname :type)
816 (wild-pathname-p pathname :version)))
817 (:host (frob (%pathname-host pathname)))
818 (:device (frob (%pathname-host pathname)))
819 (:directory (some #'frob (%pathname-directory pathname)))
820 (:name (frob (%pathname-name pathname)))
821 (:type (frob (%pathname-type pathname)))
822 (:version (frob (%pathname-version pathname)))))))
824 (defun pathname-match-p (in-pathname in-wildname)
826 "Pathname matches the wildname template?"
827 (declare (type pathname-designator in-pathname))
828 (with-pathname (pathname in-pathname)
829 (with-pathname (wildname in-wildname)
830 (macrolet ((frob (field &optional (op 'components-match ))
831 `(or (null (,field wildname))
832 (,op (,field pathname) (,field wildname)))))
833 (and (or (null (%pathname-host wildname))
834 (eq (%pathname-host wildname) (%pathname-host pathname)))
835 (frob %pathname-device)
836 (frob %pathname-directory directory-components-match)
837 (frob %pathname-name)
838 (frob %pathname-type)
839 (frob %pathname-version))))))
841 ;;; Place the substitutions into the pattern and return the string or pattern
842 ;;; that results. If DIDDLE-CASE is true, we diddle the result case as well,
843 ;;; in case we are translating between hosts with difference conventional case.
844 ;;; The second value is the tail of subs with all of the values that we used up
845 ;;; stripped off. Note that PATTERN-MATCHES matches all consecutive wildcards
846 ;;; as a single string, so we ignore subsequent contiguous wildcards.
847 (defun substitute-into (pattern subs diddle-case)
848 (declare (type pattern pattern)
850 (values (or simple-base-string pattern)))
851 (let ((in-wildcard nil)
854 (dolist (piece (pattern-pieces pattern))
855 (cond ((simple-string-p piece)
857 (setf in-wildcard nil))
862 (error "not enough wildcards in FROM pattern to match ~
865 (let ((sub (pop subs)))
869 (push (apply #'concatenate 'simple-string
872 (dolist (piece (pattern-pieces sub))
873 (push piece pieces)))
877 (error "can't substitute this into the middle of a word:~
882 (push (apply #'concatenate 'simple-string (nreverse strings))
886 (if (and pieces (simple-string-p (car pieces)) (null (cdr pieces)))
888 (make-pattern (nreverse pieces)))
892 ;;; Called when we can't see how source and from matched.
893 (defun didnt-match-error (source from)
894 (error "Pathname components from SOURCE and FROM args to TRANSLATE-PATHNAME~@
895 did not match:~% ~S ~S"
898 ;;; Do TRANSLATE-COMPONENT for all components except host and directory.
899 (defun translate-component (source from to diddle-case)
906 (if (pattern= from source)
908 (didnt-match-error source from)))
910 (multiple-value-bind (won subs) (pattern-matches from source)
912 (values (substitute-into to subs diddle-case))
913 (didnt-match-error source from))))
915 (maybe-diddle-case source diddle-case))))
917 (values (substitute-into to (list source) diddle-case)))
919 (if (components-match source from)
920 (maybe-diddle-case source diddle-case)
921 (didnt-match-error source from)))))
923 (maybe-diddle-case source diddle-case))
925 (if (components-match source from)
927 (didnt-match-error source from)))))
929 ;;; Return a list of all the things that we want to substitute into the TO
930 ;;; pattern (the things matched by from on source.) When From contains
931 ;;; :WILD-INFERIORS, the result contains a sublist of the matched source
933 (defun compute-directory-substitutions (orig-source orig-from)
934 (let ((source orig-source)
939 (unless (every #'(lambda (x) (eq x :wild-inferiors)) from)
940 (didnt-match-error orig-source orig-from))
943 (unless from (didnt-match-error orig-source orig-from))
944 (let ((from-part (pop from))
945 (source-part (pop source)))
948 (typecase source-part
950 (if (pattern= from-part source-part)
952 (didnt-match-error orig-source orig-from)))
954 (multiple-value-bind (won new-subs)
955 (pattern-matches from-part source-part)
957 (dolist (sub new-subs)
959 (didnt-match-error orig-source orig-from))))
961 (didnt-match-error orig-source orig-from))))
964 ((member :wild-inferiors)
965 (let ((remaining-source (cons source-part source)))
968 (when (directory-components-match remaining-source from)
970 (unless remaining-source
971 (didnt-match-error orig-source orig-from))
972 (res (pop remaining-source)))
974 (setq source remaining-source))))
976 (unless (and (simple-string-p source-part)
977 (string= from-part source-part))
978 (didnt-match-error orig-source orig-from)))
980 (didnt-match-error orig-source orig-from)))))
983 ;;; This is called by TRANSLATE-PATHNAME on the directory components
984 ;;; of its argument pathnames to produce the result directory
985 ;;; component. If this leaves the directory NIL, we return the source
986 ;;; directory. The :RELATIVE or :ABSOLUTE is taken from the source
987 ;;; directory, except if TO is :ABSOLUTE, in which case the result
988 ;;; will be :ABSOLUTE.
989 (defun translate-directories (source from to diddle-case)
990 (if (not (and source to from))
991 (or (and to (null source) (remove :wild-inferiors to))
992 (mapcar (lambda (x) (maybe-diddle-case x diddle-case)) source))
994 ;; If TO is :ABSOLUTE, the result should still be :ABSOLUTE.
995 (res (if (eq (first to) :absolute)
998 (let ((subs-left (compute-directory-substitutions (rest source)
1000 (dolist (to-part (rest to))
1004 (let ((match (pop subs-left)))
1006 (error ":WILD-INFERIORS is not paired in from and to ~
1007 patterns:~% ~S ~S" from to))
1008 (res (maybe-diddle-case match diddle-case))))
1009 ((member :wild-inferiors)
1011 (let ((match (pop subs-left)))
1012 (unless (listp match)
1013 (error ":WILD-INFERIORS not paired in from and to ~
1014 patterns:~% ~S ~S" from to))
1016 (res (maybe-diddle-case x diddle-case)))))
1018 (multiple-value-bind
1020 (substitute-into to-part subs-left diddle-case)
1021 (setf subs-left new-subs-left)
1023 (t (res to-part)))))
1026 (defun translate-pathname (source from-wildname to-wildname &key)
1028 "Use the source pathname to translate the from-wildname's wild and
1029 unspecified elements into a completed to-pathname based on the to-wildname."
1030 (declare (type pathname-designator source from-wildname to-wildname))
1031 (with-pathname (source source)
1032 (with-pathname (from from-wildname)
1033 (with-pathname (to to-wildname)
1034 (let* ((source-host (%pathname-host source))
1035 (to-host (%pathname-host to))
1037 (and source-host to-host
1038 (not (eq (host-customary-case source-host)
1039 (host-customary-case to-host))))))
1040 (macrolet ((frob (field &optional (op 'translate-component))
1041 `(let ((result (,op (,field source)
1045 (if (eq result :error)
1046 (error "~S doesn't match ~S." source from)
1048 (%make-maybe-logical-pathname
1049 (or to-host source-host)
1050 (frob %pathname-device)
1051 (frob %pathname-directory translate-directories)
1052 (frob %pathname-name)
1053 (frob %pathname-type)
1054 (frob %pathname-version))))))))
1058 (def!struct (search-list (:make-load-form-fun
1060 (values `(intern-search-list
1061 ',(search-list-name s))
1063 ;; The name of this search-list. Always stored in lowercase.
1064 (name (required-argument) :type simple-string)
1065 ;; T if this search-list has been defined. Otherwise NIL.
1066 (defined nil :type (member t nil))
1067 ;; the list of expansions for this search-list. Each expansion is
1068 ;; the list of directory components to use in place of this
1070 (expansions nil :type list))
1071 (def!method print-object ((sl search-list) stream)
1072 (print-unreadable-object (sl stream :type t)
1073 (write-string (search-list-name sl) stream)))
1075 ;;; a hash table mapping search-list names to search-list structures
1076 (defvar *search-lists* (make-hash-table :test 'equal))
1078 ;;; When search-lists are encountered in namestrings, they are
1079 ;;; converted to search-list structures right then, instead of waiting
1080 ;;; until the search list used. This allows us to verify ahead of time
1081 ;;; that there are no circularities and makes expansion much quicker.
1082 (defun intern-search-list (name)
1083 (let ((name (string-downcase name)))
1084 (or (gethash name *search-lists*)
1085 (let ((new (make-search-list :name name)))
1086 (setf (gethash name *search-lists*) new)
1089 ;;; Clear the definition. Note: we can't remove it from the hash-table
1090 ;;; because there may be pathnames still refering to it. So we just
1091 ;;; clear out the expansions and ste defined to NIL.
1092 (defun clear-search-list (name)
1094 "Clear the current definition for the search-list NAME. Returns T if such
1095 a definition existed, and NIL if not."
1096 (let* ((name (string-downcase name))
1097 (search-list (gethash name *search-lists*)))
1098 (when (and search-list (search-list-defined search-list))
1099 (setf (search-list-defined search-list) nil)
1100 (setf (search-list-expansions search-list) nil)
1103 ;;; As in CLEAR-SEARCH-LIST, we can't actually remove the entries from
1104 ;;; the hash-table, so we just mark them as being undefined.
1105 (defun clear-all-search-lists ()
1107 "Clear the definition for all search-lists. Only use this if you know
1108 what you are doing."
1109 (maphash #'(lambda (name search-list)
1110 (declare (ignore name))
1111 (setf (search-list-defined search-list) nil)
1112 (setf (search-list-expansions search-list) nil))
1116 ;;; Extract the search-list from PATHNAME and return it. If PATHNAME
1117 ;;; doesn't start with a search-list, then either error (if
1118 ;;; FLAME-IF-NONE is true) or return NIL (if FLAME-IF-NONE is false).
1119 (defun extract-search-list (pathname flame-if-none)
1120 (with-pathname (pathname pathname)
1121 (let* ((directory (%pathname-directory pathname))
1122 (search-list (cadr directory)))
1123 (cond ((search-list-p search-list)
1126 (error "~S doesn't start with a search-list." pathname))
1130 ;;; We have to convert the internal form of the search-list back into
1131 ;;; a bunch of pathnames.
1132 (defun search-list (pathname)
1134 "Return the expansions for the search-list starting PATHNAME. If PATHNAME
1135 does not start with a search-list, then an error is signaled. If
1136 the search-list has not been defined yet, then an error is signaled.
1137 The expansion for a search-list can be set with SETF."
1138 (with-pathname (pathname pathname)
1139 (let ((search-list (extract-search-list pathname t))
1140 (host (pathname-host pathname)))
1141 (if (search-list-defined search-list)
1142 (mapcar #'(lambda (directory)
1143 (make-pathname :host host
1144 :directory (cons :absolute directory)))
1145 (search-list-expansions search-list))
1146 (error "Search list ~S has not been defined yet." pathname)))))
1148 (defun search-list-defined-p (pathname)
1150 "Returns T if the search-list starting PATHNAME is currently defined, and
1151 NIL otherwise. An error is signaled if PATHNAME does not start with a
1153 (with-pathname (pathname pathname)
1154 (search-list-defined (extract-search-list pathname t))))
1156 ;;; Set the expansion for the search list in PATHNAME. If this would
1157 ;;; result in any circularities, we flame out. If anything goes wrong,
1158 ;;; we leave the old definition intact.
1159 (defun %set-search-list (pathname values)
1160 (let ((search-list (extract-search-list pathname t)))
1162 ((check (target-list path)
1163 (when (eq search-list target-list)
1164 (error "That would result in a circularity:~% ~
1166 (search-list-name search-list)
1168 (search-list-name target-list)))
1169 (when (search-list-p target-list)
1170 (push (search-list-name target-list) path)
1171 (dolist (expansion (search-list-expansions target-list))
1172 (check (car expansion) path))))
1174 (with-pathname (pathname pathname)
1175 (when (or (pathname-name pathname)
1176 (pathname-type pathname)
1177 (pathname-version pathname))
1178 (error "Search-lists cannot expand into pathnames that have ~
1179 a name, type, or ~%version specified:~% ~S"
1181 (let ((directory (pathname-directory pathname)))
1184 (ecase (car directory)
1185 (:absolute (cdr directory))
1186 (:relative (cons (intern-search-list "default")
1188 (list (intern-search-list "default")))))
1189 (check (car expansion) nil)
1191 (setf (search-list-expansions search-list)
1193 (mapcar #'convert values)
1194 (list (convert values)))))
1195 (setf (search-list-defined search-list) t))
1198 (defun %enumerate-search-list (pathname function)
1199 (/show0 "entering %ENUMERATE-SEARCH-LIST")
1200 (let* ((pathname (if (typep pathname 'logical-pathname)
1201 (translate-logical-pathname pathname)
1203 (search-list (extract-search-list pathname nil)))
1204 (/show0 "PATHNAME and SEARCH-LIST computed")
1207 (/show0 "no search list")
1208 (funcall function pathname))
1209 ((not (search-list-defined search-list))
1210 (/show0 "undefined search list")
1211 (error "undefined search list: ~A"
1212 (search-list-name search-list)))
1214 (/show0 "general case")
1215 (let ((tail (cddr (pathname-directory pathname))))
1216 (/show0 "TAIL computed")
1218 (search-list-expansions search-list))
1219 (/show0 "tail recursing in %ENUMERATE-SEARCH-LIST")
1220 (%enumerate-search-list (make-pathname :defaults pathname
1227 ;;;; logical pathname support. ANSI 92-102 specification.
1229 ;;;; As logical-pathname translations are loaded they are
1230 ;;;; canonicalized as patterns to enable rapid efficent translation
1231 ;;;; into physical pathnames.
1235 ;;; Canonicalize a logical pathanme word by uppercasing it checking that it
1236 ;;; contains only legal characters.
1237 (defun logical-word-or-lose (word)
1238 (declare (string word))
1239 (let ((word (string-upcase word)))
1240 (dotimes (i (length word))
1241 (let ((ch (schar word i)))
1242 (unless (or (alpha-char-p ch) (digit-char-p ch) (char= ch #\-))
1243 (error 'namestring-parse-error
1244 :complaint "logical namestring character which ~
1245 is not alphanumeric or hyphen:~% ~S"
1246 :arguments (list ch)
1247 :namestring word :offset i))))
1250 ;;; Given a logical host or string, return a logical host. If ERROR-P
1251 ;;; is NIL, then return NIL when no such host exists.
1252 (defun find-logical-host (thing &optional (errorp t))
1255 (let ((found (gethash (logical-word-or-lose thing)
1257 (if (or found (not errorp))
1259 ;; This is the error signalled from e.g.
1260 ;; LOGICAL-PATHNAME-TRANSLATIONS when host is not a defined
1261 ;; host, and ANSI specifies that that's a TYPE-ERROR.
1262 (error 'simple-type-error
1264 ;; God only knows what ANSI expects us to use for
1265 ;; the EXPECTED-TYPE here. Maybe this will be OK..
1267 '(and string (satisfies logical-pathname-translations))
1268 :format-control "logical host not yet defined: ~S"
1269 :format-arguments (list thing)))))
1270 (logical-host thing)))
1272 ;;; Given a logical host name or host, return a logical host, creating
1273 ;;; a new one if necessary.
1274 (defun intern-logical-host (thing)
1275 (declare (values logical-host))
1276 (or (find-logical-host thing nil)
1277 (let* ((name (logical-word-or-lose thing))
1278 (new (make-logical-host :name name)))
1279 (setf (gethash name *logical-hosts*) new)
1282 ;;;; logical pathname parsing
1284 ;;; Deal with multi-char wildcards in a logical pathname token.
1285 (defun maybe-make-logical-pattern (namestring chunks)
1286 (let ((chunk (caar chunks)))
1287 (collect ((pattern))
1289 (len (length chunk)))
1290 (declare (fixnum last-pos))
1292 (when (= last-pos len) (return))
1293 (let ((pos (or (position #\* chunk :start last-pos) len)))
1294 (if (= pos last-pos)
1296 (error 'namestring-parse-error
1297 :complaint "double asterisk inside of logical ~
1299 :arguments (list chunk)
1300 :namestring namestring
1301 :offset (+ (cdar chunks) pos)))
1302 (pattern (subseq chunk last-pos pos)))
1305 (pattern :multi-char-wild))
1306 (setq last-pos (1+ pos)))))
1309 (make-pattern (pattern))
1310 (let ((x (car (pattern))))
1311 (if (eq x :multi-char-wild)
1315 ;;; Return a list of conses where the CDR is the start position and
1316 ;;; the CAR is a string (token) or character (punctuation.)
1317 (defun logical-chunkify (namestr start end)
1319 (do ((i start (1+ i))
1323 (chunks (cons (nstring-upcase (subseq namestr prev end)) prev))))
1324 (let ((ch (schar namestr i)))
1325 (unless (or (alpha-char-p ch) (digit-char-p ch)
1326 (member ch '(#\- #\*)))
1328 (chunks (cons (nstring-upcase (subseq namestr prev i)) prev)))
1330 (unless (member ch '(#\; #\: #\.))
1331 (error 'namestring-parse-error
1332 :complaint "illegal character for logical pathname:~% ~S"
1333 :arguments (list ch)
1336 (chunks (cons ch i)))))
1339 ;;; Break up a logical-namestring, always a string, into its
1340 ;;; constituent parts.
1341 (defun parse-logical-namestring (namestr start end)
1342 (declare (type simple-base-string namestr)
1343 (type index start end))
1344 (collect ((directory))
1349 (labels ((expecting (what chunks)
1350 (unless (and chunks (simple-string-p (caar chunks)))
1351 (error 'namestring-parse-error
1352 :complaint "expecting ~A, got ~:[nothing~;~S~]."
1353 :arguments (list what (caar chunks) (caar chunks))
1355 :offset (if chunks (cdar chunks) end)))
1357 (parse-host (chunks)
1358 (case (caadr chunks)
1361 (find-logical-host (expecting "a host name" chunks)))
1362 (parse-relative (cddr chunks)))
1364 (parse-relative chunks))))
1365 (parse-relative (chunks)
1368 (directory :relative)
1369 (parse-directory (cdr chunks)))
1371 (directory :absolute) ; Assumption! Maybe revoked later.
1372 (parse-directory chunks))))
1373 (parse-directory (chunks)
1374 (case (caadr chunks)
1377 (let ((res (expecting "a directory name" chunks)))
1378 (cond ((string= res "..") :up)
1379 ((string= res "**") :wild-inferiors)
1381 (maybe-make-logical-pattern namestr chunks)))))
1382 (parse-directory (cddr chunks)))
1384 (parse-name chunks))))
1385 (parse-name (chunks)
1387 (expecting "a file name" chunks)
1388 (setq name (maybe-make-logical-pattern namestr chunks))
1389 (expecting-dot (cdr chunks))))
1390 (expecting-dot (chunks)
1392 (unless (eql (caar chunks) #\.)
1393 (error 'namestring-parse-error
1394 :complaint "expecting a dot, got ~S."
1395 :arguments (list (caar chunks))
1397 :offset (cdar chunks)))
1399 (parse-version (cdr chunks))
1400 (parse-type (cdr chunks)))))
1401 (parse-type (chunks)
1402 (expecting "a file type" chunks)
1403 (setq type (maybe-make-logical-pattern namestr chunks))
1404 (expecting-dot (cdr chunks)))
1405 (parse-version (chunks)
1406 (let ((str (expecting "a positive integer, * or NEWEST"
1409 ((string= str "*") (setq version :wild))
1410 ((string= str "NEWEST") (setq version :newest))
1412 (multiple-value-bind (res pos)
1413 (parse-integer str :junk-allowed t)
1414 (unless (and res (plusp res))
1415 (error 'namestring-parse-error
1416 :complaint "expected a positive integer, ~
1418 :arguments (list str)
1420 :offset (+ pos (cdar chunks))))
1421 (setq version res)))))
1423 (error 'namestring-parse-error
1424 :complaint "extra stuff after end of file name"
1426 :offset (cdadr chunks)))))
1427 (parse-host (logical-chunkify namestr start end)))
1428 (values host :unspecific
1429 (and (not (equal (directory)'(:absolute)))(directory))
1430 name type version))))
1432 ;;; We can't initialize this yet because not all host methods are loaded yet.
1433 (defvar *logical-pathname-defaults*)
1435 (defun logical-pathname (pathspec)
1437 "Converts the pathspec argument to a logical-pathname and returns it."
1438 (declare (type (or logical-pathname string stream) pathspec)
1439 (values logical-pathname))
1440 (if (typep pathspec 'logical-pathname)
1442 (let ((res (parse-namestring pathspec nil *logical-pathname-defaults*)))
1443 (when (eq (%pathname-host res)
1444 (%pathname-host *logical-pathname-defaults*))
1445 (error "This logical namestring does not specify a host:~% ~S"
1449 ;;;; logical pathname unparsing
1451 (defun unparse-logical-directory (pathname)
1452 (declare (type pathname pathname))
1454 (let ((directory (%pathname-directory pathname)))
1456 (ecase (pop directory)
1457 (:absolute) ; nothing special
1458 (:relative (pieces ";")))
1459 (dolist (dir directory)
1460 (cond ((or (stringp dir) (pattern-p dir))
1461 (pieces (unparse-logical-piece dir))
1465 ((eq dir :wild-inferiors)
1468 (error "invalid directory component: ~S" dir))))))
1469 (apply #'concatenate 'simple-string (pieces))))
1471 (defun unparse-logical-piece (thing)
1473 (simple-string thing)
1475 (collect ((strings))
1476 (dolist (piece (pattern-pieces thing))
1478 (simple-string (strings piece))
1480 (cond ((eq piece :wild-inferiors)
1482 ((eq piece :multi-char-wild)
1484 (t (error "invalid keyword: ~S" piece))))))
1485 (apply #'concatenate 'simple-string (strings))))))
1487 ;;; Unparse a logical pathname string.
1488 (defun unparse-enough-namestring (pathname defaults)
1489 (let* ((path-dir (pathname-directory pathname))
1490 (def-dir (pathname-directory defaults))
1492 ;; Go down the directory lists to see what matches. What's
1493 ;; left is what we want, more or less.
1494 (cond ((and (eq (first path-dir) (first def-dir))
1495 (eq (first path-dir) :absolute))
1496 ;; Both paths are :ABSOLUTE, so find where the
1497 ;; common parts end and return what's left
1498 (do* ((p (rest path-dir) (rest p))
1499 (d (rest def-dir) (rest d)))
1500 ((or (endp p) (endp d)
1501 (not (equal (first p) (first d))))
1504 ;; At least one path is :RELATIVE, so just return the
1505 ;; original path. If the original path is :RELATIVE,
1506 ;; then that's the right one. If PATH-DIR is
1507 ;; :ABSOLUTE, we want to return that except when
1508 ;; DEF-DIR is :ABSOLUTE, as handled above. so return
1509 ;; the original directory.
1511 (make-pathname :host (pathname-host pathname)
1512 :directory enough-dir
1513 :name (pathname-name pathname)
1514 :type (pathname-type pathname)
1515 :version (pathname-version pathname))))
1517 (defun unparse-logical-namestring (pathname)
1518 (declare (type logical-pathname pathname))
1519 (concatenate 'simple-string
1520 (logical-host-name (%pathname-host pathname)) ":"
1521 (unparse-logical-directory pathname)
1522 (unparse-unix-file pathname)))
1524 ;;;; logical pathname translations
1526 ;;; Verify that the list of translations consists of lists and prepare
1527 ;;; canonical translations. (Parse pathnames and expand out wildcards
1529 (defun canonicalize-logical-pathname-translations (translation-list host)
1530 (declare (type list translation-list) (type host host)
1532 (mapcar (lambda (translation)
1533 (destructuring-bind (from to) translation
1534 (list (if (typep from 'logical-pathname)
1536 (parse-namestring from host))
1540 (defun logical-pathname-translations (host)
1542 "Return the (logical) host object argument's list of translations."
1543 (declare (type (or string logical-host) host)
1545 (logical-host-translations (find-logical-host host)))
1547 (defun (setf logical-pathname-translations) (translations host)
1549 "Set the translations list for the logical host argument.
1550 Return translations."
1551 (declare (type (or string logical-host) host)
1552 (type list translations)
1554 (let ((host (intern-logical-host host)))
1555 (setf (logical-host-canon-transls host)
1556 (canonicalize-logical-pathname-translations translations host))
1557 (setf (logical-host-translations host) translations)))
1559 (defun translate-logical-pathname (pathname &key)
1561 "Translates pathname to a physical pathname, which is returned."
1562 (declare (type pathname-designator pathname)
1563 (values (or null pathname)))
1566 (dolist (x (logical-host-canon-transls (%pathname-host pathname))
1567 (error 'simple-file-error
1569 :format-control "no translation for ~S"
1570 :format-arguments (list pathname)))
1571 (destructuring-bind (from to) x
1572 (when (pathname-match-p pathname from)
1573 (return (translate-logical-pathname
1574 (translate-pathname pathname from to)))))))
1576 (stream (translate-logical-pathname (pathname pathname)))
1577 (t (translate-logical-pathname (logical-pathname pathname)))))
1579 (defvar *logical-pathname-defaults*
1580 (%make-logical-pathname (make-logical-host :name "BOGUS")
1587 (defun load-logical-pathname-translations (host)
1589 (declare (type string host)
1590 (values (member t nil)))
1591 (if (find-logical-host host nil)
1592 ;; This host is already defined, all is well and good.
1594 ;; ANSI: "The specific nature of the search is
1595 ;; implementation-defined." SBCL: doesn't search at all
1596 (error "logical host ~S not found" host)))