X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-pathname.lisp;h=8c7d5e78b528063950a8d5665518d1120ea2b49a;hb=ad3beba970fab6e451a461c9f9b14faf4ef17718;hp=86d1f21525f6c9faf92e53c807f60cee2fdacfd1;hpb=e73a30c901ab234291aefc9f1e73507650628892;p=sbcl.git diff --git a/src/code/target-pathname.lisp b/src/code/target-pathname.lisp index 86d1f21..8c7d5e7 100644 --- a/src/code/target-pathname.lisp +++ b/src/code/target-pathname.lisp @@ -44,11 +44,11 @@ (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) @@ -202,12 +202,12 @@ (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. @@ -308,7 +308,7 @@ (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)))) @@ -319,7 +319,7 @@ (make-pattern (mapcar (lambda (piece) (typecase piece - (simple-base-string + (simple-string (funcall fun piece)) (cons (case (car piece) @@ -333,7 +333,7 @@ (pattern-pieces thing)))) (list (mapcar fun thing)) - (simple-base-string + (simple-string (funcall fun thing)) (t thing)))) @@ -692,7 +692,7 @@ a host-structure or string." :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 @@ -702,7 +702,7 @@ a host-structure or string." ;;; 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))) @@ -816,7 +816,7 @@ a host-structure or string." (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) @@ -924,7 +924,7 @@ a host-structure or string." (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)) @@ -937,7 +937,7 @@ a host-structure or string." (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 @@ -952,7 +952,7 @@ a host-structure or string." (push sub strings)) (t (error "can't substitute this into the middle of a word:~ - ~% ~S" + ~% ~S" sub))))))) (when strings @@ -969,7 +969,7 @@ a host-structure or string." ;;; 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 @@ -1082,14 +1082,14 @@ a host-structure or string." (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 @@ -1157,13 +1157,14 @@ a host-structure or string." (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. @@ -1213,7 +1214,7 @@ a host-structure or string." (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))) @@ -1257,7 +1258,7 @@ a host-structure or string." ;;; 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) @@ -1332,7 +1333,7 @@ a host-structure or string." (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)))) @@ -1418,7 +1419,7 @@ a host-structure or string." (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 ".") @@ -1524,12 +1525,9 @@ a host-structure or string." (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