From a002ef9e8c158602a7a1eea06cc87444178d28de Mon Sep 17 00:00:00 2001
From: rtoy <rtoy>
Date: Tue, 18 May 2004 13:24:42 +0000
Subject: [PATCH] Upcase path components when given a logical pathname. 
 Preserves print/read consistency and fixes (I think) an issue with ASDF and
 logical pathnames

---
 code/pathname.lisp | 20 ++++++++++++++++++--
 1 file changed, 18 insertions(+), 2 deletions(-)

diff --git a/code/pathname.lisp b/code/pathname.lisp
index e44ed5b77..06bb46140 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.64 2004/04/01 16:26:35 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pathname.lisp,v 1.65 2004/05/18 13:24:42 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -199,7 +199,23 @@
 
 (defun %make-pathname-object (host device directory name type version)
   (if (typep host 'logical-host)
-      (%make-logical-pathname host :unspecific directory name type version)
+      (flet ((upcasify (thing)
+	       (typecase thing
+		 (list
+		  (mapcar #'(lambda (x)
+			      (if (stringp x)
+				  (string-upcase x)
+				  x))
+			  thing))
+		 (simple-base-string
+		  (string-upcase thing))
+		 (t
+		  thing))))
+	(%make-logical-pathname host :unspecific
+				(upcasify directory)
+				(upcasify name)
+				(upcasify type)
+				(upcasify version)))
       (%make-pathname         host device      directory name type version)))
 
 ;;; *LOGICAL-HOSTS* --internal.
-- 
GitLab