X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-pathname.lisp;h=86d1f21525f6c9faf92e53c807f60cee2fdacfd1;hb=6f7128b46e9ca91de777f61e8623bf5d997b2987;hp=fa8b42662d9df3581fb5fb9e69198fa8877752d5;hpb=696e38f7210c587ba0b54795f4795f58e62fed2d;p=sbcl.git

diff --git a/src/code/target-pathname.lisp b/src/code/target-pathname.lisp
index fa8b426..86d1f21 100644
--- a/src/code/target-pathname.lisp
+++ b/src/code/target-pathname.lisp
@@ -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 namestring
-	(format stream "#.(CL:LOGICAL-PATHNAME ~S)" namestring)
-	(print-unreadable-object (pathname stream :type t)
-	  (format
-	   stream
-	   "~_:HOST ~S ~_:DIRECTORY ~S ~_:FILE ~S ~_:NAME ~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
@@ -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))
@@ -1399,6 +1387,7 @@ a host-structure or string."
 
 (defun unparse-logical-piece (thing)
   (etypecase thing
+    ((member :wild) "*")
     (simple-string thing)
     (pattern
      (collect ((strings))
@@ -1413,6 +1402,36 @@ a host-structure or string."
 		  (t (error "invalid keyword: ~S" piece))))))
        (apply #'concatenate 'simple-string (strings))))))
 
+(defun unparse-logical-file (pathname)
+  (declare (type pathname pathname))
+    (collect ((strings))
+    (let* ((name (%pathname-name pathname))
+	   (type (%pathname-type pathname))
+	   (version (%pathname-version pathname))
+	   (type-supplied (not (or (null type) (eq type :unspecific))))
+	   (version-supplied (not (or (null version)
+				      (eq version :unspecific)))))
+      (when name
+	(when (and (null type) (position #\. name :start 1))
+	  (error "too many dots in the name: ~S" pathname))
+	(strings (unparse-logical-piece name)))
+      (when type-supplied
+	(unless name
+	  (error "cannot specify the type without a file: ~S" pathname))
+	(when (typep type 'simple-base-string)
+	  (when (position #\. type)
+	    (error "type component can't have a #\. inside: ~S" pathname)))
+	(strings ".")
+	(strings (unparse-logical-piece type)))
+      (when version-supplied
+	(unless type-supplied
+	  (error "cannot specify the version without a type: ~S" pathname))
+	(etypecase version
+	  ((member :newest) (strings ".NEWEST"))
+	  ((member :wild) (strings ".*"))
+	  (fixnum (strings ".") (strings (format nil "~D" version))))))
+    (apply #'concatenate 'simple-string (strings))))
+
 ;;; Unparse a logical pathname string.
 (defun unparse-enough-namestring (pathname defaults)
   (let* ((path-directory (pathname-directory pathname))
@@ -1449,7 +1468,7 @@ a host-structure or string."
   (concatenate 'simple-string
 	       (logical-host-name (%pathname-host pathname)) ":"
 	       (unparse-logical-directory pathname)
-	       (unparse-unix-file pathname)))
+	       (unparse-logical-file pathname)))
 
 ;;;; logical pathname translations