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

[Mark Evenson]

Author: mevenson
Date: Thu Feb  4 04:42:16 2010
New Revision: 12417

Log:
Fix TRANSLATE-LOGICAL-PATHNAME regression.

Problem and solution found by Alan Ruttenburg.

Closes ticket:83.



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

Modified: trunk/abcl/src/org/armedbear/lisp/pathnames.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/pathnames.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/pathnames.lisp	Thu Feb  4 04:42:16 2010
@@ -203,7 +203,12 @@
     ((and to
           (not (member (car to) '(:wild :wild-inferiors))))
      (cons (casify (car to) case)
-           (translate-directory-components-aux src from (cdr to) case)))
+           (translate-directory-components-aux 
+            src from (cdr to) case)))
+    ((and (not src) 
+          (eq (car from) :wild-inferiors) 
+          (eq (car to) :wild-inferiors))
+     (translate-directory-components-aux src (cdr from) (cdr to) case))
     ((not (and src from))
      ;; both are NIL --> TO is a wildcard which can't be matched
      ;; either is NIL --> SRC can't be fully matched against FROM, vice versa
@@ -224,8 +229,9 @@
          (NIL) ;; we'll exit the loop in different ways
        (catch 'failed-match
          (return-from translate-directory-components-aux
-           (append (reverse match) (translate-directory-components-aux
-                                        src (cdr from) (cdr to) case))))
+           (append (reverse match) 
+                   (translate-directory-components-aux
+                    src (cdr from) (cdr to) case))))
        (when (null src) ;; SRC is NIL and we're still here: error exit
          (throw 'failed-match))))))
 

Modified: trunk/abcl/test/lisp/abcl/bugs.lisp
==============================================================================
--- trunk/abcl/test/lisp/abcl/bugs.lisp	(original)
+++ trunk/abcl/test/lisp/abcl/bugs.lisp	Thu Feb  4 04:42:16 2010
@@ -3,24 +3,39 @@
 ;;; When these bugs get fixed, they should be moved elsewhere in the
 ;;; testsuite so they remain fixed.
 
-(deftest bugs.translate-logical-pathname
+(deftest bugs.logical-pathname.1
     #|
-    Date: Mon, 18 Jan 2010 10:51:07 -0500
-    Message-ID: <29af5e2d1001180751l7cf79a3ay929cef1deb9ed063 at mail.gmail.com>
-    Subject: Re: [armedbear-devel] translate-logical-pathname and :wild-inferiors 
-    regression
-    From: Alan Ruttenberg <alanruttenberg at gmail.com>
+Date: Mon, 18 Jan 2010 10:51:07 -0500
+Message-ID: <29af5e2d1001180751l7cf79a3ay929cef1deb9ed063 at mail.gmail.com>
+Subject: Re: [armedbear-devel] translate-logical-pathname and :wild-inferiors 
+regression
+From: Alan Ruttenberg <alanruttenberg at gmail.com>
     |#
     (progn
       (setf (logical-pathname-translations "ido") 
-            '((#P"IDO:IDO-CORE;**;*.*" 
-               #P"/Users/alanr/repos/infectious-disease-ontology/trunk/src/ontology/ido-core/**/*.*") 
-              (#P"IDO:IMMUNOLOGY;**;*.*"
-               #P"/Users/alanr/repos/infectious-disease-ontology/trunk/src/ontology/immunology/**/*.*") 
-              (#P"IDO:TOOLS;**;*.*" 
-               #P"/Users/alanr/repos/infectious-disease-ontology/trunk/src/tools/**/*.*") 
-              (#P"IDO:LIB;**;*.*"
-               #P"/Users/alanr/repos/infectious-disease-ontology/trunk/lib/**/*.*")))
-      (translate-pathname #P"IDO:IMMUNOLOGY;" #P"IDO:IMMUNOLOGY;**;*.*" 
-                          #P"/Users/alanr/repos/infectious-disease-ontology/trunk/src/ontology/**/*.*"))
-  #P"/users/alanr/repos/infectious-disease-ontology/trunk/src/ontology/immunology/")
\ No newline at end of file
+            '(("IDO:IDO-CORE;**;*.*" 
+               "/Users/alanr/repos/infectious-disease-ontology/trunk/src/ontology/ido-core/**/*.*") 
+              ("IDO:IMMUNOLOGY;**;*.*"
+               "/Users/alanr/repos/infectious-disease-ontology/trunk/src/ontology/immunology/**/*.*") 
+              ("IDO:TOOLS;**;*.*" 
+               "/Users/alanr/repos/infectious-disease-ontology/trunk/src/tools/**/*.*") 
+              ("IDO:LIB;**;*.*"
+               "/Users/alanr/repos/infectious-disease-ontology/trunk/lib/**/*.*")))
+      (translate-pathname "IDO:IMMUNOLOGY;" "IDO:IMMUNOLOGY;**;*.*" 
+                          "/Users/alanr/repos/infectious-disease-ontology/trunk/src/ontology/**/*.*"))
+  #P"/users/alanr/repos/infectious-disease-ontology/trunk/src/ontology/")
+
+(deftest bugs.logical.pathname.2
+    #|
+Message-Id: <BBE9D0E5-5166-4D24-9A8A-DC4E766976D1 at ISI.EDU>
+From: Thomas Russ <tar at ISI.EDU>
+To: armedbear-devel at common-lisp.net
+Subject: [armedbear-devel] Bug in translate-logical-pathname.
+    |#
+    (progn 
+      (setf (logical-pathname-translations "L")
+            '(("L:NATIVE;**;*.*" "/usr/lisp/abcl/native/**/*.*")))
+      (translate-logical-pathname "L:NATIVE;TEST;FOO.FASL"))
+  #p"/usr/lisp/abcl/native/test/foo.fasl")
+
+