X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-pathname.lisp;h=8c7d5e78b528063950a8d5665518d1120ea2b49a;hb=ad3beba970fab6e451a461c9f9b14faf4ef17718;hp=28cfa41a1e8bd7a3504d754899a2cef8c63b2b63;hpb=240b0db303764545c982e9362a986243b535f7f4;p=sbcl.git

diff --git a/src/code/target-pathname.lisp b/src/code/target-pathname.lisp
index 28cfa41..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)
@@ -58,27 +58,6 @@
 
 (def!method make-load-form ((pathname pathname) &optional environment)
   (make-load-form-saving-slots pathname :environment environment))
-
-;;; The potential conflict with search lists requires isolating the
-;;; printed representation to use the i/o macro #.(logical-pathname
-;;; <path-designator>).
-;;;
-;;; FIXME: We don't use search lists any more, so that comment is
-;;; stale, right?
-(def!method print-object ((pathname logical-pathname) stream)
-  (let ((namestring (handler-case (namestring pathname)
-		      (error nil))))
-    (if (and namestring (or *read-eval* (not *print-readably*)))
-	(format stream "#.(CL:LOGICAL-PATHNAME ~S)" namestring)
-	(print-unreadable-object (pathname stream :type t)
-	  (format
-	   stream
-	   "~_:HOST ~S ~_:DIRECTORY ~S ~_:NAME ~S ~_:TYPE ~S ~_:VERSION ~S"
-	   (%pathname-host pathname)
-	   (%pathname-directory pathname)
-	   (%pathname-name pathname)
-	   (%pathname-type pathname)
-	   (%pathname-version pathname))))))
 
 ;;; A pathname is logical if the host component is a logical host.
 ;;; This constructor is used to make an instance of the correct type
@@ -223,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.
@@ -329,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))))
@@ -340,7 +319,7 @@
 		    (make-pattern
 		     (mapcar (lambda (piece)
 			       (typecase piece
-				 (simple-base-string
+				 (simple-string
 				  (funcall fun piece))
 				 (cons
 				  (case (car piece)
@@ -354,7 +333,7 @@
 			     (pattern-pieces thing))))
 		   (list
 		    (mapcar fun thing))
-		   (simple-base-string
+		   (simple-string
 		    (funcall fun thing))
 		   (t
 		    thing))))
@@ -713,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
@@ -723,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)))
@@ -737,9 +716,8 @@ a host-structure or string."
 			 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)
@@ -796,8 +774,18 @@ a host-structure or string."
                               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))
@@ -828,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)
@@ -936,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))
@@ -949,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
@@ -964,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
@@ -981,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
@@ -1094,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
@@ -1169,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.
@@ -1225,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)))
@@ -1269,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)
@@ -1344,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))))
@@ -1430,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 ".")
@@ -1536,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