0.8.9.6.netbsd.2:

[sbcl.git] / src / code / target-pathname.lisp

diff --git a/src/code/target-pathname.lisp b/src/code/target-pathname.lisp
index fa8b426..28cfa41 100644 (file)
--- 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)
@@ -1399,6 +1399,7 @@ a host-structure or string."
 
 (defun unparse-logical-piece (thing)
   (etypecase thing
+    ((member :wild) "*")
     (simple-string thing)
     (pattern
      (collect ((strings))
@@ -1413,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))
@@ -1449,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)))
 \f
 ;;;; logical pathname translations