From 14edd4361144b7c4a20bc6d1753c36ca8ab84987 Mon Sep 17 00:00:00 2001
From: phg <phg>
Date: Wed, 19 Aug 1992 17:45:33 +0000
Subject: [PATCH] Logical pathname functions added to bring CMUCL up to the
 ANSI X3J13/92-102 standard.

---
 code/pathname.lisp | 957 ++++++++++++++++++++++++++++++++++++++++++---
 1 file changed, 896 insertions(+), 61 deletions(-)

diff --git a/code/pathname.lisp b/code/pathname.lisp
index 2a355fbe8..8a2b985bd 100644
--- a/code/pathname.lisp
+++ b/code/pathname.lisp
@@ -6,13 +6,14 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pathname.lisp,v 1.11 1992/06/01 16:24:22 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pathname.lisp,v 1.12 1992/08/19 17:45:33 phg Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
 ;;; Machine/filesystem independent pathname functions for CMU Common Lisp.
 ;;;
-;;; Written by William Lott
+;;; Written by William Lott, enhancements for logical-pathnames
+;;; written by Paul Gleichauf.
 ;;; Earlier version written by Jim Large and Rob MacLachlan
 ;;;
 ;;; **********************************************************************
@@ -224,14 +225,17 @@
   (cond (junk-allowed
 	 (handler-case (%parse-namestring namestr start end host 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)
+				   device
+				   directory
+				   file
+				   type
+				   version)
 		   end)))
 	(t
 	 (%parse-namestring (coerce namestr 'simple-string)
@@ -240,26 +244,54 @@
 (defun parse-namestring (thing
 			 &optional host (defaults *default-pathname-defaults*)
 			 &key (start 0) end junk-allowed)
-  (declare (type pathnamelike thing)
+  (declare (type (or simple-base-string stream pathname) thing)
 	   (type (or null host) host)
 	   (type pathnamelike defaults)
 	   (type index start)
 	   (type (or index null) end)
 	   (type (or null (not null)) junk-allowed)
-	   (values pathname index))
-  (if (stringp thing)
-      (%parse-namestring thing start (or end (length thing))
-			 (or host
-			     (with-pathname (defaults defaults)
-			       (%pathname-host defaults)))
-			 junk-allowed)
-      (with-pathname (pathname thing)
-	(when host
-	  (unless (eq host (%pathname-host pathname))
-	    (error "Hosts do not match: ~S and ~S."
-		   host
-		   (%pathname-host pathname))))
-	(values pathname start))))
+	   (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))))
 
 (defun pathname (thing)
   (declare (type pathnamelike thing))
@@ -291,7 +323,7 @@
 		    (dotimes (i (length in))
 		      (when (funcall pred (schar in i))
 			(return t))))
-		   ((member :unspecific)
+		   ((member :unspecific :up :absolute :relative)
 		    nil)))
 	       (diddle-with (fun thing)
 		 (etypecase thing
@@ -313,22 +345,28 @@
 			     (pattern-pieces thing))))
 		   (list
 		    (mapcar fun thing))
