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

[mevenson at common-lisp.net]

Author: mevenson
Date: Thu Oct 11 04:33:26 2012
New Revision: 14179

Log:
Fix ASDF loading recursively from JAR-PATHNAME.

With this patch, JNA should (finally) load again.

The problem manifested itself when recursive loads of ASDF systems are
triggered for which the systems are stored in a jar archive but it
could also be triggered by setting *DEFAULT-PATHNAME-DEFAULTS* to a
JAR-PATHNAME.

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	Thu Oct 11 04:33:24 2012	(r14178)
+++ trunk/abcl/src/org/armedbear/lisp/asdf.lisp	Thu Oct 11 04:33:26 2012	(r14179)
@@ -3961,19 +3961,38 @@
          (setf output-truename nil failure-p t)))
       (values output-truename warnings-p failure-p))))
 
-#+abcl
+#+abcl 
 (defun* translate-jar-pathname (source wildcard)
   (declare (ignore wildcard))
-  (let* ((p (pathname (first (pathname-device source))))
-         (root (format nil "/___jar___file___root___/~@[~A/~]"
-                       (and (find :windows *features*)
-                            (pathname-device p)))))
-    (apply-output-translations
-     (merge-pathnames*
-      (relativize-pathname-directory source)
-      (merge-pathnames*
-       (relativize-pathname-directory (ensure-directory-pathname p))
-       root)))))
+  (let* ((jar 
+          (pathname (first (pathname-device source))))
+         (target-root-directory-namestring
+          (format nil "/___jar___file___root___/~@[~A/~]"
+                  (and (find :windows *features*)
+                       (pathname-device jar))))
+         (relative-source 
+          (relativize-pathname-directory source))
+         (relative-jar 
+          (relativize-pathname-directory (ensure-directory-pathname jar)))
+         (target-root-directory
+          (if (find :windows *features*)
+              (make-pathname :name nil
+                             :type nil
+                             :version nil
+                             :defaults (parse-namestring target-root-directory-namestring))
+              (make-pathname :device :unspecific 
+                             :name nil
+                             :type nil
+                             :version nil
+                             :defaults (parse-namestring target-root-directory-namestring))))
+         (target-root 
+          (merge-pathnames* relative-jar target-root-directory))
+         (target 
+          (merge-pathnames* relative-source target-root)))
+    (if (find :windows *features*)
+        (apply-output-translations target)
+        (make-pathname :defaults (apply-output-translations target)
+                       :device :unspecific))))
 
 ;;;; -----------------------------------------------------------------
 ;;;; Compatibility mode for ASDF-Binary-Locations