(,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)
(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
+ ;; "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.
(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))))
- (multiple-value-bind (new-host device directory file type version)
- ;; 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
- ;; 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,~@
+ (cond
+ (junk-allowed
+ (handler-case
+ (%parse-namestring namestr host defaults start end nil)
+ (namestring-parse-error (condition)
+ (values nil (namestring-parse-error-offset condition)))))
+ (t
+ (let* ((end (%check-vector-sequence-bounds namestr start end)))
+ (multiple-value-bind (new-host device directory file type version)
+ ;; 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
+ ;; 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))))))
+ :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.
(defun namestring (pathname)
#!+sb-doc
"Construct the full (name)string form of the pathname."
- (declare (type pathname-designator pathname)
- (values (or null simple-base-string)))
+ (declare (type pathname-designator pathname))
(with-pathname (pathname pathname)
(when pathname
(let ((host (%pathname-host pathname)))
(defun host-namestring (pathname)
#!+sb-doc
"Return a string representation of the name of the host in the pathname."
- (declare (type pathname-designator pathname)
- (values (or null simple-base-string)))
+ (declare (type pathname-designator pathname))
(with-pathname (pathname pathname)
(let ((host (%pathname-host pathname)))
(if host
(defun directory-namestring (pathname)
#!+sb-doc
"Return a string representation of the directories used in the pathname."
- (declare (type pathname-designator pathname)
- (values (or null simple-base-string)))
+ (declare (type pathname-designator pathname))
(with-pathname (pathname pathname)
(let ((host (%pathname-host pathname)))
(if host
(defun file-namestring (pathname)
#!+sb-doc
"Return a string representation of the name used in the pathname."
- (declare (type pathname-designator pathname)
- (values (or null simple-base-string)))
+ (declare (type pathname-designator pathname))
(with-pathname (pathname pathname)
(let ((host (%pathname-host pathname)))
(if 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))
;; 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))))
+ (unparse-logical-namestring
+ (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))
(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