[armedbear-cvs] r14179 - trunk/abcl/src/org/armedbear/lisp
mevenson at common-lisp.net
mevenson at common-lisp.net
Thu Oct 11 11:33:27 UTC 2012
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
More information about the armedbear-cvs
mailing list