[armedbear-cvs] r13718 - in branches/1.0.x/abcl: src/org/armedbear/lisp test/lisp/abcl

[mevenson at common-lisp.net]

Author: mevenson
Date: Wed Jan  4 13:51:15 2012
New Revision: 13718

Log:
backport r13704: Fix problems loading ABCL-CONTRIB.

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

Modified: branches/1.0.x/abcl/src/org/armedbear/lisp/Pathname.java
==============================================================================
--- branches/1.0.x/abcl/src/org/armedbear/lisp/Pathname.java	Wed Jan  4 13:48:45 2012	(r13717)
+++ branches/1.0.x/abcl/src/org/armedbear/lisp/Pathname.java	Wed Jan  4 13:51:15 2012	(r13718)
@@ -2169,9 +2169,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: branches/1.0.x/abcl/src/org/armedbear/lisp/asdf.lisp
==============================================================================
--- branches/1.0.x/abcl/src/org/armedbear/lisp/asdf.lisp	Wed Jan  4 13:48:45 2012	(r13717)
+++ branches/1.0.x/abcl/src/org/armedbear/lisp/asdf.lisp	Wed Jan  4 13:51:15 2012	(r13718)
@@ -1653,11 +1653,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: branches/1.0.x/abcl/test/lisp/abcl/jar-pathname.lisp
==============================================================================
--- branches/1.0.x/abcl/test/lisp/abcl/jar-pathname.lisp	Wed Jan  4 13:48:45 2012	(r13717)
+++ branches/1.0.x/abcl/test/lisp/abcl/jar-pathname.lisp	Wed Jan  4 13:51:15 2012	(r13718)
@@ -481,8 +481,17 @@
 			"/foo/**/*.*")
   #p"/foo/d/e/f.lisp")
 
-      
-
-        
-
-  
+;;; 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-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)