(let ((namestring (handler-case (namestring pathname)
(error nil))))
(if namestring
- (format stream "#P~S" namestring)
+ (format stream "#P~S" (coerce namestring '(simple-array character (*))))
(print-unreadable-object (pathname stream :type t)
(format stream
"~@<(with no namestring) ~_:HOST ~S ~_:DEVICE ~S ~_:DIRECTORY ~S ~
- ~_:NAME ~S ~_:TYPE ~S ~_:VERSION ~S~:>"
+ ~_:NAME ~S ~_:TYPE ~S ~_:VERSION ~S~:>"
(%pathname-host pathname)
(%pathname-device pathname)
(%pathname-directory pathname)
(or (eq thing wild)
(eq wild :wild)
(typecase thing
- (simple-base-string
+ (simple-string
;; String is matched by itself, a matching pattern or :WILD.
(typecase wild
(pattern
(values (pattern-matches wild thing)))
- (simple-base-string
+ (simple-string
(string= thing wild))))
(pattern
;; A pattern is only matched by an identical pattern.
(dolist (x in)
(when (check-for pred x)
(return t))))
- (simple-base-string
+ (simple-string
(dotimes (i (length in))
(when (funcall pred (schar in i))
(return t))))
(make-pattern
(mapcar (lambda (piece)
(typecase piece
- (simple-base-string
+ (simple-string
(funcall fun piece))
(cons
(case (car piece)
(pattern-pieces thing))))
(list
(mapcar fun thing))
- (simple-base-string
+ (simple-string
(funcall fun thing))
(t
thing))))
:expected-type 'null
:format-control
"The host in the namestring, ~S,~@
- does not match the explicit HOST argument, ~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
;;; 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)
+ (declare (type simple-string namestr)
(type index start end)
(values (or logical-host null)))
(let ((colon-pos (position #\: namestr :start start :end end)))
host
(defaults *default-pathname-defaults*)
&key (start 0) end junk-allowed)
- (declare (type pathname-designator thing)
+ (declare (type pathname-designator thing defaults)
(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)
supported in this implementation:~% ~S"
host))
(host
- host))))
- (declare (type (or null host) found-host))
+ host)))
+ ;; 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 (or null host) found-host)
+ (type pathname defaults))
(etypecase thing
(simple-string
(%parse-namestring thing found-host defaults start end junk-allowed))
(let ((host (%pathname-host pathname)))
(unless host
(error "can't determine the namestring for pathnames with no ~
- host:~% ~S" pathname))
+ host:~% ~S" pathname))
(funcall (host-unparse host) pathname)))))
(defun host-namestring (pathname)
(defun substitute-into (pattern subs diddle-case)
(declare (type pattern pattern)
(type list subs)
- (values (or simple-base-string pattern) list))
+ (values (or simple-string pattern) list))
(let ((in-wildcard nil)
(pieces nil)
(strings nil))
(setf in-wildcard t)
(unless subs
(error "not enough wildcards in FROM pattern to match ~
- TO pattern:~% ~S"
+ TO pattern:~% ~S"
pattern))
(let ((sub (pop subs)))
(typecase sub
(push sub strings))
(t
(error "can't substitute this into the middle of a word:~
- ~% ~S"
+ ~% ~S"
sub)))))))
(when strings
;;; Called when we can't see how source and from matched.
(defun didnt-match-error (source from)
(error "Pathname components from SOURCE and FROM args to TRANSLATE-PATHNAME~@
- did not match:~% ~S ~S"
+ did not match:~% ~S ~S"
source from))
;;; Do TRANSLATE-COMPONENT for all components except host, directory
(let ((match (pop subs-left)))
(when (listp match)
(error ":WILD-INFERIORS is not paired in from and to ~
- patterns:~% ~S ~S" from to))
+ patterns:~% ~S ~S" from to))
(res (maybe-diddle-case match diddle-case))))
((member :wild-inferiors)
(aver subs-left)
(let ((match (pop subs-left)))
(unless (listp match)
(error ":WILD-INFERIORS not paired in from and to ~
- patterns:~% ~S ~S" from to))
+ patterns:~% ~S ~S" from to))
(dolist (x match)
(res (maybe-diddle-case x diddle-case)))))
(pattern
(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 #\-))
+ (unless (and (typep ch 'standard-char)
+ (or (alpha-char-p ch) (digit-char-p ch) (char= ch #\-)))
(error 'namestring-parse-error
:complaint "logical namestring character which ~
- is not alphanumeric or hyphen:~% ~S"
+ is not alphanumeric or hyphen:~% ~S"
:args (list ch)
:namestring word :offset i))))
- word))
+ (coerce word 'base-string)))
;;; Given a logical host or string, return a logical host. If ERROR-P
;;; is NIL, then return NIL when no such host exists.
(when (pattern)
(error 'namestring-parse-error
:complaint "double asterisk inside of logical ~
- word: ~S"
+ word: ~S"
:args (list chunk)
:namestring namestring
:offset (+ (cdar chunks) pos)))
;;; 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)
+ (declare (type simple-string namestr)
(type index start end))
(collect ((directory))
(let ((host nil)
(unless (and res (plusp res))
(error 'namestring-parse-error
:complaint "expected a positive integer, ~
- got ~S"
+ got ~S"
:args (list str)
:namestring namestr
:offset (+ pos (cdar chunks))))
(when type-supplied
(unless name
(error "cannot specify the type without a file: ~S" pathname))
- (when (typep type 'simple-base-string)
+ (when (typep type 'simple-string)
(when (position #\. type)
(error "type component can't have a #\. inside: ~S" pathname)))
(strings ".")
(t (translate-logical-pathname (pathname pathname)))))
(defvar *logical-pathname-defaults*
- (%make-logical-pathname (make-logical-host :name "BOGUS")
- :unspecific
- nil
- nil
- nil
- nil))
+ (%make-logical-pathname
+ (make-logical-host :name (logical-word-or-lose "BOGUS"))
+ :unspecific nil nil nil nil))
(defun load-logical-pathname-translations (host)
#!+sb-doc
projects / sbcl.git / blobdiff