From b672560b60bc440d097b4abeb56694ea658a74a2 Mon Sep 17 00:00:00 2001
From: phg <phg>
Date: Thu, 15 Jul 1993 18:02:46 +0000
Subject: [PATCH] Logical pathnames for UNIX filesystems have been added. Note
 that logical- namestrings must consist of capital letters, numbers and
 hyphens, according to the ANSI specification, and not including lower case
 letters as listed in some of the examples in the specification.

---
 code/filesys.lisp  |    4 +-
 code/pathname.lisp | 1494 +++++++++++++++++++++++++++-----------------
 2 files changed, 932 insertions(+), 566 deletions(-)

diff --git a/code/filesys.lisp b/code/filesys.lisp
index 8d2ce8524..56afdcc2d 100644
--- a/code/filesys.lisp
+++ b/code/filesys.lisp
@@ -6,7 +6,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/filesys.lisp,v 1.29 1992/09/04 15:22:16 phg Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/filesys.lisp,v 1.30 1993/07/15 17:59:50 phg Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -717,11 +717,13 @@
 ;;;
 ;;;    Return Home:, which is set up for us at initialization time.
 ;;;
+#|
 (defun user-homedir-pathname (&optional host)
   "Returns the home directory of the logged in user as a pathname.
   This is obtained from the logical name \"home:\"."
   (declare (ignore host))
   #p"home:")
+|#
 
 ;;; File-Write-Date  --  Public
 ;;;
diff --git a/code/pathname.lisp b/code/pathname.lisp
index 6a24dbbc8..10afbff36 100644
--- a/code/pathname.lisp
+++ b/code/pathname.lisp
@@ -6,7 +6,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pathname.lisp,v 1.15 1992/09/04 15:17:24 phg Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pathname.lisp,v 1.16 1993/07/15 18:02:46 phg Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -36,9 +36,43 @@
 (in-package "LISP")
 
 
-;;;; Structures and types.
+;;;; HOST structures
 
-;;; Pathname structure holds the essential properties of the parsed path.
+;;;   The host structure holds the functions that both parse the pathname
+;;; information into sturcture slot entries, and after translation the inverse
+;;; (unparse) functions.
+;;;
+(defstruct (host
+	    (:print-function %print-host))
+  (parse (required-argument) :type function)
+  (unparse (required-argument) :type function)
+  (unparse-host (required-argument) :type function)
+  (unparse-directory (required-argument) :type function)
+  (unparse-file (required-argument) :type function)
+  (unparse-enough (required-argument) :type function)
+  (customary-case (required-argument) :type (member :upper :lower)))
+
+;;; %PRINT-HOST -- Internal
+;;;
+(defun %print-host (host stream depth)
+  (declare (ignore depth))
+  (print-unreadable-object (host stream :type t :identity t)))
+
+(defstruct (logical-host
+	    (:include host
+		      (:parse #'parse-logical-namestring)
+		      (:unparse #'unparse-logical-namestring)
+		      (:unparse-host #'unparse-logical-host)
+		      (:unparse-directory #'unparse-logical-directory)
+		      (:unparse-file #'unparse-logical-file)
+		      (:unparse-enough #'identity)
+		      (:customary-case :upper)))
+  (name "" :type simple-base-string)
+  (translations nil :type list)
+  (canon-transls nil :type list))
+
+
+;;;; Pathname structures
 
 (defstruct (pathname
 	    (:conc-name %pathname-)
@@ -50,13 +84,13 @@
   ;; Slot holds the host, at present either a UNIX or logical host.
   (host nil :type (or host null))
   ;; Device is the name of a logical or physical device holding files.
-  (device nil :type (member nil :unspecific))
+  (device nil :type (or null (member :unspecific)))
   ;; A list of strings that are the component subdirectory components.
   (directory nil :type list)
   ;; The filename.
-  (name nil :type (or simple-string pattern null))
+  (name nil :type (or simple-string pattern null (member :wild)))
   ;; The type extension of the file.
-  (type nil :type (or simple-string pattern null (member :unspecific)))
+  (type nil :type (or simple-string pattern null (member :wild :unspecific)))
   ;; The version number of the file, a positive integer, but not supported
   ;; on standard UNIX filesystems.
   (version nil :type (or integer null (member :newest :wild))))
@@ -97,27 +131,86 @@
 		    (%pathname-type pathname)
 		    (%pathname-version pathname))))))
 
-;;;; HOST structure
-
-;;;   The host structure holds the functions that both parse the pathname
-;;; information into sturcture slot entries, and after translation the inverse
-;;; (unparse) functions.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;
-(defstruct (host
-	    (:print-function %print-host))
-  (parse (required-argument) :type function)
-  (unparse (required-argument) :type function)
-  (unparse-host (required-argument) :type function)
-  (unparse-directory (required-argument) :type function)
-  (unparse-file (required-argument) :type function)
-  (unparse-enough (required-argument) :type function)
-  (customary-case (required-argument) :type (member :upper :lower)))
+;;; Logical pathnames have the following format:
+;;;
+;;; logical-namestring ::=
+;;;         [host ":"] [";"] {directory ";"}* [name] ["." type ["." version]]
+;;;
+;;; host ::= word
+;;; directory ::= word | wildcard-word | **
+;;; name ::= word | wildcard-word
+;;; type ::= word | wildcard-word
+;;; version ::= pos-int | newest | NEWEST | *
+;;; word ::= {uppercase-letter | digit | -}+
+;;; wildcard-word ::= [word] '* {word '*}* [word]
+;;; pos-int ::= integer > 0
+;;;
+;;; Physical pathnames include all these slots and a device slot.
+;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-;;; %PRINT-HOST -- Internal
+;; Logical pathnames are a subclass of pathname, their class relations are
+;; mimiced using structures for efficency.
+
+(defstruct (logical-pathname
+	    (:conc-name %logical-pathname-)
+	    (:print-function %print-logical-pathname)
+	    (:include pathname)
+	    (:constructor
+	     %make-logical-pathname (host device directory name type version))
+	    (:predicate logical-pathname-p)
+	    (:make-load-form-fun :just-dump-it-normally)))
+
+;;; %PRINT-LOGICAL-PATHNAME -- Internal
 ;;;
-(defun %print-host (host stream depth)
+;;;   The printed representation of the logical-pathname structure.
+;;; The potential conflict with search-lists requires isolating the printed
+;;; representation to use the i/o macro #.(logical-pathname <path-designator>).
+;;;
+(defun %print-logical-pathname (pathname stream depth)
   (declare (ignore depth))
-  (print-unreadable-object (host stream :type t :identity t)))
+  (let ((namestring (handler-case (namestring pathname)
+		      (error nil))))
+    (cond (namestring
+	   (format stream "#.(logical-pathname ~S)" namestring))
+	  (*print-readably*
+	   (error "~S Cannot be printed readably." pathname))
+	  (*print-pretty*
+	   (pprint-logical-block (stream nil :prefix "#<" :suffix ">")
+	     (funcall (formatter
+		       "~2IUnprintable pathname: ~_Host=~S, ~_~
+			Directory=~:/LISP:PPRINT-FILL/, ~_Name=~S, ~_~
+			Type=~S, ~_Version=~S")
+		      stream
+		      (%pathname-host pathname)
+		      (%pathname-directory pathname)
+		      (%pathname-name pathname)
+		      (%pathname-type pathname)
+		      (%pathname-version pathname))))
+	  (t
+	   (funcall (formatter "#<Unprintable pathname, Host=~S,  ~
+				Directory=~S, File=~S, Name=~S, Version=~S>")
+		    stream
+		    (%pathname-host pathname)
+		    (%pathname-directory pathname)
+		    (%pathname-name pathname)
+		    (%pathname-type pathname)
+		    (%pathname-version pathname))))))
+
+;;; *LOGICAL-HOSTS* --internal.
+;;;
+;;; Hash table searching maps a logical-pathname's host to their physical
+;;; pathname translation.
+
+(defvar *logical-hosts* (make-hash-table :test #'equal))
+
+;;; PATHSPEC -- internal type
+;;;
+(deftype path-designator ()
+  "A path specification, either a string, stream or pathname."
+  '(or simple-base-string stream pathname))
 
 
 ;;;; Patterns
@@ -164,6 +257,9 @@
 
 ;;; PATTERN-MATCHES -- Internal
 ;;;
+;;;   If the string matches the pattern returns the multiple valuse T and a
+;;; list of the matched strings.
+;;;
 (defun pattern-matches (pattern string)
   (declare (type pattern pattern)
 	   (type simple-string string))
@@ -204,7 +300,7 @@
 			(and (< start len)
 			     (matches (cdr pieces) (1+ start) subs t
 				      (cons (schar string start) chars))))
-		       ((member :multi-char-wild)
+		       ((member :wild :multi-char-wild)
 			(multiple-value-bind
 			    (won new-subs)
 			    (matches (cdr pieces) start subs t chars)
@@ -219,32 +315,138 @@
 	  (matches (pattern-pieces pattern) 0 nil nil nil)
 	(values won (reverse subs))))))
 
+;;; VERIFY-WORD-CHAR-P -- Internal
+;;;
+(defun verify-word-char-p (ch)
+  (if (or (eq ch #\-)
+	  (and (char<= #\A ch) (char<= ch #\Z))
+	  (and (char<= #\0 ch) (char<= ch #\9)))
+      t
+      nil))
+
+(defun verify-wild-word-char-p (ch)
+  (if (or (and (char<= #\A ch) (char<= ch #\Z))
+	  (and (char<= #\0 ch) (char<= ch #\9)))
+      t
+      nil))
+
+;;; VERIFY-WORD-P -- Internal
+;;;
+(defun verify-word-p (wd)
+  (declare (type simple-base-string wd))
+  (let ((ch nil))
+    (dotimes (j (length wd))
+      (setf ch (schar wd j))
+      (unless (verify-word-char-p ch)
+	(error "~S is not a wildcard word, it contains an illegal character ~
+		~S" wd ch))))
+  t)
+
+;;; HOSTS-MATCH-P -- Internal
+;;;
+;;;   Predicate for host matching.  No :wild hosts permitted.
+;;;
+(defun hosts-match-p (from-host to-host)
+  (declare (type (or host simple-base-string) from-host to-host))
+  (typecase from-host
+    (logical-host ; Subclass on logical-host first.
+     (typecase to-host
+       (logical-host
+	(eq from-host to-host))
+       (host
+	nil)
+       (simple-base-string
+	(eq from-host (gethash (string-upcase to-host) *logical-hosts*)))))
+    (host
+     (typecase to-host
+       (logical-host
+	nil)
+       (host
+	(eq from-host to-host))
+       (simple-base-string
+	(eq from-host (gethash (string-upcase to-host) *logical-hosts*)))))
+    (simple-base-string
+     (verify-word-p from-host)
+     (typecase to-host
+       (logical-host
+	(eq to-host (gethash (string-upcase from-host) *logical-hosts*)))
+       (simple-base-string
+	(verify-word-p to-host)
+	(string-equal from-host to-host))))))
+
+;;; WILDCARD-WORD-PARSE -- Internal
+;;;
+;;;   Parse a potential wildcard-word for its subcomponents as a pattern,
+;;; and return an error if the syntax is inconsistent.
+;;;
+(defun wildcard-word-parse (wd)
+  (declare (type simple-base-string wd)
+	   (values (or simple-base-string pattern)))
+  (let* ((c nil)
+	 (*-p (position #\* wd))
+	 (start 0)
+	 (end (length wd))
+	 (end-1 (1- end))
+	 (piece nil)
+	 (pat nil))
+    (when (and (not *-p) (verify-word-p wd))
+      (return-from wildcard-word-parse wd))
+    (dotimes (j end)
+      (setf c (schar wd j))
+     (when (eq c #\*)
+	;; Finish the preceeding word, place in pattern.
+	(setf piece (subseq wd start j))
+	(when (< 0 (length piece))
+	  (push piece pat))
+	(push :wild pat)
+	(setf *-p t
+	      start (1+ j))
+	(when (and (< j end-1) (eq (schar wd (1+ j)) #\*))
+	      (error "~S is not a wildcard word, it contains a **." wd)))
+      ;; Verify c is a legitimate wildcard character.
+      (unless (verify-wild-word-char-p c)
+	(error "~S is not a wildcard word, it contains an illegal character: ~
+		~S" wd c))
+      (when (= j end-1)
+	(setf piece (subseq wd start (1+ j)))
+	(when (< 0 (length piece))
+	  (push piece pat))))
+    (values (make-pattern (nreverse pat)))))
+
 ;;; COMPONENTS-MATCH -- Internal
 ;;;
-;;;   Wilds in to are matched against from where both are either lists
-;;; containing :wild and :wild-inferiors, patterns or strings.
+;;;   Wilds in "to" are matched against "from" where both are strings,
+;;; patterns or lists containing :wild and :wild-inferiors.
 ;;; FROM = :WILD-INFERIORS or :WILD handled separately for directory
-;;; component. Not communative.
+;;; component. Not communative. Result is a Boolean or a member result.
 ;;;
 (defun components-match (from to)
+  (declare (type (or simple-base-string symbol pattern cons fixnum) from)
+	   (type (or simple-base-string symbol pattern cons fixnum) to))
   (or (eq from to)
       (typecase from
 	(simple-base-string
+	 ;; Match can either be a identical pattern modulo wildcards or the
+	 ;; same string.
 	 (typecase to
-	   (pattern
+	   (pattern 
 	    (values (pattern-matches to from)))
 	   (simple-base-string
 	    (string-equal from to))))
 	(pattern
+	 ;; Match is a identical pattern.
 	 (and (pattern-p to) (pattern= from to)))
-	((member :wild) ; :WILD component matches any string, or pattern or NIL.
+	((member :wild)
+	 ;; :WILD component matches any string, or pattern or NIL.
 	 (or (stringp to)
 	     (logical-host-p to)
 	     (pattern-p to)
 	     (member to '(nil :unspecific :newest :wild :wild-inferiors))))
 	((member :newest)
-	 (member to '(:wild)))
-	(cons ; Watch for wildcards.
+	 ;; :newest matches itself, a wildcard or a positive integer version
+	 ;; number.
+	 (or (member to '(:wild :newest)) (and (integerp to) (plusp to))))
+	(cons ;; A list that may include wildcards.
 	 (and (consp from)
 	      (let ((from1 (first from))
 		    (from2 nil)
@@ -276,9 +478,6 @@
 	 (and (pattern-p from)
 	      (equal (pattern-pieces from) '(:multi-char-wild)))))))
 
-
-;;;; Utilities.
-
 ;;; COMPARE-COMPONENT  -- Internal
 ;;;
 ;;; A predicate for comparing two pathname slot component sub-entries.
@@ -307,6 +506,8 @@
 ;;; PATHNAME= -- Internal
 ;;;
 (defun pathname= (pathname1 pathname2)
+  (declare (type pathname pathname1)
+	   (type pathname pathname2))
   (and (eq (%pathname-host pathname1)
 	   (%pathname-host pathname2))
        (compare-component (%pathname-device pathname1)
@@ -321,7 +522,7 @@
 			  (%pathname-version pathname2))))
 
 ;;; WITH-PATHNAME -- Internal
-;;;   Converts the var, a pathname designator (a pathname, or string, or 
+;;;   Converts the expr, a pathname designator (a pathname, or string, or 
 ;;; stream), into a pathname.
 ;;;
 (defmacro with-pathname ((var expr) &body body)
@@ -332,12 +533,24 @@
 		   (stream (parse-namestring (file-name ,var)))))))
      ,@body))
 
+;;; WITH-HOST -- Internal
+;;;
+;;; Converts the var, a host or string name for a host, into a logical-host
+;;; structure or nil if not defined.
+;;;
+(defmacro with-host ((var expr) &body body)
+  `(let ((,var (let ((,var ,expr))
+		 (typecase ,var
+		   (logical-host ,var)
+		   (string (gethash ,var *logical-hosts*))
+		   (t nil)))))
+     ,@body))
 
 ;;; PATHNAME -- Interface
 ;;;
 (defun pathname (thing)
   "Convert thing (a pathname, string or stream) into a pathname."
-  (declare (type pathnamelike thing))
+  (declare (type path-designator thing))
   (with-pathname (pathname thing)
     pathname))
 
@@ -443,6 +656,9 @@
 			(default-version :newest))
   "Construct a filled in pathname by completing the unspecified components
    from the defaults."
+  (declare (type path-designator pathname)
+	   (type path-designator defaults)
+	   (values pathname))
   (with-pathname (defaults defaults)
     (let ((pathname (let ((*default-pathname-defaults* defaults))
 		      (pathname pathname))))
@@ -507,13 +723,14 @@
 
 ;;; MAKE-PATHNAME -- Interface
 ;;;
-(defun make-pathname (&key (host nil hostp)
+(defun make-pathname (&key host
 			   (device nil devp)
 			   (directory nil dirp)
 			   (name nil namep)
 			   (type nil typep)
 			   (version nil versionp)
-			   defaults (case :local))
+			   defaults
+			   (case :local))
   "Makes a new pathname from the component arguments.  Note that host is a host-
    structure."
   (declare (type (or host null) host)
@@ -522,19 +739,31 @@
 	   (type (or null string pattern (member :wild)) name)
 	   (type (or null string pattern (member :unspecific :wild)) type)
 	   (type (or null integer (member :unspecific :wild :newest)) version)
-	   (type (or pathnamelike null) defaults)
+	   (type (or path-designator null) defaults)
 	   (type (member :common :local) case))
-  (let* ((defaults (if defaults
-		       (with-pathname (defaults defaults) defaults)))
+  (let* ((defaults (when defaults
+		     (with-pathname (defaults defaults) defaults)))
 	 (default-host (if defaults
 			   (%pathname-host defaults)
 			   (pathname-host *default-pathname-defaults*)))
-	 (host (if hostp host default-host))
+	 (host (or host default-host))
 	 (diddle-args (and (eq case :common)
 			   (eq (host-customary-case host) :lower)))
 	 (diddle-defaults
 	  (not (eq (host-customary-case host)
-		   (host-customary-case default-host)))))
+		   (host-customary-case default-host))))
+	 (dev (if devp device (if defaults (%pathname-device defaults))))
+	 (dir (import-directory directory diddle-args))
+	 (ver (cond
+	       (versionp version)
+	       (defaults (%pathname-version defaults))
+	       (t nil))))
+    (when (and defaults (not dirp))
+      (setf dir
+	    (merge-directories dir
+			       (%pathname-directory defaults)
+			       diddle-defaults)))
+    
     (macrolet ((pick (var varp field)
 		 `(cond ((eq ,var :wild)
 			 (make-pattern (list :multi-char-wild)))
@@ -551,28 +780,29 @@
 					    diddle-defaults))
 			(t
 			 nil))))
-      (%make-pathname
-       host
-       (if devp device (if defaults (%pathname-device defaults)))
-       (let ((dir (import-directory directory diddle-args)))
-	 (if (and defaults (not dirp))
-	     (merge-directories dir
-				(%pathname-directory defaults)
-				diddle-defaults)
-	     dir))
-       (pick name namep %pathname-name)
-       (pick type typep %pathname-type)
-       (cond
-	 (versionp version)
-	 (defaults (%pathname-version defaults))
-	 (t nil))))))
+      (if (logical-host-p host)
+	  (%make-logical-pathname
+	   host
+	   nil
+	   dir
+	   (pick name namep %pathname-name)
+	   (pick type typep %pathname-type)
+	   ver)
+	  (%make-pathname
+	   host
+	   dev
+	   dir
+	   (pick name namep %pathname-name)
+	   (pick type typep %pathname-type)
+	   ver)))))
 
 ;;; PATHNAME-HOST -- Interface
 ;;;
 (defun pathname-host (pathname &key (case :local))
   "Accessor for the pathname's host."
-  (declare (type pathnamelike pathname)
+  (declare (type path-designator pathname)
 	   (type (member :local :common) case)
+	   (values host)
 	   (ignore case))
   (with-pathname (pathname pathname)
     (%pathname-host pathname)))
@@ -581,7 +811,7 @@
 ;;;
 (defun pathname-device (pathname &key (case :local))
   "Accessor for pathname's device."
-  (declare (type pathnamelike pathname)
+  (declare (type path-designator pathname)
 	   (type (member :local :common) case))
   (with-pathname (pathname pathname)
     (maybe-diddle-case (%pathname-device pathname)
@@ -594,7 +824,7 @@
 ;;;
 (defun pathname-directory (pathname &key (case :local))
   "Accessor for the pathname's directory list."
-  (declare (type pathnamelike pathname)
+  (declare (type path-designator pathname)
 	   (type (member :local :common) case))
   (with-pathname (pathname pathname)
     (maybe-diddle-case (%pathname-directory pathname)
@@ -606,7 +836,7 @@
 ;;;
 (defun pathname-name (pathname &key (case :local))
   "Accessor for the pathname's name."
-  (declare (type pathnamelike pathname)
+  (declare (type path-designator pathname)
 	   (type (member :local :common) case))
   (with-pathname (pathname pathname)
     (maybe-diddle-case (%pathname-name pathname)
@@ -619,7 +849,7 @@
 ;;;
 (defun pathname-type (pathname &key (case :local))
   "Accessor for the pathname's name."
-  (declare (type pathnamelike pathname)
+  (declare (type path-designator pathname)
 	   (type (member :local :common) case))
   (with-pathname (pathname pathname)
     (maybe-diddle-case (%pathname-type pathname)
@@ -627,11 +857,12 @@
 			    (eq (host-customary-case
 				 (%pathname-host pathname))
 				:lower)))))
+
 ;;; PATHNAME-VERSION
 ;;;
 (defun pathname-version (pathname)
   "Accessor for the pathname's version."
-  (declare (type pathnamelike pathname))
+  (declare (type path-designator pathname))
   (with-pathname (pathname pathname)
     (%pathname-version pathname)))
 
@@ -654,93 +885,154 @@
    (offset :init-form (required-argument)))
   (:report %print-namestring-parse-error))
 
-;;; %PARSE-NAMESTRING -- Internal
+;;; %PARSE-PHYSICAL-NAMESTRING -- Internal
 ;;;
-(defun %parse-namestring (namestr start end host junk-allowed)
-  (declare (type string namestr)
-	   (type index start end)
-	   (type host host)
-	   (values (or null pathname) index))
+(defun %parse-physical-namestring (namestr things-host start end junk-allowed)
+  (declare (type host things-host)
+	   (type string namestr)
+	   (type index start end))
   (cond (junk-allowed
-	 (handler-case (%parse-namestring namestr start end host nil)
+	 (handler-case
+	     (%parse-physical-namestring namestr things-host start end nil)
 	   (namestring-parse-error (condition)
-	       (values nil (namestring-parse-error-offset condition)))))
+	     (values nil (namestring-parse-error-offset condition)))))
 	((simple-string-p namestr)
 	 (multiple-value-bind
 	     (new-host device directory file type version)
-	     (funcall (host-parse host) namestr start end)
-	   (values (%make-pathname (or new-host host)
-				   device
-				   directory
-				   file
-				   type
-				   version)
-		   end)))
+	     (funcall (host-parse things-host) namestr start end)
+	   (declare (ignore new-host))
+	   (values
+	    (%make-pathname things-host device directory file type version)
+	    end)))
+	(t
+	 (%parse-physical-namestring (coerce namestr 'simple-base-string)
+				     things-host
+				     start end nil))))
+
+;;; %PARSE-LOGICAL-NAMESTRING -- Internal
+;;;
+(defun %parse-logical-namestring (namestr things-host start end junk-allowed)
+  (declare (type logical-host things-host)
+	   (type string namestr)
+	   (type index start end))
+  (cond (junk-allowed
+	 (handler-case
+	     (%parse-logical-namestring namestr things-host start end nil)
+	   (namestring-parse-error
+	    (condition)
+	    (values nil (namestring-parse-error-offset condition)))))
+	((simple-string-p namestr)
+	 (multiple-value-bind
+	     (lpath end)
+	     (parse-logical-namestring namestr :host things-host
+				       :start start :end end)
+	   (values lpath end)))
 	(t
-	 (%parse-namestring (coerce namestr 'simple-string)
-			    start end host nil))))
+	 (%parse-logical-namestring (coerce namestr 'simple-base-string)
+				    things-host
+				    start end nil))))
+
+;;; EXTRACT-PATH-PREFIX -- Internal
+;;;
+;;;   Extract the host or search-list prefix from the beginning of the
+;;; namestring, use it to return the host structure, the colon-position
+;;; in the namestring for further search, and whether the namestring specifies
+;;; a logical namestring.
+;;;
+(defun extract-path-prefix (namestr start end host defaults)
+  (declare (type simple-base-string namestr)
+	   (type index start end)
+	   (type (or null host) host)
+	   (type pathname defaults)
+	   (values host index (or t null)))
+  (let* ((colon-pos (position #\: namestr :start start :end end))
+	 (host (if host host (%pathname-host defaults)))
+	 (host-temp nil)
+	 (lpathp nil)
+	 (prefix-str nil))
+    (cond ((logical-host-p host)
+	   (setf lpathp t)
+	   (logical-host-name host))
+	  (t
+	   (funcall (host-unparse-host host) host)))
+    (unless colon-pos ; No logical host or search-list prefix to namestr.
+      (return-from extract-path-prefix (values host 0 lpathp)))
+    (setf prefix-str (subseq namestr start colon-pos)
+	  lpathp (logical-word-p prefix-str))
+    (cond (lpathp ; If a legitimate logical host name prefix exists, use it.
+	   (setf host-temp (gethash prefix-str *logical-hosts*))
+	   (unless (and prefix-str host-temp)
+	     (error "The logical-host ~S is not defined." prefix-str))
+	   (setf host host-temp))
+	  (t 
+	   (unless (gethash prefix-str *search-lists*)
+	     (error "The prefix ~S to the pathname string ~S is not a ~
+		     registered search-list." prefix-str namestr))))
+    (values host colon-pos lpathp)))
 
 ;;; PARSE-NAMESTRING -- Interface
 ;;;
 (defun parse-namestring (thing
 			 &optional host (defaults *default-pathname-defaults*)
 			 &key (start 0) end junk-allowed)
-  "Converts thing, a pathname designator, into a pathname structure, returns
-   the printed representation."
-  (declare (type (or simple-base-string stream pathname) thing)
+  "Converts pathname, a pathname designator, into a pathname structure,
+   for a physical pathname, returns the printed representation. Host may be
+   a physical host structure or host namestring."
+  (declare (type path-designator thing)
 	   (type (or null host) host)
-	   (type pathnamelike defaults)
+	   (type pathname defaults)
 	   (type index start)
 	   (type (or index null) end)
-	   (type (or null (not null)) junk-allowed)
-	   (values (or null pathname) index))
-  (cond ((stringp thing)
-	 (let* ((end1 (or end (length thing)))
-		(things-host nil)
-		(hosts-name (when host
-			      (funcall (host-parse host) thing start end1))))
-	   (setf things-host
-		 (maybe-extract-logical-host thing start end1))
-	   (when (and host things-host) ; A logical host and host are defined.
-	     (unless (string= things-host hosts-name)
-	       (error "Hosts do not match: ~S in ~S and ~S."
-		      things-host thing host)))
-	   (if things-host
-	       (unless (gethash (string-downcase things-host) *search-lists*)
-		 ;; Not a search-list name, make it a logical-host name.
-		 (setf host (intern-logical-host things-host))))
-	   (%parse-namestring thing start end1
-			      (or host
-				  (with-pathname (defaults defaults)
-						 (%pathname-host defaults)))
-			      junk-allowed)))
-	((pathnamep thing)
-	 (when host
-	   (unless (eq host (%pathname-host thing))
-	     (error "Hosts do not match: ~S and ~S."
-		    host
-		    (%pathname-host thing))))
-	 (values thing start))
-	((streamp thing)
-	 (let ((host-name (funcall (host-unparse-host host) host))
-	       (stream-type (type-of thing))
-	       (stream-host-name (host-namestring thing)))
-	   (unless (or (eq stream-type 'fd-stream)
-		       ;;********Change fd-stream to file-stream in sources too.
-		       (eq stream-type 'synonym-stream))
-	     (error "Stream ~S was created with other than OPEN, WITH-OPEN-FILE~
-		     or MAKE-SYNONYM-FILE." thing))
-	   (unless (string-equal stream-host-name host-name)
-	     (error "Hosts do not match: ~S and ~S."
-		    host
-		    host-name)))
-	 (values thing start))))
+	   (type (or t null) junk-allowed)
+	   (values (or null pathname) (or null index)))
+  (let* ((end1 (or end (length thing)))
+	 (things-host nil)
+	 (colon-pos nil)
+	 (lpathp nil)) 
+    (typecase thing
+      (simple-base-string 
+       (multiple-value-setq
+	   (things-host colon-pos lpathp)
+	 (extract-path-prefix thing start end1 host defaults))
+       (if lpathp
+	   (%parse-logical-namestring thing
+				      things-host
+				      colon-pos
+				      end1
+				      junk-allowed)
+	   (%parse-physical-namestring thing
+				       things-host
+				       start
+				       end1
+				       junk-allowed)))
+      (pathname ; structure type
+       (let* ((host (if host host (%pathname-host defaults)))
+	      (hosts-name (funcall (host-unparse-host host) host)))
+	 (unless (eq hosts-name (%pathname-host thing))
+	   (error "Hosts do not match: ~S and ~S."
+		  hosts-name (%pathname-host thing))))
+       (values thing start))
+      (stream
+       (let* ((stream-type (type-of thing))
+	      (things-host-name (host-namestring thing))
+	      (host (if host host (%pathname-host defaults)))
+	      (hosts-name (funcall (host-unparse-host host) host)))
+	 (unless (or (eq stream-type 'fd-stream)
+		     ;;######Change fd-stream to file-stream in sources too.
+		     (eq stream-type 'synonym-stream))
+	   (error "Stream ~S was created with other than OPEN, WITH-OPEN-FILE~
+		   or MAKE-SYNONYM-FILE." thing))
+	 (unless (string-equal hosts-name things-host-name)
+	   (error "Hosts do not match: ~S and ~S."
+		  hosts-name things-host-name)))
+       (values (file-name thing) start)))))
 
 ;;; NAMESTRING -- Interface
 ;;;
 (defun namestring (pathname)
   "Construct the full (name)string form of the pathname."
-  (declare (type pathnamelike pathname))
+  (declare (type path-designator pathname)
+	   (values (or null simple-base-string)))
   (with-pathname (pathname pathname)
     (let ((host (%pathname-host pathname)))
       (cond ((logical-host-p host)
@@ -756,7 +1048,8 @@
 ;;;
 (defun host-namestring (pathname)
   "Returns a string representation of the name of the host in the pathname."
-  (declare (type pathnamelike pathname))
+  (declare (type path-designator pathname)
+	   (values (or null simple-base-string)))
   (with-pathname (pathname pathname)
     (let ((host (%pathname-host pathname)))
       (if host
@@ -769,7 +1062,8 @@
 ;;;
 (defun directory-namestring (pathname)
   "Returns a string representation of the directories used in the pathname."
-  (declare (type pathnamelike pathname))
+  (declare (type path-designator pathname)
+	   (values (or null simple-base-string)))
   (with-pathname (pathname pathname)
     (let ((host (%pathname-host pathname)))
       (if host
@@ -782,7 +1076,8 @@
 ;;;
 (defun file-namestring (pathname)
   "Returns a string representation of the name used in the pathname."
-  (declare (type pathnamelike pathname))
+  (declare (type path-designator pathname)
+	   (values (or null simple-base-string)))
   (with-pathname (pathname pathname)
     (let ((host (%pathname-host pathname)))
       (if host
@@ -797,7 +1092,7 @@
 			  &optional (defaults *default-pathname-defaults*))
   "Returns an abbreviated pathname sufficent to identify the pathname relative
    to the defaults."
-  (declare (type pathnamelike pathname))
+  (declare (type path-designator pathname))
   (with-pathname (pathname pathname)
     (let ((host (%pathname-host pathname)))
       (if host
@@ -814,7 +1109,7 @@
 ;;;
 (defun wild-pathname-p (pathname &optional field-key)
   "Predicate for determining whether pathname contains any wildcards."
-  (declare (type pathnamelike pathname)
+  (declare (type path-designator pathname)
 	   (type (member nil :host :device :directory :name :type :version)
 		 field-key))
   (with-pathname (pathname pathname)
@@ -826,30 +1121,29 @@
 	   (wild-pathname-p pathname :name)
 	   (wild-pathname-p pathname :type)
 	   (wild-pathname-p pathname :version)))
-      (:host
-       (pattern-p (%pathname-host pathname)))
-      (:device
-       (pattern-p (%pathname-host pathname)))
-      (:directory
-       (some #'pattern-p (%pathname-directory pathname)))
-      (:name
-       (pattern-p (%pathname-name pathname)))
-      (:type
-       (pattern-p (%pathname-type pathname)))
-      (:version
-       (eq (%pathname-version pathname) :wild)))))
+      (:host (pattern-p (%pathname-host pathname)))
+      (:device (pattern-p (%pathname-host pathname)))
+      (:directory (some #'pattern-p (%pathname-directory pathname)))
+      (:name (pattern-p (%pathname-name pathname)))
+      (:type (pattern-p (%pathname-type pathname)))
+      (:version (eq (%pathname-version pathname) :wild)))))
 
 ;;; PATHNAME-MATCH -- Interface
 ;;;
-(defun pathname-match-p (pathname wildname)
+(defun pathname-match-p (in-pathname in-wildname)
   "Pathname matches the wildname template?"
-  (with-pathname (pathname pathname)
-    (with-pathname (wildname wildname)
+  (declare (type path-designator in-pathname))
+  (with-pathname (pathname in-pathname)
+    (with-pathname (wildname in-wildname)
       (macrolet ((frob (field)
 		   `(or (null (,field wildname))
 			(components-match (,field wildname)
 					  (,field pathname)))))
-	(and (frob %pathname-host)
+	(and (or (null (%pathname-host wildname))
+		 (components-match (logical-host-name
+				    (%pathname-host wildname))
+				   (logical-host-name
+				    (%pathname-host pathname))))
 	     (frob %pathname-device)
 	     (frob %pathname-directory)
 	     (frob %pathname-name)
@@ -861,15 +1155,23 @@
 
 ;;; SUBSTITUTE-INTO -- Internal
 ;;;
-(defun substitute-into (pattern subs)
+;;;   Place the substitutions into the pattern and return the string or
+;;; pattern that results. The case argument allows for the use of a :lower
+;;; case to enable a UNIX and implementation specific translation of uppercase
+;;; characters in logical-namestrings into lower case physical namestrings.
+;;;
+(defun substitute-into (pattern subs &key (case :common))
   (declare (type pattern pattern)
-	   (type list subs))
+	   (type list subs)
+	   (values (or simple-base-string pattern)))
   (let ((in-wildcard nil)
 	(pieces nil)
 	(strings nil))
     (dolist (piece (pattern-pieces pattern))
       (cond ((simple-string-p piece)
-	     (push piece strings)
+	     (if (eq case 'lower)
+		 (push (string-downcase piece) strings)
+		 (push piece strings))
 	     (setf in-wildcard nil))
 	    (in-wildcard)
 	    ((null subs))
@@ -882,17 +1184,18 @@
 				 (nreverse strings))
 			  pieces))
 		  (dolist (piece (pattern-pieces sub))
-		    (push piece pieces)))
+		    (if (and (stringp piece) (eq case 'lower))
+			(push (string-downcase piece) pieces)
+			(push piece pieces))))
 		 (simple-string
-		  (push sub strings))))
+		  (if (eq case 'lower)
+		      (push (string-downcase sub) strings)
+		      (push sub strings)))))
 	     (setf in-wildcard t))))
     (when strings
-      (push (apply #'concatenate 'simple-string
-		   (nreverse strings))
+      (push (apply #'concatenate 'simple-string (nreverse strings))
 	    pieces))
-    (if (and pieces
-	     (simple-string-p (car pieces))
-	     (null (cdr pieces)))
+    (if (and pieces (simple-string-p (car pieces)) (null (cdr pieces)))
 	(car pieces)
 	(make-pattern (nreverse pieces)))))
 
@@ -977,7 +1280,7 @@
 (defun translate-pathname (source from-wildname to-wildname &key)
   "Use the source pathname to translate the from-wildname's wild and
    unspecified elements into a completed to-pathname based on the to-wildname."
-  (declare (type pathnamelike source from-wildname to-wildname))
+  (declare (type path-designator source from-wildname to-wildname))
   (with-pathname (source source)
     (with-pathname (from from-wildname)
       (with-pathname (to to-wildname)
@@ -1111,10 +1414,10 @@
   "Return the expansions for the search-list starting PATHNAME.  If PATHNAME
    does not start with a search-list, then an error is signaled.  If
    the search-list has not been defined yet, then an error is signaled.
-   The expansion for a search-list can be set with SETF."
+   The expansion for a search-list can be set with SETF." 
   (with-pathname (pathname pathname)
     (let ((search-list (extract-search-list pathname t))
-	  (host (pathname-host pathname)))
+	  (host (pathname-host pathname))) 
       (if (search-list-defined search-list)
 	  (mapcar #'(lambda (directory)
 		      (make-pathname :host host
@@ -1212,60 +1515,8 @@
 
 
 ;;;;  Logical pathname support. ANSI 92-102 specification.
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; Logical pathnames have the following format:
-;;;
-;;; logical-namestring ::=
-;;;         [host ":"] [";"] {directory ";"}* [name] ["." type ["." version]]
-;;;
-;;; host ::= word
-;;; directory ::= word | wildcard-word | **
-;;; name ::= word | wildcard-word
-;;; type ::= word | wildcard-word
-;;; version ::= pos-int | newest | NEWEST | *
-;;; word ::= {uppercase-letter | digit | -}+
-;;; wildcard-word ::= [word] '* {word '*}* [word]
-;;; pos-int ::= integer > 0
-;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;; Logical pathnames are a subclass of pathnames and can use the same
-;; data structures with the device slot necessarily nil.  The current lack of
-;; an integrated efficient CLOS means that the classes are mimiced using
-;; structures.  They follow the pattern set by search-lists, a CMUCL specific
-;; extension.
-
-(defstruct (logical-host
-	    (:include host
-		      (:parse #'parse-logical-namestring)
-		      (:unparse #'unparse-logical-namestring)
-		      (:unparse-host #'unparse-logical-host)
-		      (:unparse-directory #'unparse-logical-directory)
-		      (:unparse-file #'unparse-logical-file)
-		      (:unparse-enough #'identity)
-		      (:customary-case :upper)))
-  (name "" :type simple-string)
-  (translations nil :type list)
-  (canon-transls nil :type list))
-
-(deftype logical-pathname ()
-  '(satisfies logical-pathname-p))
-
-;;; LOGICAL-PATHNAME-P -- Public
-;;;
-(defun logical-pathname-p (thing)
-  "Return T if THING is a LOGICAL-PATHNAME object."
-  (and (pathnamep thing)
-       (logical-host-p (%pathname-host thing))))
-
-;;; *LOGICAL-PATHNAMES* --internal.
-;;;
-;;; Hash table searching maps a logical-pathname's host to their physical
-;;; pathname translation.
-
-(defvar *logical-pathnames* (make-hash-table :test #'equal))
+;;;;  As logical-pathname translations are loaded they are canonicalized as
+;;;;  patterns to enable rapid efficent translation into physical pathnames.
 
 (define-condition logical-namestring-parse-error (error)
   ((complaint :init-form (required-argument))
@@ -1276,10 +1527,12 @@
 
 ;;; MAYBE-MAKE-LOGICAL-PATTERN -- Internal
 ;;;
+;;;  Take the ; reduced strings and break them into words and wildcard-words.
+;;;
 (defun maybe-make-logical-pattern (namestr start end)
-  "Take the ; reduced strings and break them into words and wildcard-words."
-  (declare (type simple-base-string namestr)
-	   (type index start end))
+  (declare (type (or symbol simple-base-string) namestr)
+	   (type index start end)
+	   (values (or null symbol pattern simple-base-string)))
   (collect ((pattern))
     (let ((last-regular-char nil)
 	  (look-ahead+1 nil)
@@ -1295,8 +1548,7 @@
 	  (setf char (schar namestr index))
 	  (cond ((or (char= #\. char) (char= #\; char)) ; End of pattern piece.
 		 (flush-pending-regulars))
-		((or (char= #\- char) ; Hyphen is a legal word character.
-		     (alphanumericp char))    ; Building a word.
+		((verify-word-char-p char) ; Building a word.
 		 (unless last-regular-char
 		   (setf last-regular-char index)))
 		((char= #\* char) ; Wildcard word, :wild or wildcard-inferior.
@@ -1335,18 +1587,25 @@
 	  (t
 	   (make-pattern (pattern)))))))
 
-;;; INTERN-LOGICAL-HOST
+;;; INTERN-LOGICAL-HOST -- Internal
+;;;
+;;;   The name is a string. Put it in the hash table, return the logical-host.
 ;;;
 (defun intern-logical-host (name)
   (declare (simple-string name)
 	   (values logical-host))
-  (let ((name (string-upcase name)))
-    (or (gethash name *logical-pathnames*)
-	(let ((new (make-logical-host :name name)))
-	  (setf (gethash name *logical-pathnames*) new)
-	  new))))
+  (unless (logical-word-p name)
+    (error "Hostname ~S is not a legitimate logical word ~%
+	       (consisting of uppercase letters, digits and hyphens)." name))
+  (or (gethash name *logical-hosts*)
+      (let ((new (make-logical-host :name name)))
+	(setf (gethash name *logical-hosts*) new)
+	new)))
 
-;;; EXTRACT-LOGICAL-NAME-TYPE-AND-VERSION
+;;; EXTRACT-LOGICAL-NAME-TYPE-AND-VERSION -- Internal
+;;;
+;;;   Return a set of three elements that can be any of patterns, strings,
+;;; keywords, and integers.
 ;;;
 (defun extract-logical-name-type-and-version (namestr start end)
   (declare (type simple-base-string namestr)
@@ -1394,18 +1653,18 @@
 ;;;
 (defun logical-word-p (word)
   (declare (type simple-base-string word)
-	   (values boolean))
+	   (values (or t null)))
   (let ((ch nil))
     (dotimes (i (length word))
       (setf ch (schar word i))
-      (unless (or (alphanumericp ch) (eq ch #\-))
+      (unless (or (upper-case-p ch) (digit-char-p ch) (eq ch #\-))
 	(return-from logical-word-p nil))))
   t)
 
 ;;; MAYBE-EXTRACT-LOGICAL-HOST -- Internal
-;;;    Verify whether there is a logical host prefix in the namestr. If one is
-;;; found return its name and the index of the remainder of the namestring.
-;;; If not return nil.
+;;;    Verify whether there is a logical host or search-list prefix in the
+;;; namestr. If one is found return its name and the index of the remainder of
+;;; the namestring.  If not return nil.
 ;;;
 (defun maybe-extract-logical-host (namestr start end)
   (declare (type simple-base-string namestr)
@@ -1417,73 +1676,96 @@
 	(let ((host (subseq namestr start colon-pos)))
 	  (cond ((logical-word-p host)
 		 (return-from maybe-extract-logical-host
-			      (values (string-upcase host) (1+ colon-pos))))
+			      (values host (1+ colon-pos))))
 		((string= host "*")
 		 (return-from maybe-extract-logical-host
-			      (values :wild (1+ colon-pos))))))
+			      (values :wild (1+ colon-pos))))
+		(t (error "Host component ~S in namestring ~S is neither a ~
+			   wildcard (*),~%or a word formed from capital ~
+			   letters, digits and hyphens." host namestr))))
 	;; Implied host
 	(values nil 0))))
 
+;;; DECIDE-LOGICAL-HOST -- Internal
+;;;
+(defun decide-logical-host (host path-host defaults-host)
+  (declare (type (or null host simple-base-string stream)
+		 host path-host defaults-host)
+	   (values (or null logical-host)))
+  (with-host (host-struc host)
+     (with-host (path-host-struc path-host)
+	(with-host (defaults-host-struc defaults-host)
+	  (if host-struc
+	      host-struc
+	      (if path-host-struc
+		  path-host-struc
+		  (if defaults-host-struc
+		      defaults-host-struc
+		      (error "None of ~S, ~S, or ~S is a logical-host"
+			     host path-host defaults-host))))))))
+
 ;;; PARSE-LOGICAL-NAMESTRING  -- Internal
 ;;;
-;;;   Break up a logical-namestring into its constituent parts.
+;;;   Break up a logical-namestring, always a string, into its constituent
+;;; parts.
 ;;;
-(defun parse-logical-namestring (namestr start end)
-
+(defun parse-logical-namestring (namestr
+				 &key
+				 host
+				 (defaults *default-pathname-defaults*)
+				 (start 0)
+				 (end (length namestr)))
   (declare (type simple-base-string namestr)
 	   (type index start end)
-	   (values (or logical-host null)
-		   (or (member nil :unspecific) simple-base-string)
-		   list
-		   (or simple-base-string list pattern (member :wild))
-		   (or simple-string pattern null (member :unspecific :wild))
-		   (or integer null (member :newest :wild))))
-  (multiple-value-bind ; Parse for :
-      (host place)
-      (maybe-extract-logical-host namestr start end)
-    (typecase host
-      (keyword t) ; :wild for example.
-      (simple-string ; Already a search-list element?
-       (unless (gethash (string-downcase host) *search-lists*)
-	  (setf host (intern-logical-host host))))
-      (null nil))
-    (multiple-value-bind
-	(absolute pieces) 
-	(split-at-slashes namestr place end #\;)
-      ;; Logical paths follow opposite convention of physical pathnames.
-      (setf absolute (not absolute)) 
-      (multiple-value-bind (name type version)
-			   (let* ((tail (car (last pieces)))
-				  (tail-start (car tail))
-				  (tail-end (cdr tail)))
-			     (unless (= tail-start tail-end)
-			       (setf pieces (butlast pieces))
-			       (extract-logical-name-type-and-version
-				namestr tail-start tail-end)))
-	;; Now we have everything we want.  So return it.
-	(values host
-		:unspecific
-		(collect ((dirs))
-		  (dolist (piece pieces)
-		    (let ((piece-start (car piece))
-			  (piece-end (cdr piece)))
-		      (unless (= piece-start piece-end)
-			(let ((dir (maybe-make-logical-pattern namestr
-							       piece-start
-							       piece-end)))
-			  (if (and (simple-string-p dir)
-				   (string= dir ".."))
-			      (dirs :up)
-			      (dirs dir))))))
-		  (cond (absolute
-			 (cons :absolute (dirs)))
-			((dirs)
-			 (cons :relative (dirs)))
-			(t
-			 nil)))
-		name
-		type
-		version)))))
+	   (type (or null simple-base-string logical-host stream) host)
+	   (type pathname defaults)
+	   (values (or null logical-pathname) (or null index)))
+  (let ((namestring (string-upcase namestr))
+	(default-host (pathname-host defaults)))
+    ;; Parse for : prefixed hostname if present in namestr.
+    (multiple-value-bind (namestr-host place)
+			 (maybe-extract-logical-host namestring start end)
+      ;; The explicit host argument is a logical host, or the host's name
+      ;; or the defaults provide the host, in that order.
+      (setf host (decide-logical-host host namestr-host default-host))
+      (multiple-value-bind (absolute pieces)
+			   (split-at-slashes namestring place end #\;)
+	;; Logical paths follow opposite convention of physical pathnames.
+	(setf absolute (not absolute)) 
+	(multiple-value-bind (name type version)
+			     (let* ((tail (car (last pieces)))
+				    (tail-start (car tail))
+				    (tail-end (cdr tail)))
+			       (unless (= tail-start tail-end)
+				 (setf pieces (butlast pieces))
+				 (extract-logical-name-type-and-version
+				  namestring tail-start tail-end)))
+	  ;; Now we have everything we want.  Construct a logical pathname.
+	  (%make-logical-pathname
+	   host
+	   nil
+	   (collect ((dirs))
+		    (dolist (piece pieces)
+		      (let ((piece-start (car piece))
+			    (piece-end (cdr piece)))
+			(unless (= piece-start piece-end)
+			  (let ((dir
+				 (maybe-make-logical-pattern namestring
+							     piece-start
+							     piece-end)))
+			    (if (and (simple-string-p dir)
+				     (string= dir ".."))
+				(dirs :up)
+				(dirs dir))))))
+		    (cond (absolute
+			   (cons :absolute (dirs)))
+			  ((dirs)
+			   (cons :relative (dirs)))
+			  (t
+			   nil)))
+	   name
+	   type
+	   version))))))
 
 ;;; UNPARSE-LOGICAL-DIRECTORY-LIST -- Internal
 ;;;
@@ -1513,8 +1795,8 @@
 ;;; UNPARSE-LOGICAL-DIRECTORY -- Internal
 ;;;
 (defun unparse-logical-directory (pathname)
-  (declare (type pathname pathname))
-  (unparse-logical-directory-list (%pathname-directory pathname)))
+  (declare (type logical-pathname pathname))
+  (unparse-logical-directory-list (%logical-pathname-directory pathname)))
 
 ;;; UNPARSE-LOGICAL-PIECE -- Internal
 ;;;
@@ -1559,7 +1841,6 @@
 ;;; UNPARSE-LOGICAL-FILE -- Internal
 ;;;
 (defun unparse-logical-file (pathname)
-  (declare (type pathname pathname))
   (declare (type pathname pathname))
   (unparse-unix-file pathname))
 
@@ -1567,7 +1848,7 @@
 ;;;
 (defun unparse-logical-host (pathname)
   (declare (type logical-pathname pathname))
-  (logical-host-name (%pathname-host pathname)))
+  (logical-host-name (%logical-pathname-host pathname)))
 
 ;;; UNPARSE-LOGICAL-NAMESTRING -- Internal
 ;;;
@@ -1580,46 +1861,52 @@
 
 ;;; LOGICAL-PATHNAME -- Public
 ;;;
-;;; Logical-pathname must signal a type error of type type-error.
+;;; Logical-pathname must signal an error of type type-error.
 ;;;
 (defun logical-pathname (pathspec)
   "Converts the pathspec argument to a logical-pathname and returns it."
-  (declare (type (or logical-pathname string stream) pathspec)
+  (declare (type (or logical-pathname simple-base-string stream) pathspec)
 	   (values logical-pathname))
   ;; Decide whether to typedef logical-pathname, logical-pathname-string,
   ;; or streams for which the pathname function returns a logical-pathname.
-  (cond ((logical-pathname-p pathspec) pathspec)
-	((stringp pathspec)
-	 (if (maybe-extract-logical-host pathspec 0 (length pathspec))
-	     (pathname pathspec)
-	     (error "Pathspec is not a logical pathname prefaced by <host>:.")))
-	((streamp pathspec)
-	 (if (logical-pathname-p pathspec)
-	     (pathname pathspec)
-	     (error "Stream ~S is not a logical-pathname." pathspec)))
-	(t
-	 (error "~S is not either ~%
-		 a logical-pathname object, or~%
-		 a logical pathname namestring, or~%
-		 a stream named by a logical pathname." pathspec))))
-
-;;; TRANSLATIONS-TEST-P
+  (etypecase pathspec
+    (logical-pathname pathspec)
+    (simple-base-string
+     (let* ((l-pathspec (length pathspec))
+	    (pathspec-host
+	     (maybe-extract-logical-host pathspec 0 l-pathspec)))
+       (if pathspec-host
+	   (parse-logical-namestring pathspec :host pathspec-host
+				     :start 0 :end l-pathspec)
+	   (error "Path specification ~S is not a logical pathname ~
+		   prefaced by <host>:." pathspec))))
+    (stream
+     (let ((stream-type (type-of pathspec))
+	   (path-file (file-name pathspec)))
+       (unless (or (eq stream-type 'fd-stream)
+		   (eq stream-type 'synonym-stream))
+	 (error "Stream ~S was created with other than OPEN, WITH-OPEN-FILE~
+		 or MAKE-SYNONYM-FILE." pathspec))
+       (parse-logical-namestring path-file
+				 :start 0 :end (length path-file))))))
+
+;;; TRANSLATIONS-TEST-P -- Internal
 ;;;
 ;;;   Verify that the list of translations consists of lists and prepare
-;;; canonical translations from the pathnames.
+;;; canonical translations (parse pathnames and expand out wildcards into
+;;; patterns).
 ;;;
 (defun translations-test-p (transl-list host)
   (declare (type logical-host host)
 	   (type list transl-list)
-	   (values boolean))
-  (let ((can-transls nil))
-    (setf can-transls (make-list (length transl-list))
-	  (logical-host-canon-transls host) can-transls)
+	   (values (or t null)))
+  (let ((can-transls (make-list (length transl-list))); Canonical translations.
+	(c-tr nil))
+    (setf (logical-host-canon-transls host) can-transls)
     (do* ((i 0 (1+ i))
 	  (tr (nth i transl-list) (nth i transl-list))
 	  (from-path (first tr) (first tr))
-	  (to-path (second tr) (second tr))
-	  (c-tr (nth i can-transls) (nth i can-transls)))
+	  (to-path (second tr) (second tr)))
 	 ((<= (length transl-list) i))
       (setf c-tr (make-list 2))
       (if (logical-pathname-p from-path)
@@ -1629,8 +1916,7 @@
 	  (setf (second c-tr) to-path)
 	  (setf (second c-tr) (parse-namestring to-path)))
       ;; Verify form of translations.
-      (unless (and (or (logical-pathname-p from-path)
-		       (first c-tr))
+      (unless (and (or (logical-pathname-p from-path) (first c-tr))
 		   (second c-tr))
 	(return-from translations-test-p nil))		       
       (setf (nth i can-transls) c-tr)))
@@ -1645,8 +1931,7 @@
 	   (values list))
   (etypecase host
     (simple-string
-     (setf host (string-upcase host))
-     (let ((host-struc (gethash host *logical-pathnames*)))
+     (let ((host-struc (gethash (string-upcase host) *logical-hosts*)))
        (if host-struc
 	   (logical-host-translations host-struc)
 	   (error "HOST ~S is not defined." host))))
@@ -1661,22 +1946,25 @@
   (declare (type (or simple-base-string logical-host) host)
 	   (type list translations)
 	   (values list))
+  (setf host (string-upcase host))
   (typecase host 
     (simple-base-string
-     (setf host (string-upcase host))
+     (unless (logical-word-p host)
+       (error "Hostname ~S is not a legitimate logical word ~%
+	       (consisting of uppercase letters, digits and hyphens)." host))
      (multiple-value-bind
 	 (hash-host xst?)
-	 (gethash host *logical-pathnames*)
+	 (gethash host *logical-hosts*)
        (unless xst?
-	 (intern-logical-host host)
-	 (setf hash-host (gethash host *logical-pathnames*)))
+	 (setf hash-host (intern-logical-host host)))
        (unless (translations-test-p translations hash-host)
 	 (error "Translations ~S is not a list of pairs of from-, ~
 		 to-pathnames." translations)))
      translations)
     (t
+     (format t "TRANSLATIONS-TEST-P args = ~S, ~S~%" translations host)
      (unless (translations-test-p translations host)
-       (error "Translations ~S is not a list of pairs of from-, ~
+       (error "Translations ~S is not a list of pairs of from- and ~
 	       to-pathnames." translations))
      translations)))
 
@@ -1698,7 +1986,7 @@
 				:name host
 				:type "translations"
 				:version :newest))
-	 (new-stuff (gethash host *logical-pathnames*))
+	 (new-stuff (gethash host *logical-hosts*))
 	 (new-transl (logical-host-translations new-stuff)))
 	(with-open-file (out-str p-name
 				 :direction :output
@@ -1711,16 +1999,16 @@
 		     ~S~% ~
 		     for the host:~%   ~
 		     ~S.~%" p-name new-transl host))))
-
+#|
 ;;; Define a SYS area for system dependent logical translations, should we
-;;; ever want to use them. ########### Decision still need to made whether
-;;; to take advantage of this area.
+;;; ever want to use them. Not currently used in CMUCL.
 
-#|
 (progn
   (intern-logical-host "SYS")
   (save-logical-pathname-translations "SYS" "library:"))
+
 |#
+
 ;;; LOAD-LOGICAL-PATHNAME-TRANSLATIONS -- Public
 ;;;
 (defun load-logical-pathname-translations (host)
@@ -1729,13 +2017,13 @@
    returned. If host is not already defined, but definition is found and loaded
    successfully, T is returned, else error."
   (declare (type simple-base-string host)
-	   (values boolean))
+	   (values (or t null)))
   (setf host (string-upcase host))
   (let ((p-name nil)
 	(p-trans nil))
     (multiple-value-bind
 	(log-host xst?)
-	(gethash host *logical-pathnames*)
+	(gethash host *logical-hosts*)
       (if xst?
 	  ;; host already has a set of defined translations.
 	  (return-from load-logical-pathname-translations nil)
@@ -1762,245 +2050,321 @@
 ;;; COMPILE-FILE-PATHNAME -- Public
 ;;;
 (defun compile-file-pathname (file-path &key output-file)
-  (declare (type (or string stream pathname logical-pathname) file-path)
-	   (type (or string stream pathname logical-pathname) output-file)
-	   (values pathname))
-  (with-pathname (path file-path)
-     (cond ((and (logical-pathname-p path) (not output-file))
-	    (make-pathname :host (%pathname-host path)
-			   :directory (%pathname-directory path)
-			   :device (%pathname-device path)
-			   :name (%pathname-name path)
-			   :type (c:backend-fasl-file-type c:*backend*)))
-	   ((logical-pathname-p path)
-	    (translate-logical-pathname path))
-	   (t file-path))))
-
-;;; TRANSLATE-WILD-P -- Internal
-;;;
-(defmacro translate-wild-p (to-obj)
-  "Translate :wild?"
-  (declare (type keyword to-obj))
-  `(etypecase ,to-obj
-     ((or (member :wild :unspecific nil :up :back)
-	  string
-	  pattern)
-      t)))
+  (declare (type path-designator file-path)
+	   (type (or null pathname) output-file)
+	   (values (or null pathname)))
+  (if (logical-pathname-p file-path)
+      (if output-file
+	  (translate-logical-pathname file-path)
+	  (%make-logical-pathname
+	   (or (%logical-pathname-host file-path)
+	       (%pathname-host *default-pathname-defaults*))
+	   nil
+	   (or (%logical-pathname-directory file-path)
+	       (%pathname-directory *default-pathname-defaults*))
+	   (or (%logical-pathname-name file-path)
+	       (%pathname-name *default-pathname-defaults*))
+	   (c:backend-fasl-file-type c:*backend*)
+	   (%pathname-version *default-pathname-defaults*)))
+      (with-pathname (path file-path)
+		     path)))
+
+;;; TRANSLATE-LOGICAL-HOST -- Internal
+;;;
+(defun translate-logical-host (path-host from-host to-host)
+  "Pathname must contain a logical host or wild cards."
+  (declare (type (or logical-host host) path-host from-host to-host))
+  (cond ((or (eq path-host from-host) (eq from-host :wild)) to-host)
+	(t (throw 'next-translation nil))))
+
+(defmacro translate-absolute-relative (src from to)
+  "Translate :ABSOLUTE and RELATIVE keywords."
+  `(if (eq ,src ,from)
+	  ,to
+	  (throw 'next-translation nil)))
+
+(defmacro cleanup-to (from-context to-context result)
+  `(unless ,from-context
+     (setf ,result (append (reverse ,to-context) ,result))))
+
+;;; TRANSLATE-DIR-ELEMENTS -- Internal
+;;;
+;;;   The translation of pathnames occurs in two stages, the first produces an
+;;; intermediate result upon which the second is repeated.
+;;; The pathname result is a copy of the to element with each missing or
+;;; wildcard field filled in by a portion of from and placed in result.
+;;; If the to field is a :wild or :wild-inferiors, it is copied without any
+;;; further action. Wildcard-inferiors in the from field set the wild-inf-flag
+;;; and push the to field element onto the result, continuing until a match is
+;;; found.
+;;;
+(defun translate-dir-elements (from from-context to to-context result
+				    &optional wild-inf-flag)
+  "Translations are based on the element types of from and to, which can
+   recursively effect their repective contexts when they are :wild-inferiors."
+  (declare (type
+	    (or null (member :wild :wild-inferiors) pattern
+		simple-base-string)
+	    from to)
+	   (type list from-context to-context)
+	   (type (or null t) wild-inf-flag)
+	   (values list list list)) 
+  (let ((match-p nil)
+	(matches nil))
+    (typecase from
+      (simple-base-string
+       (typecase to
+	 (simple-base-string
+	  (cond (wild-inf-flag
+		 (push (string-downcase to) result)
+		 (multiple-value-setq (from-context to-context result)
+		   (translate-dir-elements from from-context
+					   (pop to-context) to-context t)))
+		(t ; Clean up, include any untranslated to leftovers.
+		 (push (string-downcase to) result)
+		 (cleanup-to from-context to-context result))))
+	 (pattern
+	  (multiple-value-setq (match-p matches)
+	    (pattern-matches to from))
+	  (cond (match-p
+		 (push (string-downcase from) result))
+		(wild-inf-flag
+		 (push (string-downcase from) result)
+		 (multiple-value-setq (from-context to-context result)
+		   (translate-dir-elements from from-context
+					   (pop to-context) to-context t)))
+		(t
+		 (throw 'next-translation nil))))
+	 ((member :wild :wild-inferiors)
+	  ;; Clean up, include any untranslated to leftovers.
+	  (push (string-downcase from) result)
+	  (cleanup-to from-context to-context result))))
+      (pattern
+       (typecase to
+	 (simple-base-string
+	  (multiple-value-setq (match-p matches)
+	    (pattern-matches from to))
+	  (cond	(match-p 
+		 (push (string-downcase to) result)
+		 (cleanup-to from-context to-context result))
+		(wild-inf-flag
+		 (push (string-downcase to) result)
+		 (multiple-value-setq (from-context to-context result)
+		   (translate-dir-elements (pop from-context) from-context
+					   to to-context t)))
+		(t
+		 (throw 'next-translation nil))))
+	 (pattern
+	  (cond ((and (pattern= from to) wild-inf-flag)
+		 (push to result)
+		 (multiple-value-setq (from-context to-context result)
+		   (translate-dir-elements (pop from-context) from-context
+					   to to-context t)))
+		((pattern= from to)
+		 ;; Clean up, include any untranslated to leftovers.
+		 (push to result)
+		 (cleanup-to from-context to-context result))
+		(t
+		 (throw 'next-translation nil))))
+	 ((member :wild :wild-inferiors)
+	  (push to result)
+	  ;; Clean up, include any untranslated to leftovers.
+	  (cleanup-to from-context to-context result))))
+      ((member :wild)
+       ;; Clean up, include any untranslated to leftovers.
+       (push to result)
+       (cleanup-to from-context to-context result))
+      ((member :wild-inferiors)
+       (push to result)
+       (multiple-value-setq (from-context to-context result)
+	 (translate-dir-elements (pop from-context) from-context
+				 to to-context t))))
+    (values from-context to-context result)))
+
+;;; TRANSLATE-DIRECTORY-LISTS -- Internal
+;;;
+;;;   Translate through the lists of strings of subdirectories.
+;;;
+(defun translate-directory-lists (from to result)
+  (declare (type list from to result)) 
+  (let ((from-el (pop from))
+	(to-el (pop to))) 
+    (cond (from-el
+	   ;; There remains an untranslated element, translate it and the rest.
+	   (multiple-value-setq (from to result)
+	     (translate-dir-elements from-el from to-el to result))
+	   (translate-directory-lists from to result))
+	  (t ; Done.
+	   (setf result (reverse result))))))
 
-;;; INTERMEDIATE-REP -- Internal
+;;; TRANSLATE-LOGICAL-DIRECTORY  -- Internal
 ;;;
-(defun intermediate-rep (from to)
-  "A logical component transition function that translates from one argument
-   to the other. This function is specific to the CMUCL implementation."
-  (declare (type (or logical-host host simple-base-string pattern symbol list)
-		 from)
-	   (type (or logical-host host simple-base-string pattern symbol list)
-		 to)
-	   (values
-	    (or logical-host host simple-base-string pattern list symbol)))
-  (etypecase from
-    (logical-host
-     (if (or (host-p to) (logical-host-p to))
-	 to))
-    (host
-     (if (host-p to)
-	 to))
-    (simple-base-string 
-     (etypecase to
-       (pattern
-	(multiple-value-bind
-	    (won subs)
-	    (pattern-matches to from)
-	  (if won
-	      (values (substitute-into to subs))
-	      (error "String ~S failed to match pattern ~S" from to))))
-       (simple-base-string to)
-       ((member nil :wild :wild-inferiors) from)))
-    (pattern
-     (etypecase to
-       (pattern
-	(if (pattern= to from)
-	    to
-	    (error "Patterns ~S and ~S do not match.")))))
-    ((member :absolute :relative)
-     (if (eq to from)
-	 to
-	 (error "The directory bases (FROM = ~S, TO = ~S) for the logical ~%~
-		 pathname translation are not consistently relative or absolute." from to)))
-    ((member :wild)
-     (etypecase to
-       ((or string
-	    pattern
-	    (member nil :unspecific :newest :wild :wild-inferiors))
-	to)))
-    ((member :wild-inferiors) ; Only when single directory component.
-     (etypecase to
-       ((or string pattern cons (member nil :unspecific :wild :wild-inferiors))
-	to)))
-    ((member :unspecific nil)
-     from)
-    ((member :newest)
-     (case to
-       (:wild from)
-       (:unspecific :unspecific)
-       (:newest to)
-       ((member nil) from)))))
-    
-(proclaim '(inline translate-logical-component))
-
-;;; TRANSLATE-LOGICAL-COMPONENT -- Internal
+;;;   Translate logical directories within the UNIX hierarchical file system,
+;;; which does not directly support :wildcard-inferiors.  Here :wild-inferiors
+;;; are allowed in a restricted form. The translation table is based on matching
+;;; first the source (src) directory component with the from directory
+;;; components, and if successful constructing result directory components.
+;;; If this is successful, then the result is matched relative to the the to-dir
+;;; and a possible translated result is generated.
 ;;;
-(defun translate-logical-component (source from to)
-  (intermediate-rep (intermediate-rep source from) to))
+(defun translate-logical-directory (src-dirs from-dirs to-dirs)
+  (declare (type list src-dirs from-dirs to-dirs)
+	   (values list))
+  (let ((result-dirs nil)
+	(transl-dirs nil))
+    ;; Cope with possible null directory lists.
+    (cond ((and (null src-dirs) (null from-dirs))
+	   (return-from translate-logical-directory to-dirs))
+	  ((or (null src-dirs) (null from-dirs))
+	   (throw 'next-translation nil)))
+    ;; Compute the intermediate result by matching the source-dirs
+    ;; components with the from-dirs and placing the result in the result-dirs
+    ;; if the match is successful, otherwise throw to the next translation.
+    (setf result-dirs
+	  (translate-directory-lists (rest src-dirs) (rest from-dirs)
+				     result-dirs)
+	  transl-dirs
+	  (translate-directory-lists result-dirs (rest to-dirs)
+				     transl-dirs))
+    (setf result-dirs (translate-absolute-relative
+		       (first src-dirs) (first from-dirs) transl-dirs)) 
+    (if result-dirs
+	(push (translate-absolute-relative
+	       (first src-dirs) (first from-dirs) (first to-dirs))
+	      transl-dirs))
+    transl-dirs))
+
+;;; TRANSLATE-LOGICAL-COMP-ELEMENT -- Internal
+;;;
+(defun translate-logical-comp-element (from to)
+  (declare (type (or pattern simple-base-string fixnum symbol null) from to))
+  (let ((match-p nil)
+	(matches nil))
+    (typecase from
+      (simple-base-string 
+       (typecase to
+	 (simple-base-string
+	  (string-downcase to))
+	 (fixnum
+	  (throw 'next-translation nil))
+	 ((member :newest :wild nil)
+	  (string-downcase from))
+	 (pattern
+	  (multiple-value-setq (match-p matches)
+	    (pattern-matches to from))
+	  (if match-p
+	      (substitute-into to matches :case :lower)
+	      (throw 'next-translation nil)))))
+      (fixnum
+       (typecase to
+	 (fixnum
+	  (if (<= from to)
+	      to
+	      from))
+	 ((member :newest :wild nil)
+	  to)
+	 (pattern
+	  (case (first (pattern-pieces to))
+	    ((or :wild :newest) to)
+	    (t (throw 'next-translation nil))))))
+      ((member :wild :newest nil)
+       to)
+      (pattern
+       (typecase to
+	 (simple-base-string
+	  (multiple-value-setq (match-p matches)
+	    (pattern-matches from to))
+	  (if match-p
+	      (substitute-into from matches :case :lower)
+	      (throw 'next-translation nil)))
+	 (fixnum
+	  (case (first (pattern-pieces from))
+	    ((or :wild :newest) to)
+	    (t (throw 'next-translation nil))))
+	 ((member :newest :wild nil)
+	  to)
+	 (pattern
+	  (if (pattern= from to)
+	      to
+	      (throw 'next-translation nil))))))))
 
-;;; TRANSLATE-LOGICAL-DIRECTORY  -- Internal
+;;; TRANSLATE-LOGICAL-COMPONENT -- Internal
 ;;;
-;;;   Translate logical directories within the UNIX heirarchical file system.
-;;;
-(defun translate-logical-directory (source from to)
-  ;; Handle unfilled components.
-  (if (or (eql source :UNSPECIFIC)
-	  (eql from :UNSPECIFIC)
-	  (eql to :UNSPECIFIC))
-      (return-from translate-logical-directory :UNSPECIFIC))
-  (if (or (not source) (not from) (not to))
-      (return-from translate-logical-directory nil))
-  ;; Handle directory component abbreviated as a wildcard.
-  (if (member source '(:WILD :WILD-INFERIORS))
-      (setf source '(:ABSOLUTE :WILD-INFERIORS)))
-  (if (member source '(:WILD :WILD-INFERIORS))
-      (setf source '(:ABSOLUTE :WILD-INFERIORS)))
-  (if (member source '(:WILD :WILD-INFERIORS))
-      (setf to '(:ABSOLUTE :WILD-INFERIORS)))
-  ;; Make two stage translation, storing the intermediate results in ires
-  ;; and finally returned in the list rres.
-  (let ((ires nil)
-	(rres nil)
-	(dummy nil)
-	(slen (length source))
-	(flen (length from))
-	(tlen (length to)))
-    (do* ((i 0 (1+ i))
-	  (j 0 (1+ j))
-	  (k 0)
-	  (s-el (nth i source) (nth i source))
-	  (s-next-el nil)
-	  (f-el (nth j from) (nth j from)))
-	 ((<= slen i))
-      (cond ((eq s-el :wild-inferiors)
-	     (setf s-next-el (nth (+ 1 i) source)) ; NIL if beyond end.
-	     (cond ((setf k (position s-next-el from :start (1+ j)))
-		    ;; Found it, splice this portion into ires.
-		    (setf ires
-			  (append ires
-				  (subseq from j (1- k)))
-			  j (1- k)))
-		   (t
-		    ;; Either did not find next source element in from,
-		    ;; or was nil.
-		    (setf ires
-			  (append ires
-				  (subseq from j flen)))
-		    (unless (= i (1- slen))
-		      (error "Source ~S inconsistent with from translation ~
-			      ~S~%." source from)))))
-	    (t 
-	     (setf ires (append ires (list (intermediate-rep s-el f-el)))))))
-    ;; Remember to add leftover elements of from.
-    (if (< slen flen)
-	(setf ires (append ires (last from (- flen slen)))))
-    (do* ((i 0 (1+ i))
-	  (j 0 (1+ j))
-	  (k 0)
-	  (irlen (length ires))
-	  (ir-el (nth i ires) (nth i ires))
-	  (ir-next-el nil)
-	  (t-el (nth j to) (nth j to)))
-	 ((<= tlen i))
-      ;; Remember to add leftover elements of to.
-      (cond ((eq ir-el :wild-inferiors)
-	     (setf ir-next-el (nth (+ 1 i) ires)) ; NIL if beyond end.
-	     (cond ((setf k (position ir-next-el from :start (1+ j)))
-		    ;; Found it, splice this portion into rres.
-		    (setf rres
-			  (append rres
-				  (subseq from j (1- k)))
-		       j (1- k)))
-		   (t
-		    ;; Either did not find next source element in from,
-		    ;; or was nil.
-		    (setf rres
-			  (append rres
-				  (subseq from j tlen)))
-		    (unless (= i (1- irlen))
-		      (error "Intermediate path ~S inconsistent with to~
-			      translation ~S~%." ires to)))))
-	    (t (if (setf dummy (intermediate-rep ir-el t-el))
-		   (setf rres (append rres (list dummy)))))))
-    (if (< flen tlen)
-	(setf rres (append rres (last to (- tlen flen)))))
-    rres))
-
-;;; A physical-pathname is a pathname that does not contain any wildcards,
-;;; but is not a logical-pathname. 
-
-(deftype physical-pathname ()
-  '(and (satisfies pathnamep)
-	(not (or (satisfies wild-pathname-p)
-		 (satisfies logical-pathname-p)))))
+(defun translate-logical-component (src from to)
+  (declare (type (or pattern simple-base-string fixnum symbol null) from to))
+  (translate-logical-comp-element (translate-logical-comp-element src from) to))
 
 ;;; TRANSLATE-LOGICAL-PATHNAME  -- Public
 ;;;
 (defun translate-logical-pathname (pathname &key)
   "Translates pathname to a physical pathname, which is returned."
-  (declare (type logical-pathname pathname))
-  (with-pathname (source pathname)
-    (etypecase source
-      (physical-pathname source)
-      (logical-pathname 
-       (let ((source-host (%pathname-host source))
-	     (result-path nil))
-	 (unless (gethash
-		  (funcall (logical-host-unparse-host source-host) source)
-		  *logical-pathnames*)
+  (declare (type path-designator pathname)
+	   (values (or null pathname)))
+  (with-pathname (source pathname) 
+     (when (logical-pathname-p source)
+       (let ((p-host (%pathname-host source))
+	     (from nil)
+	     (to nil)
+	     (tr-host nil)
+	     (tr-dir nil)
+	     (tr-name nil)
+	     (tr-type nil)
+	     (tr-version nil)
+	     (result-path nil)
+	     (src-transl nil)
+	     (i 0))
+	 (declare (type fixnum i)
+		  (type (or pathname null) result-path))
+	 ;; Verify that the logical-host is defined.
+	 (unless (gethash (funcall (logical-host-unparse-host p-host) source)
+			  *logical-hosts*)
 	   (error "The logical host ~S is not defined.~%"
-				    (logical-host-name source-host)))
-	 (dolist (src-transl (logical-host-canon-transls source-host)
-			     (error "~S has no matching translation for ~
-				     logical host ~S.~%"
-				    pathname (logical-host-name source-host)))
-	   (when (pathname-match-p source (first src-transl))
-	     (macrolet ((frob (field)
-			  `(let* ((from (first src-transl))
-				  (to (second src-transl))
-				  (result (translate-logical-component
-					   (,field source)
-					   (,field from)
-					   (,field to))))
-				 result)))
-	       (setf result-path
-		     (%make-pathname (frob %pathname-host)
-				     :unspecific
-				     (let* ((from (first src-transl))
-					    (to (second src-transl))
-					    (result
-					     (translate-logical-directory
-					      (%pathname-directory source)
-					      (%pathname-directory from)
-					      (%pathname-directory to))))
-				       (if (eq result :error)
-					   (error "~S doesn't match ~S"
-						  source from)
-					   result))
-				     (frob %pathname-name)
-				     (frob %pathname-type)
-				     (frob %pathname-version))))
-	     (etypecase result-path
-	       (logical-pathname 
-		(translate-logical-pathname result-path))
-	       (physical-pathname
-		(return-from translate-logical-pathname result-path))))))))))
-
+		  (logical-host-name p-host)))
+	 ;; Scan the pathname translations, and if none is found signal error.
+	 (loop
+	   (catch 'next-translation
+	     (setf src-transl (nth i (logical-host-canon-transls p-host)))
+	     (incf i)
+	     (unless src-transl
+	       (error "~S has no matching translation for logical host ~S.~%"
+		      pathname (logical-host-name p-host)))
+	     (setf from (first src-transl)
+		   to (second src-transl))
+	     (when (pathname-match-p pathname from) 
+	       (setf tr-host (translate-logical-host
+			      p-host
+			      (%pathname-host from)
+			      (%pathname-host to))
+		     tr-dir (translate-logical-directory
+			     (%pathname-directory source)
+			     (%pathname-directory from)
+			     (%pathname-directory to))
+		     tr-name (translate-logical-component
+			      (%pathname-name source)
+			      (%pathname-name from)
+			      (%pathname-name to))
+		     tr-type (translate-logical-component
+			      (%pathname-type source)
+			      (%pathname-type from)
+			      (%pathname-type to))
+		     tr-version (translate-logical-component
+				 (%pathname-version source)
+				 (%pathname-version from)
+				 (%pathname-version to))
+		     result-path (%make-pathname tr-host
+						 :unspecific
+						 tr-dir
+						 tr-name
+						 tr-type
+						 tr-version))
+	       (etypecase result-path
+		 (logical-pathname 
+		  (translate-logical-pathname result-path))
+		 (pathname 
+		  (return-from translate-logical-pathname result-path))
+		 (null
+		  (error "The logical path ~S could not be translated."
+			 pathname))))))))))
 
 
 
-- 
GitLab