(,pathname (etypecase ,pd0
(pathname ,pd0)
(string (parse-namestring ,pd0))
- (stream (file-name ,pd0)))))
+ (file-stream (file-name ,pd0)))))
,@body)))
;;; Convert the var, a host or string name for a host, into a
(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)
(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.
;; 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)
\f
;;;; namestrings
+;;; 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.
(%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 no HOST argument is supplied, the DEFAULTS argument ~
- 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 'simple-type-error
:datum new-host
"The host in the namestring, ~S,~@
does not match the explicit HOST argument, ~S."
:format-arguments (list new-host host)))
- (let ((pn-host (or new-host parse-host)))
+ (let ((pn-host (or new-host host (pathname-host defaults))))
(values (%make-maybe-logical-pathname
pn-host device directory file type version)
end))))))
;; 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,
(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))
;;; 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)))
(canonicalize-logical-pathname-translations translations host))
(setf (logical-host-translations host) translations)))
-;;; KLUDGE: Ordinarily known functions aren't defined recursively, and
-;;; it's common for compiler problems (e.g. missing/broken
-;;; optimization transforms) to cause them to recurse inadvertently,
-;;; so the compiler should warn about it. But the natural definition
-;;; of TRANSLATE-LOGICAL-PATHNAME *is* recursive; and we don't want
-;;; the warning, so we hide the definition of T-L-P in this
-;;; differently named function so that the compiler won't warn about
-;;; it. -- WHN 2001-09-16
-(defun %translate-logical-pathname (pathname)
+(defun translate-logical-pathname (pathname &key)
+ #!+sb-doc
+ "Translate PATHNAME to a physical pathname, which is returned."
(declare (type pathname-designator pathname)
(values (or null pathname)))
(typecase pathname
(return (translate-logical-pathname
(translate-pathname pathname from to)))))))
(pathname pathname)
- (stream (translate-logical-pathname (pathname pathname)))
- (t (translate-logical-pathname (logical-pathname pathname)))))
-
-(defun translate-logical-pathname (pathname &key)
- #!+sb-doc
- "Translate PATHNAME to a physical pathname, which is returned."
- (declare (type pathname-designator pathname)
- (values (or null pathname)))
- (%translate-logical-pathname pathname))
+ (t (translate-logical-pathname (pathname pathname)))))
(defvar *logical-pathname-defaults*
(%make-logical-pathname (make-logical-host :name "BOGUS")
projects / sbcl.git / blobdiff