X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-pathname.lisp;h=28cfa41a1e8bd7a3504d754899a2cef8c63b2b63;hb=cd13034f9415f64cdaa05893a4ac5ff1e95c97bd;hp=542432aafe85d4e1b625f5e202f1b2f421e5624a;hpb=bd246f3f982b002260bad55588acd410b96059ba;p=sbcl.git

diff --git a/src/code/target-pathname.lisp b/src/code/target-pathname.lisp
index 542432a..28cfa41 100644
--- a/src/code/target-pathname.lisp
+++ b/src/code/target-pathname.lisp
@@ -68,12 +68,12 @@
 (def!method print-object ((pathname logical-pathname) stream)
   (let ((namestring (handler-case (namestring pathname)
 		      (error nil))))
-    (if namestring
+    (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 ~_:FILE ~S ~_:NAME ~S ~_:VERSION ~S"
+	   "~_:HOST ~S ~_:DIRECTORY ~S ~_:NAME ~S ~_:TYPE ~S ~_:VERSION ~S"
 	   (%pathname-host pathname)
 	   (%pathname-directory pathname)
 	   (%pathname-name pathname)
@@ -97,7 +97,9 @@
 				(upcase-maybe name)
 				(upcase-maybe type)
 				version)
-	(%make-pathname host device directory name type version))))
+	(progn
+	  (aver (eq host *unix-host*))
+	  (%make-pathname host device directory name type version)))))
 
 ;;; Hash table searching maps a logical pathname's host to its
 ;;; physical pathname translation.
@@ -267,8 +269,9 @@
 			  (%pathname-name pathname2))
        (compare-component (%pathname-type pathname1)
 			  (%pathname-type pathname2))
-       (compare-component (%pathname-version pathname1)
-			  (%pathname-version pathname2))))
+       (or (eq (%pathname-host pathname1) *unix-host*)
+	   (compare-component (%pathname-version pathname1)
+			      (%pathname-version pathname2)))))
 
 ;;; Convert PATHNAME-DESIGNATOR (a pathname, or string, or
 ;;; stream), into a pathname in pathname.
@@ -383,7 +386,8 @@
 	(flet ((add (dir)
 		 (if (and (eq dir :back)
 			  results
-			  (not (eq (car results) :back)))
+			  (not (member (car results)
+				       '(:back :wild-inferiors))))
 		     (pop results)
 		     (push dir results))))
 	  (dolist (dir (maybe-diddle-case dir2 diddle-case))
@@ -920,7 +924,8 @@ a host-structure or string."
 	     (frob %pathname-directory directory-components-match)
 	     (frob %pathname-name)
 	     (frob %pathname-type)
-	     (frob %pathname-version))))))
+	     (or (eq (%pathname-host wildname) *unix-host*)
+		 (frob %pathname-version)))))))
 
 ;;; Place the substitutions into the pattern and return the string or pattern
 ;;; that results. If DIDDLE-CASE is true, we diddle the result case as well,
@@ -979,7 +984,8 @@ a host-structure or string."
 	  did not match:~%  ~S ~S"
 	 source from))
 
-;;; Do TRANSLATE-COMPONENT for all components except host and directory.
+;;; Do TRANSLATE-COMPONENT for all components except host, directory
+;;; and version.
 (defun translate-component (source from to diddle-case)
   (typecase to
     (pattern
@@ -1116,6 +1122,7 @@ a host-structure or string."
     (with-pathname (from from-wildname)
       (with-pathname (to to-wildname)
 	  (let* ((source-host (%pathname-host source))
+		 (from-host (%pathname-host from))
 		 (to-host (%pathname-host to))
 		 (diddle-case
 		  (and source-host to-host
@@ -1135,7 +1142,11 @@ a host-structure or string."
 	       (frob %pathname-directory translate-directories)
 	       (frob %pathname-name)
 	       (frob %pathname-type)
-	       (frob %pathname-version))))))))
+	       (if (eq from-host *unix-host*)
+		   (if (eq (%pathname-version to) :wild)
+		       (%pathname-version from)
+		       (%pathname-version to))
+		   (frob %pathname-version)))))))))
 
 ;;;;  logical pathname support. ANSI 92-102 specification.
 ;;;;
@@ -1388,6 +1399,7 @@ a host-structure or string."
 
 (defun unparse-logical-piece (thing)
   (etypecase thing
+    ((member :wild) "*")
     (simple-string thing)
     (pattern
      (collect ((strings))
@@ -1402,6 +1414,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))
@@ -1438,7 +1480,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