0.8.16.16:
[sbcl.git] / src / code / target-pathname.lisp
index f8a688b..6848a57 100644 (file)
@@ -48,7 +48,7 @@
        (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)
 
 (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))))))
 \f
 ;;; A pathname is logical if the host component is a logical host.
 ;;; This constructor is used to make an instance of the correct type
@@ -97,7 +76,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.
   (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.
                          (%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.
            (,pathname (etypecase ,pd0
                         (pathname ,pd0)
                         (string (parse-namestring ,pd0))
-                        (stream (file-name ,pd0)))))
+                        (file-stream (file-name ,pd0)))))
        ,@body)))
 
 ;;; Convert the var, a host or string name for a host, into a
                              (simple-string
                               (check-for pred piece))
                              (cons
-                              (case (car in)
+                              (case (car piece)
                                 (:character-set
-                                 (check-for pred (cdr in))))))
+                                 (check-for pred (cdr piece))))))
                        (return t))))
                   (list
                    (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))))
                    (make-pattern
                     (mapcar (lambda (piece)
                               (typecase piece
-                                (simple-base-string
+                                (simple-string
                                  (funcall fun piece))
                                 (cons
                                  (case (car piece)
                             (pattern-pieces thing))))
                   (list
                    (mapcar fun thing))
-                  (simple-base-string
+                  (simple-string
                    (funcall fun thing))
                   (t
                    thing))))
                                              x)) thing))
                (any-lowers
                 ;; all lowercase, becomes all upper case
-                (diddle-with #'(lambda (x) (if (stringp x)
-                                               (string-upcase x)
-                                               x)) thing))
+                (diddle-with (lambda (x) (if (stringp x)
+                                             (string-upcase x)
+                                             x)) thing))
                (t
                 ;; no letters?  I guess just leave it.
                 thing))))
        (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))
             (maybe-diddle-case (%pathname-type defaults)
                                diddle-case))
         (or (%pathname-version pathname)
+            (and (not (%pathname-name pathname)) (%pathname-version defaults))
             default-version))))))
 
 (defun import-directory (directory diddle-case)
@@ -479,11 +463,11 @@ a host-structure or string."
         (default-host (if defaults
                           (%pathname-host defaults)
                           (pathname-host *default-pathname-defaults*)))
-        ;; toy@rtp.ericsson.se: CLHS says make-pathname can take a
+        ;; Raymond Toy writes: CLHS says make-pathname can take a
         ;; string (as a logical-host) for the host part. We map that
         ;; string into the corresponding logical host structure.
         ;;
-        ;; pw@snoopy.mv.com:
+        ;; Paul Werkowski writes:
         ;; HyperSpec says for the arg to MAKE-PATHNAME;
         ;; "host---a valid physical pathname host. ..."
         ;; where it probably means -- a valid pathname host.
@@ -499,6 +483,7 @@ a host-structure or string."
         ;; It seems an error message is appropriate.
         (host (typecase host
                 (host host)            ; A valid host, use it.
+                ((string 0) *unix-host*) ; "" cannot be a logical host
                 (string (find-logical-host host t)) ; logical-host or lose.
                 (t default-host)))     ; unix-host
         (diddle-args (and (eq (host-customary-case host) :lower)
@@ -605,6 +590,41 @@ a host-structure or string."
 \f
 ;;;; namestrings
 
+;;; Handle the case for PARSE-NAMESTRING parsing a potentially
+;;; syntactically valid logical namestring with an explicit host.
+;;;
+;;; This then isn't fully general -- we are relying on the fact that
+;;; we will only pass to parse-namestring namestring with an explicit
+;;; logical host, so that we can pass the host return from
+;;; parse-logical-namestring through to %PARSE-NAMESTRING as a truth
+;;; value. Yeah, this is probably a KLUDGE - CSR, 2002-04-18
+(defun parseable-logical-namestring-p (namestr start end)
+  (catch 'exit
+    (handler-bind
+       ((namestring-parse-error (lambda (c)
+                                  (declare (ignore c))
+                                  (throw 'exit nil))))
+      (let ((colon (position #\: namestr :start start :end end)))
+       (when colon
+         (let ((potential-host
+                (logical-word-or-lose (subseq namestr start colon))))
+           ;; depending on the outcome of CSR comp.lang.lisp post
+           ;; "can PARSE-NAMESTRING create logical hosts", we may need
+           ;; to do things with potential-host (create it
+           ;; temporarily, parse the namestring and unintern the
+           ;; logical host potential-host on failure.
+           (declare (ignore potential-host))
+           (let ((result
+                  (handler-bind
+                      ((simple-type-error (lambda (c)
+                                            (declare (ignore c))
+                                            (throw 'exit nil))))
+                    (parse-logical-namestring namestr start end))))
+             ;; if we got this far, we should have an explicit host
+             ;; (first return value of parse-logical-namestring)
+             (aver result)
+             result)))))))
+
 ;;; Handle the case where PARSE-NAMESTRING is actually parsing a
 ;;; namestring. We pick off the :JUNK-ALLOWED case then find a host to
 ;;; use for parsing, call the parser, then check whether the host matches.
@@ -613,45 +633,76 @@ a host-structure or string."
           (type string namestr)
           (type index start)
           (type (or index null) end))
-  (if junk-allowed
-      (handler-case
-         (%parse-namestring namestr host defaults start end nil)
-       (namestring-parse-error (condition)
-         (values nil (namestring-parse-error-offset condition))))
-      (let* ((end (or end (length namestr)))
-            (parse-host (or host
-                            (extract-logical-host-prefix namestr start end)
-                            (pathname-host defaults))))
-       (unless parse-host
-         (error "When no HOST argument is supplied, the DEFAULTS argument ~
-                 must have a non-null PATHNAME-HOST."))
-
-       (multiple-value-bind (new-host device directory file type version)
-           (funcall (host-parse parse-host) namestr start end)
-         (when (and host new-host (not (eq new-host host)))
-           (error 'simple-type-error
-                  :datum new-host
-                  ;; Note: ANSI requires that this be a TYPE-ERROR,
-                  ;; but there seems to be no completely correct
-                  ;; value to use for TYPE-ERROR-EXPECTED-TYPE.
-                  ;; Instead, we return a sort of "type error allowed
-                  ;; type", trying to say "it would be OK if you
-                  ;; passed NIL as the host value" but not mentioning
-                  ;; that a matching string would be OK too.
-                  :expected-type 'null
-                  :format-control
-                  "The host in the namestring, ~S,~@
-                   does not match the explicit HOST argument, ~S."
-                  :format-arguments (list new-host host)))
-         (let ((pn-host (or new-host parse-host)))
-           (values (%make-maybe-logical-pathname
-                    pn-host device directory file type version)
-                   end))))))
+  (cond
+    (junk-allowed
+     (handler-case
+        (%parse-namestring namestr host defaults start end nil)
+       (namestring-parse-error (condition)
+        (values nil (namestring-parse-error-offset condition)))))
+    (t
+     (let* ((end (%check-vector-sequence-bounds namestr start end)))
+       (multiple-value-bind (new-host device directory file type version)
+          ;; Comments below are quotes from the HyperSpec
+          ;; PARSE-NAMESTRING entry, reproduced here to demonstrate
+          ;; that we actually have to do things this way rather than
+          ;; some possibly more logical way. - CSR, 2002-04-18
+          (cond
+            ;; "If host is a logical host then thing is parsed as a
+            ;; logical pathname namestring on the host."
+            (host (funcall (host-parse host) namestr start end))
+            ;; "If host is nil and thing is a syntactically valid
+            ;; logical pathname namestring containing an explicit
+            ;; host, then it is parsed as a logical pathname
+            ;; namestring."
+            ((parseable-logical-namestring-p namestr start end)
+             (parse-logical-namestring namestr start end))
+            ;; "If host is nil, default-pathname is a logical
+            ;; pathname, and thing is a syntactically valid logical
+            ;; pathname namestring without an explicit host, then it
+            ;; is parsed as a logical pathname namestring on the
+            ;; host that is the host component of default-pathname."
+            ;;
+            ;; "Otherwise, the parsing of thing is
+            ;; implementation-defined."
+            ;;
+            ;; Both clauses are handled here, as the default
+            ;; *DEFAULT-PATHNAME-DEFAULTS has a SB-IMPL::UNIX-HOST
+            ;; for a host.
+            ((pathname-host defaults)
+             (funcall (host-parse (pathname-host defaults))
+                      namestr
+                      start
+                      end))
+            ;; I don't think we should ever get here, as the default
+            ;; host will always have a non-null HOST, given that we
+            ;; can't create a new pathname without going through
+            ;; *DEFAULT-PATHNAME-DEFAULTS*, which has a non-null
+            ;; host...
+            (t (bug "Fallen through COND in %PARSE-NAMESTRING")))
+        (when (and host new-host (not (eq new-host host)))
+          (error 'simple-type-error
+                 :datum new-host
+                 ;; Note: ANSI requires that this be a TYPE-ERROR,
+                 ;; but there seems to be no completely correct
+                 ;; value to use for TYPE-ERROR-EXPECTED-TYPE.
+                 ;; Instead, we return a sort of "type error allowed
+                 ;; type", trying to say "it would be OK if you
+                 ;; passed NIL as the host value" but not mentioning
+                 ;; that a matching string would be OK too.
+                 :expected-type 'null
+                 :format-control
+                 "The host in the namestring, ~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
+                   pn-host device directory file type version)
+                  end)))))))
 
 ;;; 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)))
@@ -665,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)
@@ -697,6 +747,12 @@ a host-structure or string."
   ;; A logical host is an object of implementation-dependent nature. In
   ;; SBCL, it's a member of the HOST class (a subclass of STRUCTURE-OBJECT).
   (let ((found-host (etypecase host
+                     ((string 0)
+                      ;; This is a special host. It's not valid as a
+                      ;; logical host, so it is a sensible thing to
+                      ;; designate the physical Unix host object. So
+                      ;; we do that.
+                      *unix-host*)
                      (string
                       ;; In general ANSI-compliant Common Lisps, a
                       ;; string might also be a physical pathname host,
@@ -718,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))
@@ -744,21 +810,19 @@ a host-structure or string."
 (defun namestring (pathname)
   #!+sb-doc
   "Construct the full (name)string form of the pathname."
-  (declare (type pathname-designator pathname)
-          (values (or null simple-base-string)))
+  (declare (type pathname-designator pathname))
   (with-pathname (pathname pathname)
     (when pathname
       (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)
   #!+sb-doc
   "Return a string representation of the name of the host in the pathname."
-  (declare (type pathname-designator pathname)
-          (values (or null simple-base-string)))
+  (declare (type pathname-designator pathname))
   (with-pathname (pathname pathname)
     (let ((host (%pathname-host pathname)))
       (if host
@@ -770,8 +834,7 @@ a host-structure or string."
 (defun directory-namestring (pathname)
   #!+sb-doc
   "Return a string representation of the directories used in the pathname."
-  (declare (type pathname-designator pathname)
-          (values (or null simple-base-string)))
+  (declare (type pathname-designator pathname))
   (with-pathname (pathname pathname)
     (let ((host (%pathname-host pathname)))
       (if host
@@ -783,8 +846,7 @@ a host-structure or string."
 (defun file-namestring (pathname)
   #!+sb-doc
   "Return a string representation of the name used in the pathname."
-  (declare (type pathname-designator pathname)
-          (values (or null simple-base-string)))
+  (declare (type pathname-designator pathname))
   (with-pathname (pathname pathname)
     (let ((host (%pathname-host pathname)))
       (if host
@@ -841,7 +903,7 @@ a host-structure or string."
   (declare (type pathname-designator in-pathname))
   (with-pathname (pathname in-pathname)
     (with-pathname (wildname in-wildname)
-      (macrolet ((frob (field &optional (op 'components-match ))
+      (macrolet ((frob (field &optional (op 'components-match))
                   `(or (null (,field wildname))
                        (,op (,field pathname) (,field wildname)))))
        (and (or (null (%pathname-host wildname))
@@ -850,7 +912,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,
@@ -861,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))
@@ -874,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
@@ -889,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
@@ -906,10 +969,11 @@ 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 and directory.
+;;; Do TRANSLATE-COMPONENT for all components except host, directory
+;;; and version.
 (defun translate-component (source from to diddle-case)
   (typecase to
     (pattern
@@ -1018,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
@@ -1046,6 +1110,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
@@ -1065,7 +1130,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)))))))))
 \f
 ;;;;  logical pathname support. ANSI 92-102 specification.
 ;;;;
@@ -1079,16 +1148,23 @@ a host-structure or string."
 ;;; contains only legal characters.
 (defun logical-word-or-lose (word)
   (declare (string word))
+  (when (string= word "")
+    (error 'namestring-parse-error
+          :complaint "Attempted to treat invalid logical hostname ~
+                       as a logical host:~%  ~S"
+          :args (list word)
+          :namestring word :offset 0))
   (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"
-                :arguments (list ch)
+                             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.
@@ -1138,8 +1214,8 @@ a host-structure or string."
                (when (pattern)
                  (error 'namestring-parse-error
                         :complaint "double asterisk inside of logical ~
-                                    word: ~S"
-                        :arguments (list chunk)
+                                     word: ~S"
+                        :args (list chunk)
                         :namestring namestring
                         :offset (+ (cdar chunks) pos)))
                (pattern (subseq chunk last-pos pos)))
@@ -1173,7 +1249,7 @@ a host-structure or string."
          (unless (member ch '(#\; #\: #\.))
            (error 'namestring-parse-error
                   :complaint "illegal character for logical pathname:~%  ~S"
-                  :arguments (list ch)
+                  :args (list ch)
                   :namestring namestr
                   :offset i))
          (chunks (cons ch i)))))
@@ -1182,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)
@@ -1193,7 +1269,7 @@ a host-structure or string."
                 (unless (and chunks (simple-string-p (caar chunks)))
                   (error 'namestring-parse-error
                          :complaint "expecting ~A, got ~:[nothing~;~S~]."
-                         :arguments (list what (caar chunks) (caar chunks))
+                         :args (list what (caar chunks) (caar chunks))
                          :namestring namestr
                          :offset (if chunks (cdar chunks) end)))
                 (caar chunks))
@@ -1235,7 +1311,7 @@ a host-structure or string."
                   (unless (eql (caar chunks) #\.)
                     (error 'namestring-parse-error
                            :complaint "expecting a dot, got ~S."
-                           :arguments (list (caar chunks))
+                           :args (list (caar chunks))
                            :namestring namestr
                            :offset (cdar chunks)))
                   (if type
@@ -1257,8 +1333,8 @@ a host-structure or string."
                       (unless (and res (plusp res))
                         (error 'namestring-parse-error
                                :complaint "expected a positive integer, ~
-                                           got ~S"
-                               :arguments (list str)
+                                            got ~S"
+                               :args (list str)
                                :namestring namestr
                                :offset (+ pos (cdar chunks))))
                       (setq version res)))))
@@ -1312,6 +1388,7 @@ a host-structure or string."
 
 (defun unparse-logical-piece (thing)
   (etypecase thing
+    ((member :wild) "*")
     (simple-string thing)
     (pattern
      (collect ((strings))
@@ -1326,6 +1403,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-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))
@@ -1350,18 +1457,19 @@ a host-structure or string."
                    ;; DEF-DIRECTORY is :ABSOLUTE, as handled above. so return
                    ;; the original directory.
                    path-directory))))
-    (make-pathname :host (pathname-host pathname)
-                   :directory enough-directory
-                   :name (pathname-name pathname)
-                   :type (pathname-type pathname)
-                   :version (pathname-version pathname))))
+    (unparse-logical-namestring
+     (make-pathname :host (pathname-host pathname)
+                    :directory enough-directory
+                    :name (pathname-name pathname)
+                    :type (pathname-type pathname)
+                    :version (pathname-version pathname)))))
 
 (defun unparse-logical-namestring (pathname)
   (declare (type logical-pathname pathname))
   (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
 
@@ -1397,15 +1505,9 @@ a host-structure or string."
          (canonicalize-logical-pathname-translations translations host))
     (setf (logical-host-translations host) translations)))
 
-;;; KLUDGE: Ordinarily known functions aren't defined recursively, and
-;;; it's common for compiler problems (e.g. missing/broken
-;;; optimization transforms) to cause them to recurse inadvertently,
-;;; so the compiler should warn about it. But the natural definition
-;;; of TRANSLATE-LOGICAL-PATHNAME *is* recursive; and we don't want
-;;; the warning, so we hide the definition of T-L-P in this
-;;; differently named function so that the compiler won't warn about
-;;; it. -- WHN 2001-09-16
-(defun %translate-logical-pathname (pathname)
+(defun translate-logical-pathname (pathname &key)
+  #!+sb-doc
+  "Translate PATHNAME to a physical pathname, which is returned."
   (declare (type pathname-designator pathname)
           (values (or null pathname)))
   (typecase pathname
@@ -1420,23 +1522,12 @@ a host-structure or string."
           (return (translate-logical-pathname
                    (translate-pathname pathname from to)))))))
     (pathname pathname)
-    (stream (translate-logical-pathname (pathname pathname)))
-    (t (translate-logical-pathname (logical-pathname pathname)))))
-
-(defun translate-logical-pathname (pathname &key)
-  #!+sb-doc
-  "Translate PATHNAME to a physical pathname, which is returned."
-  (declare (type pathname-designator pathname)
-          (values (or null pathname)))
-  (%translate-logical-pathname pathname))
+    (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
@@ -1444,7 +1535,10 @@ a host-structure or string."
           (values (member t nil)))
   (if (find-logical-host host nil)
       ;; This host is already defined, all is well and good.
-      t
+      nil
       ;; ANSI: "The specific nature of the search is
       ;; implementation-defined." SBCL: doesn't search at all
+      ;;
+      ;; FIXME: now that we have a SYS host that the system uses, it
+      ;; might be cute to search in "SYS:TRANSLATIONS;<name>.LISP"
       (error "logical host ~S not found" host)))