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

(CVS commit dated 2009/06/19 03:09).
This commit is contained in:
Kevin Cozens 2009-08-18 00:26:22 -04:00
parent 59ea11d78a
commit e602fc88af
4 changed files with 43 additions and 9 deletions

View File

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

View File

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

View File

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

View File

@ -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;
}