From 6de3f186707882e06fda8f9809b8ff4accac0879 Mon Sep 17 00:00:00 2001
From: toy <toy>
Date: Wed, 16 Oct 2002 14:01:01 +0000
Subject: [PATCH] Port over SBCL's fix for the Entomotomy bug

host-namestring-return-value-unusable
logical-pathnames-not-externalizable

host-namestring returns "" for physical pathnames when it used to
return "Unix".  But "Unix" is a valid logical host name and "" is not.

Logical pathnames weren't externalizable.  Make them so.
---
 code/filesys.lisp  |  7 +++--
 code/pathname.lisp | 68 ++++++++++++++++++++++++++++++++++++++++++----
 2 files changed, 68 insertions(+), 7 deletions(-)

diff --git a/code/filesys.lisp b/code/filesys.lisp
index 5a2ffedb7..9a1b3c3d5 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.68 2002/10/02 13:36:48 toy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/filesys.lisp,v 1.69 2002/10/16 14:01:01 toy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -334,7 +334,10 @@
 (defun unparse-unix-host (pathname)
   (declare (type pathname pathname)
 	   (ignore pathname))
-  "Unix")
+  ;; this host designator needs to be recognized as a physical host in
+  ;; PARSE-NAMESTRING. Until sbcl-0.7.3.x, we had "Unix" here, but
+  ;; that's a valid Logical Hostname, so that's a bad choice. -- CSR,
+  "")
 
 (defun unparse-unix-piece (thing)
   (etypecase thing
diff --git a/code/pathname.lisp b/code/pathname.lisp
index 6a40230c2..7e0645b8c 100644
--- a/code/pathname.lisp
+++ b/code/pathname.lisp
@@ -4,7 +4,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pathname.lisp,v 1.56 2002/08/12 20:56:10 toy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pathname.lisp,v 1.57 2002/10/16 14:01:01 toy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -68,11 +68,16 @@
 		      (:unparse-directory #'unparse-logical-directory)
 		      (:unparse-file #'unparse-unix-file)
 		      (:unparse-enough #'unparse-enough-namestring)
-		      (:customary-case :upper)))
+		      (:customary-case :upper))
+	    (:make-load-form-fun make-logical-host-load-form-fun))
   (name "" :type simple-base-string)
   (translations nil :type list)
   (canon-transls nil :type list))
 
+(defun make-logical-host-load-form-fun (logical-host)
+  (values `(find-logical-host ',(logical-host-name logical-host))
+	  nil))
+
 ;;; The various magic tokens that are allowed to appear in pretty much all
 ;;; pathname components.
 ;;;
@@ -657,7 +662,8 @@ a host-structure or string."
 	 ;; HS is silent on what happens if the :host arg is NOT one of these.
 	 ;; It seems an error message is appropriate.
 	 (host (typecase host
-		 (host host) 		; A valid host, use it. 
+		 (host host) 		; A valid host, use it.
+		 ((string 0) default-host) ; "" cannot be a logical host
 		 (string (find-logical-host host t)) ; logical-host or lose.
 		 (t default-host)))	; unix-host
 	 (diddle-args (and (eq (host-customary-case host) :lower)
@@ -866,10 +872,62 @@ a host-structure or string."
    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 string host) host)
+	   (type (or list string host (member :unspecific)) host)
 	   (type pathname defaults)
 	   (type index start)
 	   (type (or index null) end))
+  ;; Generally, redundant specification of information in software,
+  ;; whether in code or in comments, is bad. However, the ANSI spec
+  ;; for this is messy enough that it's hard to hold in short-term
+  ;; memory, so I've recorded these redundant notes on the
+  ;; implications of the ANSI spec.
+  ;; 
+  ;; According to the ANSI spec, HOST can be a valid pathname host, or
+  ;; a logical host, or NIL.
+  ;;
+  ;; A valid pathname host can be a valid physical pathname host or a
+  ;; valid logical pathname host.
+  ;; 
+  ;; A valid physical pathname host is "any of a string, a list of
+  ;; strings, or the symbol :UNSPECIFIC, that is recognized by the
+  ;; implementation as the name of a host". In SBCL as of 0.6.9.8,
+  ;; that means :UNSPECIFIC: though someday we might want to
+  ;; generalize it to allow strings like "RTFM.MIT.EDU" or lists like
+  ;; '("RTFM" "MIT" "EDU"), that's not supported now.
+  ;; 
+  ;; A valid logical pathname host is a string which has been defined as
+  ;; the name of a logical host, as with LOAD-LOGICAL-PATHNAME-TRANSLATIONS.
+  ;; 
+  (let ((host (etypecase host
+		((string 0)
+		 ;; This is a special host. It's not valid as a
+		 ;; logical host, so it is a sensible thing to
+		 ;; designate the physical Unix host object. So
+		 ;; we do that.
+		 *unix-host*)
+		(string
+		 ;; In general ANSI-compliant Common Lisps, a
+		 ;; string might also be a physical pathname host,
+		 ;; but ANSI leaves this up to the implementor,
+		 ;; and in CMUCL we don't do it, so it must be a
+		 ;; logical host.
+		 (find-logical-host host))
+		((or null (member :unspecific))
+		 ;; CLHS says that HOST=:UNSPECIFIC has
+		 ;; implementation-defined behavior. We
+		 ;; just turn it into NIL.
+		 nil)
+		(list
+		 ;; ANSI also allows LISTs to designate hosts,
+		 ;; but leaves its interpretation
+		 ;; implementation-defined. Our interpretation
+		 ;; is that it's unsupported.:-|
+		 (error "A LIST representing a pathname host is not ~
+                              supported in this implementation:~%  ~S"
+			host))
+		(host
+		 host))))
+    (declare (type (or null host) host))
     (etypecase thing
       (simple-string
        (%parse-namestring thing host defaults start end junk-allowed))
@@ -887,7 +945,7 @@ a host-structure or string."
 	 (unless name
 	   (error "Can't figure out the file associated with stream:~%  ~S"
 		  thing))
-	 (values name nil)))))
+	 (values name nil))))))
 
 
 ;;; NAMESTRING -- Interface
-- 
GitLab