[gimp] Defined *compile-hook*. Changes based on official version of TinyScheme

[Kevin Cozens <kcozens src gnome org>]

commit e602fc88af9db5d797c0a4c70324d5f606dd1295
Author: Kevin Cozens <kcozens cvs gnome org>
Date:   Tue Aug 18 00:26:22 2009 -0400

    Defined *compile-hook*. Changes based on official version of TinyScheme
    (CVS commit dated 2009/06/19 03:09).

 plug-ins/script-fu/tinyscheme/init.scm         |   16 ++++++++++++----
 plug-ins/script-fu/tinyscheme/opdefines.h      |    1 +
 plug-ins/script-fu/tinyscheme/scheme-private.h |   11 ++++++-----
 plug-ins/script-fu/tinyscheme/scheme.c         |   24 ++++++++++++++++++++++++
 4 files changed, 43 insertions(+), 9 deletions(-)
---
diff --git a/plug-ins/script-fu/tinyscheme/init.scm b/plug-ins/script-fu/tinyscheme/init.scm
index 6d149a5..e062a4a 100644
--- a/plug-ins/script-fu/tinyscheme/init.scm
+++ b/plug-ins/script-fu/tinyscheme/init.scm
@@ -30,6 +30,18 @@
 (define (cdddar x) (cdr (cdr (cdr (car x)))))
 (define (cddddr x) (cdr (cdr (cdr (cdr x)))))
 
+;;;; Utility to ease macro creation
+(define (macro-expand form)
+     ((eval (get-closure-code (eval (car form)))) form))
+
+(define (macro-expand-all form)
+   (if (macro? form)
+      (macro-expand-all (macro-expand form))
+      form))
+
+(define *compile-hook* macro-expand-all)
+
+
 (macro (unless form)
      `(if (not ,(cadr form)) (begin ,@(cddr form))))
 
@@ -502,10 +514,6 @@
 
 (define (acons x y z) (cons (cons x y) z))
 
-;;;; Utility to ease macro creation
-(define (macro-expand form)
-     ((eval (get-closure-code (eval (car form)))) form))
-
 ;;;; Handy for imperative programs
 ;;;; Used as: (define-with-return (foo x y) .... (return z) ...)
 (macro (define-with-return form)
diff --git a/plug-ins/script-fu/tinyscheme/opdefines.h b/plug-ins/script-fu/tinyscheme/opdefines.h
index 51664e8..a1ace89 100644
--- a/plug-ins/script-fu/tinyscheme/opdefines.h
+++ b/plug-ins/script-fu/tinyscheme/opdefines.h
@@ -17,6 +17,7 @@
 #endif
     _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_DOMACRO          )
     _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_LAMBDA           )
+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_LAMBDA1          )
     _OP_DEF(opexe_0, "make-closure",                   1,  2,       TST_PAIR TST_ENVIRONMENT,        OP_MKCLOSURE        )
     _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_QUOTE            )
     _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_DEF0             )
diff --git a/plug-ins/script-fu/tinyscheme/scheme-private.h b/plug-ins/script-fu/tinyscheme/scheme-private.h
index a2d7e7c..0a65eae 100644
--- a/plug-ins/script-fu/tinyscheme/scheme-private.h
+++ b/plug-ins/script-fu/tinyscheme/scheme-private.h
@@ -92,16 +92,17 @@ pointer global_env;      /* pointer to global environment */
 pointer c_nest;          /* stack for nested calls from C */
 
 /* global pointers to special symbols */
-pointer LAMBDA;               /* pointer to syntax lambda */
+pointer LAMBDA;          /* pointer to syntax lambda */
 pointer QUOTE;           /* pointer to syntax quote */
 
-pointer QQUOTE;               /* pointer to symbol quasiquote */
+pointer QQUOTE;          /* pointer to symbol quasiquote */
 pointer UNQUOTE;         /* pointer to symbol unquote */
 pointer UNQUOTESP;       /* pointer to symbol unquote-splicing */
 pointer FEED_TO;         /* => */
 pointer COLON_HOOK;      /* *colon-hook* */
 pointer ERROR_HOOK;      /* *error-hook* */
-pointer SHARP_HOOK;  /* *sharp-hook* */
+pointer SHARP_HOOK;      /* *sharp-hook* */
+pointer COMPILE_HOOK;    /* *compile-hook* */
 
 pointer free_cell;       /* pointer to top of free cells */
 long    fcells;          /* # of free cells */
@@ -112,7 +113,7 @@ pointer save_inport;
 pointer loadport;
 
 #define MAXFIL 64
-port load_stack[MAXFIL];     /* Stack of open files for port -1 (LOADing) */
+port load_stack[MAXFIL]; /* Stack of open files for port -1 (LOADing) */
 int nesting_stack[MAXFIL];
 int file_i;
 int nesting;
@@ -131,7 +132,7 @@ int print_flag;
 pointer value;
 int op;
 
-void *ext_data;     /* For the benefit of foreign functions */
+void *ext_data;      /* For the benefit of foreign functions */
 long gensym_cnt;
 
 struct scheme_interface *vptr;
diff --git a/plug-ins/script-fu/tinyscheme/scheme.c b/plug-ins/script-fu/tinyscheme/scheme.c
index 557357d..38eab08 100644
--- a/plug-ins/script-fu/tinyscheme/scheme.c
+++ b/plug-ins/script-fu/tinyscheme/scheme.c
@@ -2791,8 +2791,31 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
           sc->code = sc->value;
           s_goto(sc,OP_EVAL);
 
+#if 1	  
+     case OP_LAMBDA:     /* lambda */
+	  /* If the hook is defined, apply it to sc->code, otherwise
+	     set sc->value fall thru */
+	  {
+	       pointer f=find_slot_in_env(sc,sc->envir,sc->COMPILE_HOOK,1);
+               if(f==sc->NIL) {
+		    sc->value = sc->code;
+                    /* Fallthru */
+               } else {
+		    s_save(sc,OP_LAMBDA1,sc->args,sc->code);
+		    sc->args=cons(sc,sc->code,sc->NIL);
+		    sc->code=slot_value_in_env(f);
+                    s_goto(sc,OP_APPLY);
+               }
+          }
+
+     case OP_LAMBDA1:
+          s_return(sc,mk_closure(sc, sc->value, sc->envir));
+
+#else
      case OP_LAMBDA:     /* lambda */
           s_return(sc,mk_closure(sc, sc->code, sc->envir));
+	  
+#endif	  
 
      case OP_MKCLOSURE: /* make-closure */
        x=car(sc->args);
@@ -4782,6 +4805,7 @@ int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) {
   sc->COLON_HOOK = mk_symbol(sc,"*colon-hook*");
   sc->ERROR_HOOK = mk_symbol(sc, "*error-hook*");
   sc->SHARP_HOOK = mk_symbol(sc, "*sharp-hook*");
+  sc->COMPILE_HOOK = mk_symbol(sc, "*compile-hook*");
 
   return !sc->no_memory;
 }