-		   (simple-base-string
-		    (funcall fun thing)))))
+		   (simple-base-string 
+		    (funcall fun thing))
+		   ((member :unspecific :up :absolute :relative)
+		    thing))))
 	(let ((any-uppers (check-for #'upper-case-p thing))
 	      (any-lowers (check-for #'lower-case-p thing)))
 	  (cond ((and any-uppers any-lowers)
 		 ;; Mixed case, stays the same.
 		 thing)
-	    (any-uppers
-	     ;; All uppercase, becomes all lower case.
-	     (diddle-with #'string-downcase thing))
-	    (any-lowers
-	     ;; All lowercase, becomes all upper case.
-	     (diddle-with #'string-upcase thing))
-	    (t
-	     ;; No letters?  I guess just leave it.
-	     thing))))
+		(any-uppers
+		 ;; All uppercase, becomes all lower case.
+		 (diddle-with #'(lambda (x) (if (stringp x)
+						(string-downcase x)
+						x)) thing))
+		(any-lowers
+		 ;; All lowercase, becomes all upper case.
+		 (diddle-with #'(lambda (x) (if (stringp x)
+						(string-upcase x)
+						x)) thing))
+		(t
+		 ;; No letters?  I guess just leave it.
+		 thing))))
       thing))
 
 (defun merge-directories (dir1 dir2 diddle-case)
@@ -393,7 +431,7 @@
 	 (cond ((eq piece :wild)
 		(results (make-pattern (list :multi-char-wild))))
 	       ((eq piece :wild-inferiors)
-		(error ":WILD-INFERIORS not supported."))
+		(results piece))
 	       ((member piece '(:up :back))
 		(results piece))
 	       ((or (simple-string-p piece) (pattern-p piece))
@@ -423,8 +461,8 @@
 	   (type (member nil :unspecific) device)
 	   (type (or list string pattern (member :wild)) directory)
 	   (type (or null string pattern (member :wild)) name)
-	   (type (or null string pattern (member :wild)) type)
-	   (type (or null integer (member :wild :newest)) version)
+	   (type (or null string pattern (member :unspecific :wild)) type)
+	   (type (or null integer (member :unspecific :wild :newest)) version)
 	   (type (or pathnamelike null) defaults)
 	   (type (member :common :local) case))
   (let* ((defaults (if defaults
@@ -523,14 +561,18 @@
     (%pathname-version pathname)))
 
 (defun namestring (pathname)
+  "Construct the full (name)string form of the pathname."
   (declare (type pathnamelike pathname))
   (with-pathname (pathname pathname)
     (let ((host (%pathname-host pathname)))
-      (if host
-	  (funcall (host-unparse host) pathname)
-	  (error
-	   "Cannot determine the namestring for pathnames with no host:~%  ~S"
-	   pathname)))))
+      (cond ((logical-host-p host)
+	     (funcall (logical-host-unparse host) pathname))
+	    ((host-p host)
+	     (funcall (host-unparse host) pathname))
+	    (t
+	     (error
+	      "Cannot determine the namestring for pathnames with no ~
+	       host:~%  ~S" pathname))))))
 
 (defun host-namestring (pathname)
   (declare (type pathnamelike pathname))
@@ -658,42 +700,74 @@
 	  (matches (pattern-pieces pattern) 0 nil nil nil)
 	(values won (reverse subs))))))
 
-(defun components-match (this that)
-  (or (eq this that)
-      (typecase this
-	(simple-string
-	 (typecase that
+(defun components-match (from to)
+  "Wilds in to are matched against from where both are either lists containing
+   :wild and :wild-inferiors, patterns or strings. FROM = :WILD-INFERIORS or
+   :WILD handled separately for directory component. Not communative."
+  (or (eq from to)
+      (typecase from
+	(simple-base-string
+	 (typecase to
 	   (pattern
-	    (values (pattern-matches that this)))
-	   (simple-string
-	    (string= this that))))
+	    (values (pattern-matches to from)))
+	   (simple-base-string
+	    (string-equal from to))))
 	(pattern
-	 (and (pattern-p that)
-	      (pattern= this that)))
-	(cons
-	 (and (consp that)
-	      (components-match (car this) (car that))
-	      (components-match (cdr this) (cdr that))))
+	 (and (pattern-p to) (pattern= from to)))
+	((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 :wild :wild-inferiors))))
+	(cons ; Watch for wildcards.
+	 (and (consp from)
+	      (let ((from1 (first from))
+		    (from2 nil)
+		    (to1 (first to)))
+		(typecase from1
+		  ((member :wild)
+		   (or (stringp to1)
+		       (pattern-p to1)
+		       (not to1)
+		       (eq to1 ':unspecific)))
+		  ((member :wild-inferiors)
+		   (setf from2 (second from))
+		   (cond ((not from2)
+			  ;; Nothing left of from, hence anything else in to
+			  ;; matches :wild-inferiors. 
+			  t)
+			 ((components-match
+			   (rest (rest from))
+			   (rest (member from2 to :test #'equal))))))
+		  (keyword ; :unspecific, :up, :back
+		   (and (keywordp to1)
+			(eq from1 to1)
+			(components-match (rest from) (rest to))))
+		  (string
+		   (and (stringp to1)
+			(string-equal from1 to1)
+			(components-match (rest from) (rest to))))))))
 	((member :back :up :unspecific nil)
-	 (and (pattern-p that)
-	      (equal (pattern-pieces that) '(:multi-char-wild)))))))
+	 (and (pattern-p from)
+	      (equal (pattern-pieces from) '(:multi-char-wild)))))))
 
 (defun pathname-match-p (pathname wildname)
+  "Pathname matches the wildname template?"
   (with-pathname (pathname pathname)
     (with-pathname (wildname wildname)
       (macrolet ((frob (field)
 		   `(or (null (,field wildname))
-			(components-match (,field pathname)
-					  (,field wildname)))))
+			(components-match (,field wildname)
+					  (,field pathname)))))
 	(and (frob %pathname-host)
 	     (frob %pathname-device)
 	     (frob %pathname-directory)
 	     (frob %pathname-name)
 	     (frob %pathname-type)
 	     (or (null (%pathname-version wildname))
-	       (eq (%pathname-version wildname) :wild)
-	       (eql (%pathname-version pathname)
-		    (%pathname-version wildname))))))))
+		 (eq (%pathname-version wildname) :wild)
+		 (eql (%pathname-version pathname)
+		      (%pathname-version wildname))))))))
 
 (defun substitute-into (pattern subs)
   (declare (type pattern pattern)
@@ -1033,3 +1107,764 @@
 						       (append expansion
 							       tail)))
 				  function)))))))
+
+
+;;;;  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 ':lower)))
+  (name "" :type simple-string)
+  (translations nil :type list)
+  (canon-transls nil :type list))
+
+(deftype logical-pathname ()
+  '(satisfies logical-pathname-p))
+
+(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))
+
+(define-condition logical-namestring-parse-error (error)
+  ((complaint :init-form (required-argument))
+   (arguments :init-form nil)
+   (namestring :init-form (required-argument))
+   (offset :init-form (required-argument)))
+  (:report %print-namestring-parse-error))
+
+(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))
+  (collect ((pattern))
+    (let ((last-regular-char nil)
+	  (look-ahead+1 nil)
+	  (index start)
+	  (char nil))
+      (flet ((flush-pending-regulars ()
+	       (when last-regular-char
+		 (pattern (subseq namestr last-regular-char index))
+		 (setf last-regular-char nil))))
+	(loop
+	  (when (>= index end)
+		(return)) 
+	  (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.
+		 (unless last-regular-char
+		   (setf last-regular-char index)))
+		((char= #\* char) ; Wildcard word, :wild or wildcard-inferior.
+		 (if (<= end index)
+		     (setf look-ahead+1 nil)
+		     (setf look-ahead+1 (schar namestr (1+ index))))
+		 (cond ((or (char= #\. look-ahead+1)
+			    (char= #\; look-ahead+1))
+			(flush-pending-regulars)
+			(pattern :wild)
+			(incf index)) ; skip * and ;
+		       ((and (char= #\* look-ahead+1)
+			     (char= #\; (schar namestr (+ 2 index))))
+			(pattern :wild-inferiors)
+			(setq last-regular-char nil)
+			(incf index 2)) ; skip ** and ;
+		       (t ; wildcard-word, keep going
+			(flush-pending-regulars)
+			(pattern :wild)
+			(incf index)
+			(unless last-regular-char
+			  (setf last-regular-char index))
+			)))
+		(t (error "Incorrect logical pathname syntax.")))
+	  (incf index))
+	(flush-pending-regulars))
+    (cond ((null (pattern))
+	   "")
+	  ((and (null (cdr (pattern)))
+		(simple-string-p (car (pattern))))
+	   (car (pattern)))
+	  ((= 1 (length (pattern)))
+	   (let ((elmt (first (pattern))))
+	     (if (or (eq elmt ':wild) (eq elmt ':wild-inferiors))
+		 elmt)))
+	  (t
+	   (make-pattern (pattern)))))))
+
+(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))))
+
+;;; parse-namestring and merge-pathnames must be upgraded to include
+;;; logical-namestrings, as required by the ANSI spec.
+
+;;; A large set of functions must be upgraded to accept logical-pathnames,
+;;; even if they do not accept logical-pathname strings.
+
+(defun extract-logical-name-type-and-version (namestr start end)
+  (declare (type simple-base-string namestr)
+	   (type index start end))
+  (let* ((last-dot (position #\. namestr :start (1+ start) :end end
+			     :from-end t))
+	 (second-to-last-dot (and last-dot
+				  (position #\. namestr :start (1+ start)
+					    :end last-dot :from-end t)))
+	 (version :newest))
+    ;; If there is a second-to-last dot, check to see if there is a valid
+    ;; version after the last dot.
+    (when second-to-last-dot
+      (cond ((and (= (+ last-dot 2) end)
+		  (char= (schar namestr (1+ last-dot)) #\*))
+	     (setf version :wild))
+	    ((and (< (1+ last-dot) end)
+		  (do ((index (1+ last-dot) (1+ index)))
+		      ((= index end) t)
+		    (unless (char<= #\0 (schar namestr index) #\9)
+		      (return nil))))
+	     (setf version
+		   (parse-integer namestr :start (1+ last-dot) :end end)))
+	    (t
+	     (setf second-to-last-dot nil))))
+    (cond (second-to-last-dot
+	   (values (maybe-make-logical-pattern
+		    namestr start second-to-last-dot)
+		   (maybe-make-logical-pattern
+		    namestr (1+ second-to-last-dot) last-dot)
+		   version))
+	  (last-dot
+	   (values (maybe-make-logical-pattern namestr start last-dot)
+		   (maybe-make-logical-pattern namestr (1+ last-dot) end)
+		   version))
+	  (t
+	   (values (maybe-make-logical-pattern namestr start end)
+		   nil
+		   version)))))
+
+(declaim (inline copy-string))
+
+(defun copy-string (str start end)
+  (declare (type simple-base-string str)
+	   (type index start end)
+	   (values simple-base-string))
+  (let* ((bnd (- end start))
+	 (len (length str))
+	 (res (make-string bnd)))
+    (if (and (<= start end) (<= bnd len))
+	(dotimes (i bnd res)
+	  (setf (schar res i) (schar str i)))
+	(error "Cannot copy string ~S given the bounds ~D,~D" str start end))))
+
+(defun logical-word-p (word)
+  (declare (type simple-base-string word)
+	   (values boolean))
+  (let ((ch nil))
+    (dotimes (i (length word))
+      (setf ch (schar word i))
+      (unless (or (alphanumericp ch) (eq ch #\-))
+	(return-from logical-word-p nil))))
+  t)
+
+(defun maybe-extract-logical-host (namestr start end)
+  "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."
+  (declare (type simple-base-string namestr)
+	   (type index start)
+	   (type index start end)
+	   (values (or (member :wild) simple-base-string null) (or null index)))
+  (let ((colon-pos (position #\: namestr :start start :end end)))
+    (if colon-pos
+	(let ((host (copy-string namestr start colon-pos)))
+	  (cond ((logical-word-p host)
+		 (return-from maybe-extract-logical-host
+			      (values (string-upcase host) (1+ colon-pos))))
+		((string= host "*")
+		 (return-from maybe-extract-logical-host
+			      (values ':wild (1+ colon-pos))))))
+	;; Implied host
+	(values nil 0))))
+
+(defun parse-logical-namestring (namestr start end)
+  "Break up a logical-namestring into its constituent parts."
+  (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)))))
+
+(defun unparse-logical-directory-list (directory)
+  (declare (type list directory))
+  (collect ((pieces))
+	   (when directory
+	     (ecase (pop directory)
+	       (:absolute
+		;; Nothing special.
+		)
+	       (:relative
+		(pieces ";")
+		))
+	     (dolist (dir directory)
+	       (cond ((or (stringp dir) (pattern-p dir))
+		      (pieces (unparse-logical-piece dir))
+		      (pieces ";"))
+		     ((eq dir ':wild)
+		      (pieces "*;"))
+		     ((eq dir ':wild-inferiors)
+		      (pieces "**;"))
+		     (t
+		      (error "Invalid directory component: ~S" dir)))))
+	   (apply #'concatenate 'simple-string (pieces))))
+
+(defun unparse-logical-directory (pathname)
+  (declare (type pathname pathname))
+  (unparse-logical-directory-list (%pathname-directory pathname)))
+
+(defun unparse-logical-piece (thing)
+  (etypecase thing
+    (simple-string
+     (let* ((srclen (length thing))
+	    (dstlen srclen))
+       (dotimes (i srclen)
+	 (case (schar thing i)
+	   (#\*
+	    (incf dstlen))))
+       (let ((result (make-string dstlen))
+	     (dst 0))
+	 (dotimes (src srclen)
+	   (let ((char (schar thing src)))
+	     (case char
+	       (#\*
+		(setf (schar result dst) #\\)
+		(incf dst)))
+	     (setf (schar result dst) char)
+	     (incf dst)))
+	 result)))
+    (pattern
+     (collect ((strings))
+	      (dolist (piece (pattern-pieces thing))
+		(typecase piece
+		  (simple-string
+		   (strings piece))
+		  (keyword
+		   (cond ((eq piece ':wild-inferiors)
+			  (strings "**"))
+			 ((eq piece ':wild)
+			  (strings "*"))
+			 (t (error "Invalid keyword: ~S" piece))))
+		  (t
+		   (error "Invalid pattern piece: ~S" piece))))
+	      (apply #'concatenate
+		     'simple-string
+		     (strings))))))
+
+(defun unparse-logical-file (pathname)
+  (declare (type pathname pathname))
+  (declare (type pathname pathname))
+  (unparse-unix-file pathname))
+
+(defun unparse-logical-host (pathname)
+  (declare (type logical-pathname pathname))
+  (logical-host-name (%pathname-host pathname)))
+  
+(defun unparse-logical-namestring (pathname)
+  (declare (type logical-pathname pathname))
+  (concatenate 'simple-string
+	       (unparse-logical-host pathname) ":"
+	       (unparse-logical-directory pathname)
+	       (unparse-logical-file pathname)))
+
+;;; Logical-pathname must signal a type 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)
+	   (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))))
+
+
+(defun translations-test-p (transl-list host)
+  "Verify that the list of translations consists of lists and prepare
+   canonical translations from the pathnames."
+  (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)
+    (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)))
+	 ((<= (length transl-list) i))
+      (setf c-tr (make-list 2))
+      (if (logical-pathname-p from-path)
+	(setf (first c-tr) from-path)
+	(setf (first c-tr) (parse-namestring from-path host)))
+      (if (pathnamep to-path)
+	  (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))
+		   (second c-tr))
+	(return-from translations-test-p nil))		       
+      (setf (nth i can-transls) c-tr)))
+  (setf (logical-host-translations host) transl-list)
+  t)
+
+(defun logical-pathname-translations (host)
+  "Return the (logical) host object argument's list of translations."
+  (declare (type (or simple-base-string logical-host) host)
+	   (values list))
+  (etypecase host
+    (simple-string
+     (setf host (string-upcase host))
+     (let ((host-struc (gethash host *logical-pathnames*)))
+       (if host-struc
+	   (logical-host-translations host-struc)
+	   (error "HOST ~S is not defined." host))))
+    (logical-host
+     (logical-host-translations host))))
+
+(defun (setf logical-pathname-translations) (translations host)
+  "Set the translations list for the logical host argument.
+   Return translations."
+  (declare (type (or simple-base-string logical-host) host)
+	   (type list translations)
+	   (values list))
+  (typecase host 
+    (simple-base-string
+     (setf host (string-upcase host))
+     (multiple-value-bind
+	 (hash-host xst?)
+	 (gethash host *logical-pathnames*)
+       (unless xst?
+	 (intern-logical-host host)
+	 (setf hash-host (gethash host *logical-pathnames*)))
+       (unless (translations-test-p translations hash-host)
+	 (error "Translations ~S is not a list of pairs of from-, ~
+		 to-pathnames." translations)))
+     translations)
+    (t
+     (unless (translations-test-p translations host)
+       (error "Translations ~S is not a list of pairs of from-, ~
+	       to-pathnames." translations))
+     translations)))
+
+;;; The search mechanism for loading pathname translations uses the CMUCL
+;;; extension of search-lists.  The user can add to the library: search-list
+;;; using setf.  The file for translations should have the name defined by
+;;; the host name (a string) and with type component "translations".
+
+(defun save-logical-pathname-translations (host directory)
+  "Save the translations for host in the file named host in
+   the directory argument. This is an internal convenience function and
+   not part of the ANSI standard."
+  (declare (type simple-base-string host directory))
+  (setf host (string-upcase host))
+  (let* ((p-name (make-pathname :directory (%pathname-directory
+					    (pathname directory))
+				:name host
+				:type "translations"
+				:version :newest))
+	 (new-stuff (gethash host *logical-pathnames*))
+	 (new-transl (logical-host-translations new-stuff)))
+	(with-open-file (out-str p-name
+				 :direction :output
+				 :if-exists :new-version
+				 :if-does-not-exist :create)
+	  (write new-transl :stream out-str)
+	  (format t "Created a new version of the file:~%   ~
+		     ~S~% ~
+		     containing logical-pathname translations:~%   ~
+		     ~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.
+
+(progn
+  (intern-logical-host "SYS")
+  (save-logical-pathname-translations "SYS" "library:"))
+
+(defun load-logical-pathname-translations (host)
+  "Search for a logical pathname named host, if not already defined. If already
+   defined no attempt to find or load a definition is attempted and NIL is
+   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))
+  (setf host (string-upcase host))
+  (let ((p-name nil)
+	(p-trans nil))
+    (multiple-value-bind
+	(log-host xst?)
+	(gethash host *logical-pathnames*)
+      (if xst?
+	  ;; host already has a set of defined translations.
+	  (return-from load-logical-pathname-translations nil)
+	  (enumerate-search-list (p "library:")
+ 	     (setf p-name (make-pathname :host (%pathname-host p)
+					 :directory (%pathname-directory p)
+					 :device (%pathname-device p)
+					 :name host
+					 :type "translations"
+					 :version :newest))
+	     (if (member p-name (directory p) :test #'pathname=)
+		 (with-open-file (in-str p-name
+					 :direction :input
+					 :if-does-not-exist :error)
+		   (setf p-trans (read in-str))
+		   (setf log-host (intern-logical-host host))
+		   (format t ";; Loading ~S~%" p-name)
+		   (unless (translations-test-p p-trans log-host)
+		     (error "Translations ~S is not a list of pairs of from-, ~
+			     to-pathnames." p-trans))
+		   (format t ";; Loading done.~%")
+		   (return-from load-logical-pathname-translations t))))))))
+
+(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))))
+
+(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)))
+
+(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 copy-sublist))
+
+(defun translate-logical-component (source from to)
+  (intermediate-rep (intermediate-rep source from) to))
+
+(defun copy-sublist (lst &key start end)
+  (let* ((res (make-list (- end start))))
+    (do ((i start (1+ start))
+	 (j 0 (1+ j)))
+	((<= start i))
+      (setf (nth j res) (nth i lst)))
+    res))
+
+(defun translate-logical-directory (source from to)
+  "Translate logical directories within the UNIX heirarchical file system."
+  ;; 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.
+	     (if (setf k (position s-next-el from :start (1+ j)))
+		 ;; Found it, splice this portion into ires.
+		 (setf ires
+		       (append ires
+			       (copy-sublist from :start j :end (1- k)))
+		       j (1- k))
+		 (progn
+		   ;; Either did not find next source element in from,
+		   ;; or was nil.
+		   (setf ires
+			 (append ires
+				 (copy-sublist from :start j :end 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.
+	     (if (setf k (position ir-next-el from :start (1+ j)))
+		 ;; Found it, splice this portion into rres.
+		 (setf rres
+		       (append rres
+			       (copy-sublist from :start j :end (1- k)))
+		       j (1- k))
+		 (progn
+		   ;; Either did not find next source element in from,
+		   ;; or was nil.
+		   (setf rres
+			 (append rres
+				 (copy-sublist from :start j :end 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))
+
+(deftype physical-pathname ()
+  '(not (or (satisfies wild-pathname-p)
+	    (satisfies logical-pathname-p))))
+
+(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*)
+	   (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))))))))))
+
+
+
+
-- 
GitLab