[armedbear-cvs] r13704 - in trunk/abcl: src/org/armedbear/lisp test/lisp/abcl

[mevenson at common-lisp.net]

Author: mevenson
Date: Sun Dec 18 13:08:13 2011
New Revision: 13704

Log:
Fix #181: TRUENAME doesn't always canonicalize the outer DEVICE component of JAR-PATHNAME.

If *DEFAULT-PATHNAME-DEFAULTS* is a JAR-PATHNAME, then TRUENAME will
not attempt to canonicalize the outer DEVICE component of a JAR-PATHNAME.

Remove corresponding kludge from ASDF.

Modified:
   trunk/abcl/src/org/armedbear/lisp/Pathname.java
   trunk/abcl/src/org/armedbear/lisp/asdf.lisp
   trunk/abcl/test/lisp/abcl/jar-pathname.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Pathname.java	Sun Dec 18 08:03:22 2011	(r13703)
+++ trunk/abcl/src/org/armedbear/lisp/Pathname.java	Sun Dec 18 13:08:13 2011	(r13704)
@@ -2179,9 +2179,18 @@
             // Possibly canonicalize jar file directory
             Cons jars = (Cons) pathname.device;
             LispObject o = jars.car();
-            if (o instanceof Pathname && ! (((Pathname)o).isURL())) {
+            if (o instanceof Pathname 
+                && !(((Pathname)o).isURL())
+                // XXX Silently fail to call truename() if the default
+                // pathname defaults exist within a jar, as that will
+                // (probably) not succeed.  The better solution would
+                // probably be to parametize the value of
+                // *DEFAULT-PATHNAME-DEFAULTS* on invocations of
+                // truename().
+                && !coerceToPathname(Symbol.DEFAULT_PATHNAME_DEFAULTS.symbolValue()).isJar()) 
+                {
                 LispObject truename = Pathname.truename((Pathname)o, errorIfDoesNotExist);
-                if (truename != null
+                if (truename != null && truename != NIL
                     && truename instanceof Pathname) {
                     Pathname truePathname = (Pathname)truename;
                     // A jar that is a directory makes no sense, so exit

Modified: trunk/abcl/src/org/armedbear/lisp/asdf.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/asdf.lisp	Sun Dec 18 08:03:22 2011	(r13703)
+++ trunk/abcl/src/org/armedbear/lisp/asdf.lisp	Sun Dec 18 13:08:13 2011	(r13704)
@@ -1650,11 +1650,6 @@
              (let ((*package* package)
                    (*default-pathname-defaults*
                     (pathname-directory-pathname pathname)))
-               ;;; XXX Kludge for ABCL ticket #181 
-               #+abcl
-               (when (ext:pathname-jar-p pathname) 
-                 (setf *default-pathname-defaults* 
-                       (make-pathname :device nil :defaults *default-pathname-defaults*)))
                (asdf-message (compatfmt "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%")
                              pathname package)
                (load pathname)))

Modified: trunk/abcl/test/lisp/abcl/jar-pathname.lisp
==============================================================================
--- trunk/abcl/test/lisp/abcl/jar-pathname.lisp	Sun Dec 18 08:03:22 2011	(r13703)
+++ trunk/abcl/test/lisp/abcl/jar-pathname.lisp	Sun Dec 18 13:08:13 2011	(r13704)
@@ -484,11 +484,15 @@
 ;;; ticket #181
 ;;; TODO Make reasons for failure more clear
 (deftest jar-pathname.truename.1
-    (let* ((abcl (slot-value (asdf:find-system 'abcl) 'asdf::absolute-pathname))
-           (jar (pathname (format nil "jar:file:~A/dist/abcl-contrib.jar!/jss/jss.asd" (namestring abcl))))
-           (jar-dir (make-pathname :defaults jar :name nil :type nil))
-           (defaults *default-pathname-defaults*))
-      (let ((*default-pathname-defaults* jar-dir))
-        (not (probe-file (merge-pathnames jar)))))
+    (let* ((abcl 
+            (slot-value (asdf:find-system 'abcl) 'asdf::absolute-pathname))
+           (jar-entry 
+            (pathname (format nil "jar:file:~A/dist/abcl-contrib.jar!/jss/jss.asd" (namestring abcl))))
+           (jar-entry-dir 
+            (make-pathname :defaults jar-entry :name nil :type nil))
+           (defaults 
+            *default-pathname-defaults*))
+      (let ((*default-pathname-defaults* jar-entry-dir))
+        (not (probe-file (merge-pathnames jar-entry)))))
   nil)
   
\ No newline at end of file