[armedbear-devel] Bug in translate-logical-pathname.

[Thomas Russ]

There seems to be a bug in TRANSLATE-LOGICAL-PATHNAME when the logical  
pathname source includes constant elements in addition to wildcards.

Here is an example that demonstrates the problem:

  CL-USER(1): (setf (logical-pathname-translations "L")
  	          '(("L:NATIVE;**;*.*" "/usr/lisp/abcl/native/**/*.*")))

  ((#P"L:NATIVE;**;*.*" #P"/usr/lisp/abcl/native/**/*.*"))


  CL-USER(2): (translate-logical-pathname "L:NATIVE;TEST;FOO.FASL")

  #P"/usr/lisp/abcl/native/native/test/foo.fasl"

;; ERROR.  Should be #P"/usr/lisp/abcl/native/test/foo.fasl"
;;
;; With :wild-inferiors, the full directory path is copied instead of
;; just the part after the matching constant part.  That results in
;; the "native" element appearing twice.
;;

The problem seems to be in the file "abcl/src/org/armedbear/lisp/ 
pathnames.lisp", in the function SYSTEM::TRANSLATE-DIRECTORY-COMPONENTS:

(defun translate-directory-components (source from to case)
   (cond ((null to)
          nil
          )
         ((memq (car to) '(:absolute :relative))
          (cons (car to)
                (translate-directory-components (cdr source) (cdr  
from) (cdr to) case))
          )
         ((eq (car to) :wild)
          (if (eq (car from) :wild)
              ;; Grab the next chunk from SOURCE.
              (append (casify (car source) case)
                      (translate-directory-components (cdr source)  
(cdr from) (cdr to) case))
              (error "Unsupported case 1: ~S ~S ~S" source from to))
          )
         ((eq (car to) :wild-inferiors)
          ;; Grab the next chunk from SOURCE.
          (append (casify (car source) case)
                  (translate-directory-components (cdr source) (cdr  
from) (cdr to) case))
          )
         (t
          ;; "If the piece in TO-WILDCARD is present and not wild, it  
is copied
          ;; into the result."
          (append (casify (car to) case)
                  (translate-directory-components source from (cdr to)  
case))
          )
         ))

The final COND clause ("T") needs to be more sophisticated in what it  
does.  If there are non-wildcard elements in the FROM, then it will  
need to eliminate the the common prefix between "source" and "from".   
In order to be a valid match, it I think it SHOULD be guaranteed that  
a non-wildcard "from" component is a leading subsequence or equal to  
"source" -- but I'm not fully familiar with the code, but a quick test  
seems to indicate that the following modified function covers at least  
the simpler cases of this issue.  It adds a new clause checking  
for :WILD-INFERIORS in the FROM slot which performs the current  
function, and changes the T clause to properly manage the subsequence  
matching.

(defun translate-directory-components (source from to case)
   (cond ((null to)
          nil
          )
         ((memq (car to) '(:absolute :relative))
          (cons (car to)
                (translate-directory-components (cdr source) (cdr  
from) (cdr to) case))
          )
         ((eq (car to) :wild)
          (if (eq (car from) :wild)
              ;; Grab the next chunk from SOURCE.
              (append (casify (car source) case)
                      (translate-directory-components (cdr source)  
(cdr from) (cdr to) case))
              (error "Unsupported case 1: ~S ~S ~S" source from to))
          )
         ((eq (car to) :wild-inferiors)
          ;; Grab the next chunk from SOURCE.
          (append (casify (car source) case)
                  (translate-directory-components (cdr source) (cdr  
from) (cdr to) case))
          )
	((eq (car from) :wild-inferiors)
          ;; "If the piece in TO-WILDCARD is present and not wild, and  
the FROM item
	 ;;  doesn't contain any constants, then just copy TO to the result."
          (append (casify (car to) case)
                  (translate-directory-components source from (cdr to)  
case)))
         (t
          ;; "If the piece in TO-WILDCARD is present and not wild,  
then FROM should
          ;;  be a subsequence of SOURCE.  The common subsequence  
needs to be removed
          ;;  in the recursive call.  Special case handling for a full  
match is
          ;;  also needed."
          (let ((pos (mismatch (car source) (car from) :test #'string- 
equal)))
            (append (casify (car to) case)
                    (if (null pos) ;; A full match, pop both source  
and from
                      (translate-directory-components  (cdr source)  
(cdr from) (cdr to) case)
                      (translate-directory-components (cons (subseq  
(car source) pos) (cdr source)) (cdr from) (cdr to) case))))
          )
         ))