Changeset 14179

Timestamp:

10/11/12 11:33:26 (11 years ago)

Author:

Mark Evenson

Message:

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.

File:

• trunk/abcl/src/org/armedbear/lisp/asdf.lisp (modified) (1 diff)

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

@@ -3962 +3962 @@
       (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))))
 
 ;;;; -----------------------------------------------------------------