[Ecls-list] patch *translate-pathname-hook* Was: debugging ecl?

[Pascal J. Bourguignon]

Juan Jose Garcia-Ripoll <juanjose.garciaripoll at googlemail.com> writes:

> On Tue, Jun 1, 2010 at 10:51 AM, Pascal J. Bourguignon <pjb at informatimago.com> wrote:
>
>     Unfortunately, it seems that I wrote bugs, since build/ecl_min breaks
>     when I invoke the code I modified:
>
>     [pjb at kuiper :0.0 ecl]$ build/ecl_min
>     ;*** Lisp core booted ****
>     ECL (Embeddable Common Lisp)
>    
>     > (setf (logical-pathname-translations "TEST") '(("TEST:**;*.*" "/tmp/**/*.*")))
>
> Run it with
>
> $ cd build; ./ecl_min bare.lsp
>
> so that it loads the rest of Common Lisp first! Without the rest of
> the library you do not even have SETF and thus your statement does
> not work.

Thank you.  Indeed with the .gdbinit that's in build/ it's easier.

I couldn't load bare.lsp either because it does the very thing that
broke in error, but I could define a test logical host directly with:

(si::pathname-translations "TEST" `(("TEST:**;*.*.*" "/tmp/**/*.*")))


Anyways, a suggestion from Geo Carncross, and my preference with lisp
coding over C coding, made me implement a lighter and more general
solution, namely a hook in TRANSLATE-PATHNAME.

If the variable si:*translate-pathname-hook* is not NIL,
translate-pathname calls it with the source pathname, the from and to
pathnames, and three expected results are used in place of source,
from and to.


This allows me to implement the downcasing of logical pathnames as:


(setf SI:*TRANSLATE-PATHNAME-HOOK*
    (lambda (src from to)
       (when (and (typep src 'logical-pathname)
                  (or (not (pathname-directory src))
                      (every (lambda (item) (string= (string-upcase item) item))
                             (rest (pathname-directory src))))
                  (or (not (pathname-name src))
                      (string= (string-upcase (pathname-name src)) (pathname-name src)))
                  (or (not (pathname-type src))
                      (string= (string-upcase (pathname-type src)) (pathname-type src))))
         (setf src (make-pathname :defaults src
                                  :directory (when (pathname-directory src)
                                                 (cons (first (pathname-directory src))
                                                       (mapcar (function string-downcase)
                                                             (rest (pathname-directory src)))))
                                  :name (when (pathname-name src) (string-downcase (pathname-name src)))
                                  :type (when (pathname-type src) (string-downcase (pathname-type src))))))
      (values src from to)))



So that:

> (translate-logical-pathname "TEST:ABC;DEF;GHI.KL")

#P"/tmp/abc/def/ghi.kl"


> (translate-logical-pathname "TEST:Abc;Def;GHI.kl")

#P"/tmp/Abc/Def/GHI.kl"





Here is the patch:
----------------------------------------------------------------------
diff --git a/src/c/pathname.d b/src/c/pathname.d
index cf439ea..2cf6ed2 100644
--- a/src/c/pathname.d
+++ b/src/c/pathname.d
@@ -1580,6 +1580,12 @@ copy_list_wildcards(cl_object *wilds, cl_object to)
 	/* The pattern which says what the output should look like */
 	to = cl_pathname(to);
 
+  if(!Null(ecl_symbol_value(@'si::*translate-pathname-hook*'))){
+          source=funcall(4,ecl_symbol_value(@'si::*translate-pathname-hook*'),source,from,to);
+          from=VALUES(1);
+          to=VALUES(2);
+  }    
+
 	if (source->pathname.logical != from->pathname.logical)
 		goto error;
 	out = ecl_alloc_object(t_pathname);
diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h
index e1b3edf..5b3e765 100755
--- a/src/c/symbols_list.h
+++ b/src/c/symbols_list.h
@@ -1056,6 +1056,7 @@ cl_symbols[] = {
 {SYS_ "*INTERRUPTS-ENABLED*", SI_SPECIAL, NULL, 1, Ct},
 {SYS_ "*KEEP-DEFINITIONS*", SI_SPECIAL, NULL, -1, Ct},
 {SYS_ "*LOAD-HOOKS*", SI_SPECIAL, NULL, -1, OBJNULL},
+{SYS_ "*TRANSLATE-PATHNAME-HOOK*", SI_SPECIAL, NULL, -1, Cnil},
 {SYS_ "*LOAD-SEARCH-LIST*", SI_SPECIAL, NULL, -1, Cnil},
 {SYS_ "*MAKE-CONSTANT", SI_ORDINARY, si_Xmake_constant, 2, OBJNULL},
 {SYS_ "*MAKE-SPECIAL", SI_ORDINARY, si_Xmake_special, 1, OBJNULL},
diff --git a/src/c/symbols_list2.h b/src/c/symbols_list2.h
index b7e00fb..b88284f 100755
--- a/src/c/symbols_list2.h
+++ b/src/c/symbols_list2.h
@@ -1056,6 +1056,7 @@ cl_symbols[] = {
 {SYS_ "*INTERRUPTS-ENABLED*",NULL},
 {SYS_ "*KEEP-DEFINITIONS*",NULL},
 {SYS_ "*LOAD-HOOKS*",NULL},
+{SYS_ "*TRANSLATE-PATHNAME-HOOK*",NULL},
 {SYS_ "*LOAD-SEARCH-LIST*",NULL},
 {SYS_ "*MAKE-CONSTANT","si_Xmake_constant"},
 {SYS_ "*MAKE-SPECIAL","si_Xmake_special"},
diff --git a/src/lsp/iolib.lsp b/src/lsp/iolib.lsp
index 36c9e6e..3b8d76f 100644
--- a/src/lsp/iolib.lsp
+++ b/src/lsp/iolib.lsp
@@ -13,6 +13,14 @@
 
 (in-package "SYSTEM")
 
+(defvar *translate-pathname-hook* nil
+  "May be bound to a (FUNCTION (PATHNAME PATHNAME PATHNAME) (VALUES PATHNAME PATHNAME PATHNAME))
+that is called with the source pathname, the from wildcard and the to wildcard, and that must
+return three values, the new source, the new from and the new to, to be processed by TRANSLATE-PATHNAME
+instead.");; see translate-pathname in xpathname.d
+(export '*translate-pathname-hook*)
+
+
 (defmacro with-open-stream ((var stream) &rest body)
   "Syntax: (with-open-stream (var stream-form) {decl}* {form}*)
 Evaluates FORMs with VAR bound to the value of STREAM-FORM.  The stream is

----------------------------------------------------------------------

-- 
__Pascal Bourguignon__                     http://www.informatimago.com/