- &optional
- host
- (defaults *default-pathname-defaults*)
- &key (start 0) end junk-allowed)
- (declare (type pathname-designator thing)
- (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)))
- ;; 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 found-host defaults start end junk-allowed))
- (string
- (%parse-namestring (coerce thing 'simple-string)
- found-host defaults start end junk-allowed))
- (pathname
- (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"
- thing))
- (values name nil))))))
+ &optional
+ host
+ (defaults *default-pathname-defaults*)
+ &key (start 0) end junk-allowed)
+ (declare (type pathname-designator thing defaults)
+ (type (or list host string (member :unspecific)) host)
+ (type index start)
+ (type (or index null) end)
+ (type (or t null) junk-allowed)
+ (values (or null pathname) (or null index)))
+ (with-host (found-host host)
+ (let (;; According to ANSI defaults may be any valid pathname designator
+ (defaults (etypecase defaults
+ (pathname
+ defaults)
+ (string
+ (aver (pathnamep *default-pathname-defaults*))
+ (parse-namestring defaults))
+ (stream
+ (truename defaults)))))
+ (declare (type pathname defaults))
+ (etypecase thing
+ (simple-string
+ (%parse-namestring thing found-host defaults start end junk-allowed))
+ (string
+ (%parse-namestring (coerce thing 'simple-string)
+ found-host defaults start end junk-allowed))
+ (pathname
+ (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"
+ thing))
+ (values name nil)))))))
+
+(defun %parse-native-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))
+ (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)
+ (cond
+ (host (funcall (host-parse-native host) namestr start end))
+ ((pathname-host defaults)
+ (funcall (host-parse-native (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
+ :expected-type `(or null (eql ,host))
+ :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-pathname
+ pn-host device directory file type version)
+ end)))))))
+
+(defun parse-native-namestring (thing
+ &optional
+ host
+ (defaults *default-pathname-defaults*)
+ &key (start 0) end junk-allowed)
+ #!+sb-doc
+ "Convert THING into a pathname, using the native conventions
+appropriate for the pathname host HOST, or if not specified the host
+of DEFAULTS. If THING is a string, the parse is bounded by START and
+END, and error behaviour is controlled by JUNK-ALLOWED, as with
+PARSE-NAMESTRING."
+ (declare (type pathname-designator thing defaults)
+ (type (or list host string (member :unspecific)) host)
+ (type index start)
+ (type (or index null) end)
+ (type (or t null) junk-allowed)
+ (values (or null pathname) (or null index)))
+ (with-host (found-host host)
+ (let ((defaults (etypecase defaults
+ (pathname
+ defaults)
+ (string
+ (aver (pathnamep *default-pathname-defaults*))
+ (parse-native-namestring defaults))
+ (stream
+ (truename defaults)))))
+ (declare (type pathname defaults))
+ (etypecase thing
+ (simple-string
+ (%parse-native-namestring
+ thing found-host defaults start end junk-allowed))
+ (string
+ (%parse-native-namestring (coerce thing 'simple-string)
+ found-host defaults start end junk-allowed))
+ (pathname
+ (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
+ ;; FIXME
+ (let ((name (file-name thing)))
+ (unless name
+ (error "can't figure out the file associated with stream:~% ~S"
+ thing))
+ (values name nil)))))))