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

@@ -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)

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             )

plug-ins/script-fu/tinyscheme/scheme-private.h

@@ -102,6 +102,7 @@ pointer FEED_TO;         /* => */
 pointer COLON_HOOK;      /* *colon-hook* */
 pointer ERROR_HOOK;      /* *error-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 */

plug-ins/script-fu/tinyscheme/scheme.c

@@ -2791,9 +2791,32 @@ 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);
        if(car(x)==sc->LAMBDA) {
@@ -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;
 }