mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

* eval.h, eval.c, debug.h, debug.c (scm_evaluator_traps): Moved

Browse source 
from debug.c --> eval.c

* eval.h, eval.c (scm_eval_options_interface): New options
interface.
(SCM_EVAL_STACK): New option: Size of newly created stacks,
i.e. stacks for new threads.

* eval.c (unsafe_setjmp): Removed with #if 0.

* eval.c, numbers.c, unif.c, srcprop.c: Added a few curly braces
to avoid compiler warnings.
This commit is contained in:
Mikael Djurfeldt 1998-03-30 21:02:59 +00:00
parent 51d394a1c5
commit 33b974026b
4 changed files with 381 additions and 105 deletions
Download patch file Download diff file Expand all files Collapse all files

250
libguile/debug.c
View file

@ -88,23 +88,6 @@ scm_debug_options (setting)
return ans; return ans;
} }
SCM_PROC (s_evaluator_traps, "evaluator-traps-interface", 0, 1, 0, scm_evaluator_traps);
SCM
scm_evaluator_traps (setting)
SCM setting;
{
SCM ans;
SCM_DEFER_INTS;
ans = scm_options (setting,
scm_evaluator_trap_table,
SCM_N_EVALUATOR_TRAPS,
s_evaluator_traps);
SCM_RESET_DEBUG_MODE;
SCM_ALLOW_INTS
return ans;
}
SCM_PROC (s_single_step, "single-step", 2, 0, 0, scm_single_step); SCM_PROC (s_single_step, "single-step", 2, 0, 0, scm_single_step);
SCM SCM
@ -142,7 +125,11 @@ prinmemoized (obj, port, pstate)
int writingp = SCM_WRITINGP (pstate); int writingp = SCM_WRITINGP (pstate);
scm_puts ("#<memoized ", port); scm_puts ("#<memoized ", port);
SCM_SET_WRITINGP (pstate, 1); SCM_SET_WRITINGP (pstate, 1);
#ifdef GUILE_DEBUG
scm_iprin1 (SCM_MEMOIZED_EXP (obj), port, pstate);
#else
scm_iprin1 (scm_unmemoize (obj), port, pstate); scm_iprin1 (scm_unmemoize (obj), port, pstate);
#endif
SCM_SET_WRITINGP (pstate, writingp); SCM_SET_WRITINGP (pstate, writingp);
scm_putc ('>', port); scm_putc ('>', port);
return 1; return 1;
@ -178,6 +165,212 @@ scm_make_memoized (exp, env)
return ans; return ans;
} }
#ifdef GUILE_DEBUG
/*
* Some primitives for construction of memoized code
*
* - procedure: memcons CAR CDR [ENV]
*
* Construct a pair, encapsulated in a memoized object.
*
* The CAR and CDR can be either normal or memoized. If ENV isn't
* specified, the top-level environment of the current module will
* be assumed. All environments must match.
*
* - procedure: make-gloc VARIABLE [ENV]
*
* Return a gloc, encapsulated in a memoized object.
*
* (Glocs can't exist in normal list structures, since they will
* be mistaken for structs.)
*
* - procedure: gloc? OBJECT
*
* Return #t if OBJECT is a memoized gloc.
*
* - procedure: make-iloc FRAME BINDING CDRP
*
* Return an iloc referring to frame no. FRAME, binding
* no. BINDING. If CDRP is non-#f, the iloc is referring to a
* frame consisting of a single pair, with the value stored in the
* CDR.
*
* - procedure: iloc? OBJECT
*
* Return #t if OBJECT is an iloc.
*
* - procedure: mem->proc MEMOIZED
*
* Construct a closure from the memoized lambda expression MEMOIZED
*
* WARNING! The code is not copied!
*
* - procedure: proc->mem CLOSURE
*
* Turn the closure CLOSURE into a memoized object.
*
* WARNING! The code is not copied!
*
* - constant: SCM_IM_AND
* - constant: SCM_IM_BEGIN
* - constant: SCM_IM_CASE
* - constant: SCM_IM_COND
* - constant: SCM_IM_DO
* - constant: SCM_IM_IF
* - constant: SCM_IM_LAMBDA
* - constant: SCM_IM_LET
* - constant: SCM_IM_LETSTAR
* - constant: SCM_IM_LETREC
* - constant: SCM_IM_OR
* - constant: SCM_IM_QUOTE
* - constant: SCM_IM_SET
* - constant: SCM_IM_DEFINE
* - constant: SCM_IM_APPLY
* - constant: SCM_IM_CONT
*/
#include "variable.h"
#include "procs.h"
SCM_PROC (s_make_gloc, "make-gloc", 1, 1, 0, scm_make_gloc);
SCM
scm_make_gloc (var, env)
SCM var;
SCM env;
{
#if 1 /* Unsafe */
if (SCM_NIMP (var) && SCM_CONSP (var))
var = scm_cons (SCM_BOOL_F, var);
else
#endif
SCM_ASSERT (SCM_NIMP (var) && SCM_VARIABLEP (var),
var,
SCM_ARG1,
s_make_gloc);
if (SCM_UNBNDP (env))
env = scm_top_level_env (SCM_CDR (scm_top_level_lookup_closure_var));
else
SCM_ASSERT (SCM_NULLP (env) || (SCM_NIMP (env) && SCM_CONSP (env)),
env,
SCM_ARG2,
s_make_gloc);
return scm_make_memoized (SCM_VARVCELL (var) + 1, env);
}
SCM_PROC (s_gloc_p, "gloc?", 1, 0, 0, scm_gloc_p);
SCM
scm_gloc_p (obj)
SCM obj;
{
return ((SCM_NIMP (obj)
&& SCM_MEMOIZEDP (obj)
&& (SCM_MEMOIZED_EXP (obj) & 7) == 1)
? SCM_BOOL_T
: SCM_BOOL_F);
}
SCM_PROC (s_make_iloc, "make-iloc", 3, 0, 0, scm_make_iloc);
SCM
scm_make_iloc (frame, binding, cdrp)
SCM frame;
SCM binding;
SCM cdrp;
{
SCM_ASSERT (SCM_INUMP (frame), frame, SCM_ARG1, s_make_iloc);
SCM_ASSERT (SCM_INUMP (binding), binding, SCM_ARG2, s_make_iloc);
return (SCM_ILOC00
+ SCM_IFRINC * SCM_INUM (frame)
+ (SCM_NFALSEP (cdrp) ? SCM_ICDR : 0)
+ SCM_IDINC * SCM_INUM (binding));
}
SCM_PROC (s_iloc_p, "iloc?", 1, 0, 0, scm_iloc_p);
SCM
scm_iloc_p (obj)
SCM obj;
{
return SCM_ILOCP (obj) ? SCM_BOOL_T : SCM_BOOL_F;
}
SCM_PROC (s_memcons, "memcons", 2, 1, 0, scm_memcons);
SCM
scm_memcons (car, cdr, env)
SCM car;
SCM cdr;
SCM env;
{
if (SCM_NIMP (car) && SCM_MEMOIZEDP (car))
{
/*fixme* environments may be two different but equal top-level envs */
if (!SCM_UNBNDP (env) && SCM_MEMOIZED_ENV (car) != env)
scm_misc_error (s_memcons,
"environment mismatch arg1 <-> arg3",
scm_cons2 (car, env, SCM_EOL));
else
env = SCM_MEMOIZED_ENV (car);
car = SCM_MEMOIZED_EXP (car);
}
if (SCM_NIMP (cdr) && SCM_MEMOIZEDP (cdr))
{
if (!SCM_UNBNDP (env) && SCM_MEMOIZED_ENV (cdr) != env)
scm_misc_error (s_memcons,
"environment mismatch arg2 <-> arg3",
scm_cons2 (cdr, env, SCM_EOL));
else
env = SCM_MEMOIZED_ENV (cdr);
cdr = SCM_MEMOIZED_EXP (cdr);
}
if (SCM_UNBNDP (env))
env = scm_top_level_env (SCM_CDR (scm_top_level_lookup_closure_var));
else
SCM_ASSERT (SCM_NULLP (env) || (SCM_NIMP (env) && SCM_CONSP (env)),
env,
SCM_ARG3,
s_make_iloc);
return scm_make_memoized (scm_cons (car, cdr), env);
}
SCM_PROC (s_mem_to_proc, "mem->proc", 1, 0, 0, scm_mem_to_proc);
SCM
scm_mem_to_proc (obj)
SCM obj;
{
SCM env;
SCM_ASSERT (SCM_NIMP (obj) && SCM_MEMOIZEDP (obj),
obj,
SCM_ARG1,
s_mem_to_proc);
env = SCM_MEMOIZED_ENV (obj);
obj = SCM_MEMOIZED_EXP (obj);
if (!(SCM_NIMP (obj) && SCM_CAR (obj) == SCM_IM_LAMBDA))
scm_misc_error (s_mem_to_proc,
"expected lambda expression",
scm_cons (obj, SCM_EOL));
return scm_closure (SCM_CDR (obj), env);
}
SCM_PROC (s_proc_to_mem, "proc->mem", 1, 0, 0, scm_proc_to_mem);
SCM
scm_proc_to_mem (obj)
SCM obj;
{
SCM_ASSERT (SCM_NIMP (obj) && SCM_CLOSUREP (obj),
obj,
SCM_ARG1,
s_proc_to_mem);
return scm_make_memoized (scm_cons (SCM_IM_LAMBDA, SCM_CODE (obj)),
SCM_ENV (obj));
}
#endif /* GUILE_DEBUG */
SCM_PROC (s_unmemoize, "unmemoize", 1, 0, 0, scm_unmemoize); SCM_PROC (s_unmemoize, "unmemoize", 1, 0, 0, scm_unmemoize);
SCM SCM
@ -407,9 +600,6 @@ void
scm_init_debug () scm_init_debug ()
{ {
scm_init_opts (scm_debug_options, scm_debug_opts, SCM_N_DEBUG_OPTIONS); scm_init_opts (scm_debug_options, scm_debug_opts, SCM_N_DEBUG_OPTIONS);
scm_init_opts (scm_evaluator_traps,
scm_evaluator_trap_table,
SCM_N_EVALUATOR_TRAPS);
scm_tc16_memoized = scm_newsmob (&memoizedsmob); scm_tc16_memoized = scm_newsmob (&memoizedsmob);
scm_tc16_debugobj = scm_newsmob (&debugobjsmob); scm_tc16_debugobj = scm_newsmob (&debugobjsmob);
@ -422,7 +612,25 @@ scm_init_debug ()
scm_i_eval_args = SCM_CAR (scm_sysintern ("eval-args", SCM_UNDEFINED)); scm_i_eval_args = SCM_CAR (scm_sysintern ("eval-args", SCM_UNDEFINED));
scm_make_synt (s_start_stack, scm_makacro, scm_m_start_stack); scm_make_synt (s_start_stack, scm_makacro, scm_m_start_stack);
#ifdef GUILE_DEBUG
scm_sysintern ("SCM_IM_AND", SCM_IM_AND);
scm_sysintern ("SCM_IM_BEGIN", SCM_IM_BEGIN);
scm_sysintern ("SCM_IM_CASE", SCM_IM_CASE);
scm_sysintern ("SCM_IM_COND", SCM_IM_COND);
scm_sysintern ("SCM_IM_DO", SCM_IM_DO);
scm_sysintern ("SCM_IM_IF", SCM_IM_IF);
scm_sysintern ("SCM_IM_LAMBDA", SCM_IM_LAMBDA);
scm_sysintern ("SCM_IM_LET", SCM_IM_LET);
scm_sysintern ("SCM_IM_LETSTAR", SCM_IM_LETSTAR);
scm_sysintern ("SCM_IM_LETREC", SCM_IM_LETREC);
scm_sysintern ("SCM_IM_OR", SCM_IM_OR);
scm_sysintern ("SCM_IM_QUOTE", SCM_IM_QUOTE);
scm_sysintern ("SCM_IM_SET", SCM_IM_SET);
scm_sysintern ("SCM_IM_DEFINE", SCM_IM_DEFINE);
scm_sysintern ("SCM_IM_APPLY", SCM_IM_APPLY);
scm_sysintern ("SCM_IM_CONT", SCM_IM_CONT);
#endif
scm_add_feature ("debug-extensions"); scm_add_feature ("debug-extensions");
#include "debug.x" #include "debug.x"

9
libguile/debug.h
View file

@ -63,7 +63,7 @@
/* {Options} /* {Options}
*/ */
/* scm_debug_opts and scm_evaluator_trap_table are defined in eval.c. /* scm_debug_opts is defined in eval.c.
*/ */
extern scm_option scm_debug_opts[]; extern scm_option scm_debug_opts[];
@ -82,13 +82,6 @@ extern scm_option scm_debug_opts[];
#define SCM_STACK_LIMIT scm_debug_opts[11].val #define SCM_STACK_LIMIT scm_debug_opts[11].val
#define SCM_N_DEBUG_OPTIONS 12 #define SCM_N_DEBUG_OPTIONS 12
extern scm_option scm_evaluator_trap_table[];
#define SCM_ENTER_FRAME_P scm_evaluator_trap_table[0].val
#define SCM_APPLY_FRAME_P scm_evaluator_trap_table[1].val
#define SCM_EXIT_FRAME_P scm_evaluator_trap_table[2].val
#define SCM_N_EVALUATOR_TRAPS 3
extern SCM (*scm_ceval_ptr) SCM_P ((SCM exp, SCM env)); extern SCM (*scm_ceval_ptr) SCM_P ((SCM exp, SCM env));
extern int scm_debug_mode; extern int scm_debug_mode;

210
libguile/eval.c
View file

@ -280,6 +280,7 @@ scm_lookupcar1 (vloc, genv)
for (fl = SCM_CAR (*al); SCM_NIMP (fl); fl = SCM_CDR (fl)) for (fl = SCM_CAR (*al); SCM_NIMP (fl); fl = SCM_CDR (fl))
{ {
if (SCM_NCONSP (fl)) if (SCM_NCONSP (fl))
{
if (fl == var) if (fl == var)
{ {
#ifdef MEMOIZE_LOCALS #ifdef MEMOIZE_LOCALS
@ -291,8 +292,9 @@ scm_lookupcar1 (vloc, genv)
#endif #endif
return SCM_CDRLOC (*al); return SCM_CDRLOC (*al);
} }
else else
break; break;
}
al = SCM_CDRLOC (*al); al = SCM_CDRLOC (*al);
if (SCM_CAR (fl) == var) if (SCM_CAR (fl) == var)
{ {
@ -652,23 +654,23 @@ scm_m_lambda (xorig, env)
if (scm_ilength (x) < 2) if (scm_ilength (x) < 2)
goto badforms; goto badforms;
proc = SCM_CAR (x); proc = SCM_CAR (x);
if SCM_NULLP if (SCM_NULLP (proc))
(proc) goto memlambda; goto memlambda;
if SCM_IMP if (SCM_IMP (proc))
(proc) goto badforms; goto badforms;
if SCM_SYMBOLP if (SCM_SYMBOLP (proc))
(proc) goto memlambda; goto memlambda;
if SCM_NCONSP if (SCM_NCONSP (proc))
(proc) goto badforms; goto badforms;
while SCM_NIMP while (SCM_NIMP (proc))
(proc)
{ {
if SCM_NCONSP if (SCM_NCONSP (proc))
(proc) {
if (!SCM_SYMBOLP (proc)) if (!SCM_SYMBOLP (proc))
goto badforms; goto badforms;
else else
goto memlambda; goto memlambda;
}
if (!(SCM_NIMP (SCM_CAR (proc)) && SCM_SYMBOLP (SCM_CAR (proc)))) if (!(SCM_NIMP (SCM_CAR (proc)) && SCM_SYMBOLP (SCM_CAR (proc))))
goto badforms; goto badforms;
proc = SCM_CDR (proc); proc = SCM_CDR (proc);
@ -1316,6 +1318,7 @@ scm_eval_args (l, env)
returns, rendering the jump buffer invalid. Duh. Gotta find a returns, rendering the jump buffer invalid. Duh. Gotta find a
better way... -JimB */ better way... -JimB */
#define safe_setjmp(x) setjmp (x) #define safe_setjmp(x) setjmp (x)
#if 0
static int static int
unsafe_setjmp (jmp_buf env) unsafe_setjmp (jmp_buf env)
{ {
@ -1326,6 +1329,7 @@ unsafe_setjmp (jmp_buf env)
val = setjmp (env); val = setjmp (env);
return val; return val;
} }
#endif
#endif /* !DEVAL */ #endif /* !DEVAL */
@ -1418,6 +1422,10 @@ int scm_debug_eframe_size;
int scm_debug_mode, scm_check_entry_p, scm_check_apply_p, scm_check_exit_p; int scm_debug_mode, scm_check_entry_p, scm_check_apply_p, scm_check_exit_p;
scm_option scm_eval_opts[] = {
{ SCM_OPTION_INTEGER, "stack", 0x10000, "Size of thread stacks." }
};
scm_option scm_debug_opts[] = { scm_option scm_debug_opts[] = {
{ SCM_OPTION_BOOLEAN, "cheap", 1, { SCM_OPTION_BOOLEAN, "cheap", 1,
"*Flyweight representation of the stack at traps." }, "*Flyweight representation of the stack at traps." },
@ -1444,6 +1452,39 @@ scm_option scm_evaluator_trap_table[] = {
{ SCM_OPTION_BOOLEAN, "exit-frame", 0, "Trap when exiting eval or apply." } { SCM_OPTION_BOOLEAN, "exit-frame", 0, "Trap when exiting eval or apply." }
}; };
SCM_PROC (s_eval_options_interface, "eval-options-interface", 0, 1, 0, scm_eval_options_interface);
SCM
scm_eval_options_interface (setting)
SCM setting;
{
SCM ans;
SCM_DEFER_INTS;
ans = scm_options (setting,
scm_eval_opts,
SCM_N_EVAL_OPTIONS,
s_eval_options_interface);
SCM_ALLOW_INTS;
return ans;
}
SCM_PROC (s_evaluator_traps, "evaluator-traps-interface", 0, 1, 0, scm_evaluator_traps);
SCM
scm_evaluator_traps (setting)
SCM setting;
{
SCM ans;
SCM_DEFER_INTS;
ans = scm_options (setting,
scm_evaluator_trap_table,
SCM_N_EVALUATOR_TRAPS,
s_evaluator_traps);
SCM_RESET_DEBUG_MODE;
SCM_ALLOW_INTS
return ans;
}
SCM SCM
scm_deval_args (l, env, lloc) scm_deval_args (l, env, lloc)
SCM l, env, *lloc; SCM l, env, *lloc;
@ -2104,18 +2145,20 @@ evapply:
? SCM_ENTITY_PROC_0 (proc) ? SCM_ENTITY_PROC_0 (proc)
: SCM_OPERATOR_PROC_0 (proc)); : SCM_OPERATOR_PROC_0 (proc));
if (SCM_NIMP (x)) if (SCM_NIMP (x))
if (SCM_TYP7 (x) == scm_tc7_subr_1) {
RETURN (SCM_SUBRF (x) (proc)) if (SCM_TYP7 (x) == scm_tc7_subr_1)
else if (SCM_CLOSUREP (x)) RETURN (SCM_SUBRF (x) (proc))
{ else if (SCM_CLOSUREP (x))
t.arg1 = proc; {
proc = x; t.arg1 = proc;
proc = x;
#ifdef DEVAL #ifdef DEVAL
debug.info->a.args = scm_cons (t.arg1, SCM_EOL); debug.info->a.args = scm_cons (t.arg1, SCM_EOL);
debug.info->a.proc = proc; debug.info->a.proc = proc;
#endif #endif
goto clos1; goto clos1;
} }
}
/* Fall through. */ /* Fall through. */
} }
case scm_tc7_contin: case scm_tc7_contin:
@ -2230,19 +2273,22 @@ evapply:
? SCM_ENTITY_PROC_1 (proc) ? SCM_ENTITY_PROC_1 (proc)
: SCM_OPERATOR_PROC_1 (proc)); : SCM_OPERATOR_PROC_1 (proc));
if (SCM_NIMP (x)) if (SCM_NIMP (x))
if (SCM_TYP7 (x) == scm_tc7_subr_2) {
RETURN (SCM_SUBRF (x) (proc, t.arg1)) if (SCM_TYP7 (x) == scm_tc7_subr_2)
else if (SCM_CLOSUREP (x)) RETURN (SCM_SUBRF (x) (proc, t.arg1))
{ else if (SCM_CLOSUREP (x))
arg2 = t.arg1; {
t.arg1 = proc; arg2 = t.arg1;
proc = x; t.arg1 = proc;
proc = x;
#ifdef DEVAL #ifdef DEVAL
debug.info->a.args = scm_cons (t.arg1, debug.info->a.args); debug.info->a.args = scm_cons (t.arg1,
debug.info->a.proc = proc; debug.info->a.args);
debug.info->a.proc = proc;
#endif #endif
goto clos2; goto clos2;
} }
}
/* Fall through. */ /* Fall through. */
} }
case scm_tc7_contin: case scm_tc7_contin:
@ -2313,22 +2359,25 @@ evapply:
? SCM_ENTITY_PROC_2 (proc) ? SCM_ENTITY_PROC_2 (proc)
: SCM_OPERATOR_PROC_2 (proc)); : SCM_OPERATOR_PROC_2 (proc));
if (SCM_NIMP (x)) if (SCM_NIMP (x))
if (SCM_TYP7 (x) == scm_tc7_subr_3) {
RETURN (SCM_SUBRF (x) (proc, t.arg1, arg2)) if (SCM_TYP7 (x) == scm_tc7_subr_3)
else if (SCM_CLOSUREP (x)) RETURN (SCM_SUBRF (x) (proc, t.arg1, arg2))
{ else if (SCM_CLOSUREP (x))
{
#ifdef DEVAL #ifdef DEVAL
SCM_SET_ARGSREADY (debug); SCM_SET_ARGSREADY (debug);
debug.info->a.args = scm_cons (proc, debug.info->a.args); debug.info->a.args = scm_cons (proc,
debug.info->a.proc = x; debug.info->a.args);
debug.info->a.proc = x;
#endif #endif
env = EXTEND_ENV (SCM_CAR (SCM_CODE (x)), env = EXTEND_ENV (SCM_CAR (SCM_CODE (x)),
scm_cons2 (proc, t.arg1, scm_cons2 (proc, t.arg1,
scm_cons (arg2, env)), scm_cons (arg2, env)),
SCM_ENV (x)); SCM_ENV (x));
x = SCM_CODE (x); x = SCM_CODE (x);
goto cdrxbegin; goto cdrxbegin;
} }
}
/* Fall through. */ /* Fall through. */
} }
case scm_tc7_subr_0: case scm_tc7_subr_0:
@ -2472,36 +2521,38 @@ evapply:
? SCM_ENTITY_PROC_3 (proc) ? SCM_ENTITY_PROC_3 (proc)
: SCM_OPERATOR_PROC_3 (proc)); : SCM_OPERATOR_PROC_3 (proc));
if (SCM_NIMP (p)) if (SCM_NIMP (p))
if (SCM_TYP7 (p) == scm_tc7_lsubr_2) {
if (SCM_TYP7 (p) == scm_tc7_lsubr_2)
#ifdef DEVAL #ifdef DEVAL
RETURN (SCM_SUBRF (p) (proc, t.arg1, RETURN (SCM_SUBRF (p) (proc, t.arg1,
scm_cons (arg2, SCM_CDDR (debug.info->a.args)))) scm_cons (arg2, SCM_CDDR (debug.info->a.args))))
#else #else
RETURN (SCM_SUBRF (p) (proc, t.arg1, RETURN (SCM_SUBRF (p) (proc, t.arg1,
scm_cons (arg2, scm_cons (arg2,
scm_eval_args (x, env)))) scm_eval_args (x, env))))
#endif #endif
else if (SCM_CLOSUREP (p)) else if (SCM_CLOSUREP (p))
{ {
#ifdef DEVAL #ifdef DEVAL
SCM_SET_ARGSREADY (debug); SCM_SET_ARGSREADY (debug);
debug.info->a.args = scm_cons (proc, debug.info->a.args); debug.info->a.args = scm_cons (proc, debug.info->a.args);
debug.info->a.proc = p; debug.info->a.proc = p;
env = EXTEND_ENV (SCM_CAR (SCM_CODE (p)), env = EXTEND_ENV (SCM_CAR (SCM_CODE (p)),
scm_cons2 (proc, t.arg1, scm_cons2 (proc, t.arg1,
scm_cons (arg2, scm_cons (arg2,
SCM_CDDDR (debug.info->a.args))), SCM_CDDDR (debug.info->a.args))),
SCM_ENV (p)); SCM_ENV (p));
#else #else
env = EXTEND_ENV (SCM_CAR (SCM_CODE (p)), env = EXTEND_ENV (SCM_CAR (SCM_CODE (p)),
scm_cons2 (proc, t.arg1, scm_cons2 (proc, t.arg1,
scm_cons (arg2, scm_cons (arg2,
scm_eval_args (x, env))), scm_eval_args (x, env))),
SCM_ENV (p)); SCM_ENV (p));
#endif #endif
x = SCM_CODE (p); x = SCM_CODE (p);
goto cdrxbegin; goto cdrxbegin;
} }
}
/* Fall through. */ /* Fall through. */
} }
case scm_tc7_subr_2: case scm_tc7_subr_2:
@ -3348,6 +3399,13 @@ scm_make_synt (name, macroizer, fcn)
void void
scm_init_eval () scm_init_eval ()
{ {
scm_init_opts (scm_evaluator_traps,
scm_evaluator_trap_table,
SCM_N_EVALUATOR_TRAPS);
scm_init_opts (scm_eval_options_interface,
scm_eval_opts,
SCM_N_EVAL_OPTIONS);
scm_tc16_promise = scm_newsmob (&promsmob); scm_tc16_promise = scm_newsmob (&promsmob);
scm_tc16_macro = scm_newsmob (&macrosmob); scm_tc16_macro = scm_newsmob (&macrosmob);
scm_i_apply = scm_make_subr ("apply", scm_tc7_lsubr_2, scm_apply); scm_i_apply = scm_make_subr ("apply", scm_tc7_lsubr_2, scm_apply);

17
libguile/eval.h
View file

@ -48,6 +48,23 @@
/* {Options}
*/
extern scm_option scm_eval_opts[];
#define SCM_EVAL_STACK scm_eval_opts[0].val
#define SCM_N_EVAL_OPTIONS 1
extern scm_option scm_evaluator_trap_table[];
#define SCM_ENTER_FRAME_P scm_evaluator_trap_table[0].val
#define SCM_APPLY_FRAME_P scm_evaluator_trap_table[1].val
#define SCM_EXIT_FRAME_P scm_evaluator_trap_table[2].val
#define SCM_N_EVALUATOR_TRAPS 3
/* {Ilocs} /* {Ilocs}
* *
* Ilocs are relative pointers into local environment structures. * Ilocs are relative pointers into local environment structures.