mirror of https://github.com/GNOME/gimp.git
Defined *compile-hook*. Changes based on official version of TinyScheme
(CVS commit dated 2009/06/19 03:09).
This commit is contained in:
parent
59ea11d78a
commit
e602fc88af
|
@ -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)
|
||||
|
|
|
@ -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 )
|
||||
|
|
|
@ -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;
|
||||
|
|
|
@ -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;
|
||||
}
|
||||
|
|
Loading…
Reference in New Issue