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

[mevenson at common-lisp.net]

Author: mevenson
Date: Fri Nov  9 08:07:08 2012
New Revision: 14238

Log:
Fixes #243: MAKE-PATHNAME with a DEVICE string.

We allow DEVICE lists to contain a string value as constructed by
MAKE-PATHNAME, but the result can never actually be resolvable by
TRUENAME.

Instead of trying to figure out the proper use of Java labels, just
use the private static Pathname.doTruenameExit() as the common point
for all exits from the TRUENAME implementation.

Modified:
   trunk/abcl/src/org/armedbear/lisp/Pathname.java
   trunk/abcl/test/lisp/abcl/bugs.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Pathname.java	Fri Nov  9 07:15:03 2012	(r14237)
+++ trunk/abcl/src/org/armedbear/lisp/Pathname.java	Fri Nov  9 08:07:08 2012	(r14238)
@@ -654,11 +654,15 @@
             StringBuilder prefix = new StringBuilder();
             for (int i = 0; i < jars.length; i++) {
                 prefix.append("jar:");
-                if (!((Pathname)jars[i]).isURL() && i == 0) {
+		LispObject component = jars[i];
+		if (!(component instanceof Pathname)) {
+		   return null; // If DEVICE is a CONS, it should only contain Pathname 
+		}
+                if (! ((Pathname)component).isURL() && i == 0) {
                     sb.append("file:");
                     uriEncoded = true;
                 }
-                Pathname jar = (Pathname) jars[i];
+                Pathname jar = (Pathname) component;
                 String encodedNamestring;
                 if (uriEncoded) {
                     encodedNamestring = uriEncode(jar.getNamestring());
@@ -2152,14 +2156,8 @@
     public static final LispObject truename(Pathname pathname,
                                             boolean errorIfDoesNotExist) 
     {
-        if (pathname == null || pathname.equals(NIL)) {  // XXX duplicates code at the end of this longish function: figure out proper nesting of labels.
-            if (errorIfDoesNotExist) {
-                StringBuilder sb = new StringBuilder("The file ");
-                sb.append(pathname.princToString());
-                sb.append(" does not exist.");
-                return error(new FileError(sb.toString(), pathname));
-            }
-            return NIL;
+        if (pathname == null || pathname.equals(NIL)) {  
+           return doTruenameExit(pathname, errorIfDoesNotExist); 
         }
         if (pathname instanceof LogicalPathname) {
             pathname = LogicalPathname.translateLogicalPathname((LogicalPathname) pathname);
@@ -2209,6 +2207,9 @@
             // Possibly canonicalize jar file directory
             Cons jars = (Cons) pathname.device;
             LispObject o = jars.car();
+	    if (!(o instanceof Pathname)) {
+	       return doTruenameExit(pathname, errorIfDoesNotExist);
+	    }
             if (o instanceof Pathname 
                 && !(((Pathname)o).isURL())
                 // XXX Silently fail to call truename() if the default
@@ -2286,6 +2287,10 @@
             }
         }
         error:
+	  return doTruenameExit(pathname, errorIfDoesNotExist);
+    }
+    
+    static private LispObject doTruenameExit(Pathname pathname, boolean errorIfDoesNotExist) {
         if (errorIfDoesNotExist) {
             StringBuilder sb = new StringBuilder("The file ");
             sb.append(pathname.princToString());

Modified: trunk/abcl/test/lisp/abcl/bugs.lisp
==============================================================================
--- trunk/abcl/test/lisp/abcl/bugs.lisp	Fri Nov  9 07:15:03 2012	(r14237)
+++ trunk/abcl/test/lisp/abcl/bugs.lisp	Fri Nov  9 08:07:08 2012	(r14238)
@@ -111,3 +111,14 @@
      2)
   3)
       
+;;; http://trac.common-lisp.net/armedbear/ticket/243
+(deftest bugs.pathname.make-pathname.1
+    (signals-error 
+     (make-pathname :device (list "foo"))
+     'error)
+t)
+
+
+(deftest bugs.pathname.make-pathname.2
+  (probe-file (make-pathname :device (list "foo")))
+nil)