[armedbear-cvs] r12644 - trunk/abcl/src/org/armedbear/lisp

[Mark Evenson]

Author: mevenson
Date: Sat May  1 13:45:49 2010
New Revision: 12644

Log:
Fix for loading ASDF systems from jar files under win32.

Changed synthetic '/:jar:file:/' path into the hopefully never used
'/___jar___file___root___/' string which doesn't turn out to be a
relative pathname under Windows (thanks to Carlos Ungil).

Add Windows drive letter to output translation path to allow
identically named jars on different drives to be handled.



Modified:
   trunk/abcl/src/org/armedbear/lisp/asdf.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/asdf.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/asdf.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/asdf.lisp	Sat May  1 13:45:49 2010
@@ -2516,7 +2516,7 @@
     #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; only needed if LPNs are resolved manually.
     #+clozure (,(wilden (ccl::ccl-directory)) ()) ; not needed: no precompiled ASDF system
     #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
-    #+abcl (#p"/:jar:file/**/*.*" (:user-cache #p"**/*.*"))
+    #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*"))
     ;; All-import, here is where we want user stuff to be:
     :inherit-configuration
     ;; If we want to enable the user cache by default, here would be the place:
@@ -2706,14 +2706,20 @@
 #+abcl
 (defun translate-jar-pathname (source wildcard)
   (declare (ignore wildcard))
-  (let ((root (apply-output-translations
-               (concatenate 'string
-                            "/:jar:file/"
-                            (namestring (first (pathname-device
-                                                source))))))
-        (entry (make-pathname :directory (pathname-directory source)
-                              :name (pathname-name source)
-                              :type (pathname-type source))))
+  (let* ((p (first (pathname-device source)))
+	 (r (concatenate 'string  
+			 (if (and (find :windows *features*) 
+				  (not (null (pathname-device p))))
+			     (format nil "~A/" (pathname-device p))
+			     "")
+			 (namestring (make-pathname :directory (pathname-directory p)
+						    :name (pathname-name p)
+						    :type (pathname-type p)))))
+	 (root (apply-output-translations
+		(format nil "/___jar___file___root___/~A" r)))
+	 (entry (make-pathname :directory (pathname-directory source)
+			       :name (pathname-name source)
+			       :type (pathname-type source))))
     (concatenate 'string (namestring root) (namestring entry))))
 
 ;;;; -----------------------------------------------------------------