#undef EVAL_DEBUGGING_P
-#ifdef DEVAL
-
/*
This code is specific for the debugging support.
*/
}
-#else /* DEVAL */
-
-/*
- Code is specific to debugging-less support.
- */
-
-
-#define CEVAL ceval
-#define SCM_APPLY scm_apply
-#define PREP_APPLY(proc, args)
-#define ENTER_APPLY
-#define RETURN(x) do { return x; } while (0)
-#define EVAL_DEBUGGING_P 0
-
-#ifdef STACK_CHECKING
-# ifndef NO_CEVAL_STACK_CHECKING
-# define EVAL_STACK_CHECKING
-# endif
-#endif
-
-
-
-
-static SCM
-scm_ceval_args (SCM l, SCM env, SCM proc)
-{
- SCM results = SCM_EOL, *lloc = &results, res;
- while (scm_is_pair (l))
- {
- res = EVALCAR (l, env);
-
- *lloc = scm_list_1 (res);
- lloc = SCM_CDRLOC (*lloc);
- l = SCM_CDR (l);
- }
- if (!scm_is_null (l))
- scm_wrong_num_args (proc);
- return results;
-}
-
-
-SCM
-scm_eval_args (SCM l, SCM env, SCM proc)
-{
- return scm_ceval_args (l, env, proc);
-}
-
-
-
-#endif
-
-
#define EVAL(x, env) SCM_I_XEVAL(x, env)
CEVAL (SCM x, SCM env)
{
SCM proc, arg1;
-#ifdef DEVAL
scm_t_debug_frame debug;
scm_t_debug_info *debug_info_end;
debug.prev = scm_i_last_debug_frame ();
debug.info = debug.vect;
debug_info_end = debug.vect + scm_debug_eframe_size;
scm_i_set_last_debug_frame (&debug);
-#endif
#ifdef EVAL_STACK_CHECKING
if (scm_stack_checking_enabled_p && SCM_STACK_OVERFLOW_P (&proc))
{
-#ifdef DEVAL
debug.info->e.exp = x;
debug.info->e.env = env;
-#endif
scm_report_stack_overflow ();
}
#endif
-#ifdef DEVAL
goto start;
-#endif
loop:
-#ifdef DEVAL
SCM_CLEAR_ARGSREADY (debug);
if (SCM_OVERFLOWP (debug))
--debug.info;
}
}
}
-#endif
dispatch:
SCM_TICK;
if (SCM_ISYMP (SCM_CAR (x)))
if (SCM_CLOSUREP (proc))
{
SCM formals = SCM_CLOSURE_FORMALS (proc);
-#ifdef DEVAL
debug.info->a.args = arg1;
-#endif
if (SCM_UNLIKELY (scm_badargsp (formals, arg1)))
scm_wrong_num_args (proc);
ENTER_APPLY;
goto dispatch;
}
proc = *location;
-#ifdef DEVAL
if (scm_check_memoize_p && SCM_TRAPS_P)
{
SCM arg1, retval;
*/
SCM_TRAPS_P = 1;
}
-#endif
}
if (SCM_MACROP (proc))
SCM_SETCAR (x, orig_sym); /* Undo memoizing effect of
lookupcar */
handle_a_macro: /* inputs: x, env, proc */
-#ifdef DEVAL
/* Set a flag during macro expansion so that macro
application frames can be deleted from the backtrace. */
SCM_SET_MACROEXP (debug);
-#endif
arg1 = SCM_APPLY (SCM_MACRO_CODE (proc), x,
scm_cons (env, scm_listofnull));
-#ifdef DEVAL
SCM_CLEAR_MACROEXP (debug);
-#endif
switch (SCM_MACRO_TYPE (proc))
{
case 3:
assert (!scm_is_eq (x, SCM_CAR (arg1))
&& !scm_is_eq (x, SCM_CDR (arg1)));
-#ifdef DEVAL
if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc)))
{
SCM_CRITICAL_SECTION_START;
debug.info->e.exp = scm_cons_source (debug.info->e.exp,
SCM_CAR (x),
SCM_CDR (x));
-#endif
SCM_CRITICAL_SECTION_START;
SCM_SETCAR (x, SCM_CAR (arg1));
SCM_SETCDR (x, SCM_CDR (arg1));
goto badfun;
RETURN (SCM_SMOB_APPLY_0 (proc));
case scm_tc7_gsubr:
-#ifdef DEVAL
debug.info->a.proc = proc;
debug.info->a.args = SCM_EOL;
-#endif
RETURN (scm_i_gsubr_apply (proc, SCM_UNDEFINED));
case scm_tc7_pws:
proc = SCM_PROCEDURE (proc);
-#ifdef DEVAL
debug.info->a.proc = proc;
-#endif
if (!SCM_CLOSUREP (proc))
goto evap0;
/* fallthrough */
if (SCM_STRUCT_APPLICABLE_P (proc))
{
proc = SCM_STRUCT_PROCEDURE (proc);
-#ifdef DEVAL
debug.info->a.proc = proc;
-#endif
goto evap0;
}
else
arg1 = EVALCAR (x, env);
else
scm_wrong_num_args (proc);
-#ifdef DEVAL
debug.info->a.args = scm_list_1 (arg1);
-#endif
x = SCM_CDR (x);
{
SCM arg2;
case scm_tc7_asubr:
RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED));
case scm_tc7_lsubr:
-#ifdef DEVAL
RETURN (SCM_SUBRF (proc) (debug.info->a.args));
-#else
- RETURN (SCM_SUBRF (proc) (scm_list_1 (arg1)));
-#endif
case scm_tc7_smob:
if (!SCM_SMOB_APPLICABLE_P (proc))
goto badfun;
RETURN (SCM_SMOB_APPLY_1 (proc, arg1));
case scm_tc7_gsubr:
-#ifdef DEVAL
debug.info->a.args = debug.info->a.args;
debug.info->a.proc = proc;
-#endif
RETURN (scm_i_gsubr_apply (proc, arg1, SCM_UNDEFINED));
case scm_tc7_pws:
proc = SCM_PROCEDURE (proc);
-#ifdef DEVAL
debug.info->a.proc = proc;
-#endif
if (!SCM_CLOSUREP (proc))
goto evap1;
/* fallthrough */
|| (scm_is_pair (formals) && scm_is_pair (SCM_CDR (formals))))
goto wrongnumargs;
x = SCM_CLOSURE_BODY (proc);
-#ifdef DEVAL
env = SCM_EXTEND_ENV (formals,
debug.info->a.args,
SCM_ENV (proc));
-#else
- env = SCM_EXTEND_ENV (formals,
- scm_list_1 (arg1),
- SCM_ENV (proc));
-#endif
goto nontoplevel_begin;
}
case scm_tcs_struct:
if (SCM_STRUCT_APPLICABLE_P (proc))
{
proc = SCM_STRUCT_PROCEDURE (proc);
-#ifdef DEVAL
debug.info->a.proc = proc;
-#endif
goto evap1;
}
else
scm_wrong_num_args (proc);
{ /* have two or more arguments */
-#ifdef DEVAL
debug.info->a.args = scm_list_2 (arg1, arg2);
-#endif
x = SCM_CDR (x);
if (scm_is_null (x)) {
ENTER_APPLY;
case scm_tc7_subr_2o:
RETURN (SCM_SUBRF (proc) (arg1, arg2));
case scm_tc7_lsubr:
-#ifdef DEVAL
RETURN (SCM_SUBRF (proc) (debug.info->a.args));
-#else
- RETURN (SCM_SUBRF (proc) (scm_list_2 (arg1, arg2)));
-#endif
case scm_tc7_lsubr_2:
RETURN (SCM_SUBRF (proc) (arg1, arg2, SCM_EOL));
case scm_tc7_rpsubr:
goto badfun;
RETURN (SCM_SMOB_APPLY_2 (proc, arg1, arg2));
case scm_tc7_gsubr:
-#ifdef DEVAL
RETURN (scm_i_gsubr_apply_list (proc, debug.info->a.args));
-#else
- RETURN (scm_i_gsubr_apply (proc, arg1, arg2, SCM_UNDEFINED));
-#endif
case scm_tcs_struct:
if (SCM_STRUCT_APPLICABLE_P (proc))
{
operatorn:
-#ifdef DEVAL
RETURN (SCM_APPLY (SCM_STRUCT_PROCEDURE (proc),
debug.info->a.args,
SCM_EOL));
-#else
- RETURN (SCM_APPLY (SCM_STRUCT_PROCEDURE (proc),
- scm_cons (arg1,
- scm_cons (arg2,
- scm_ceval_args (x,
- env,
- proc))),
- SCM_EOL));
-#endif
}
else
goto badfun;
goto badfun;
case scm_tc7_pws:
proc = SCM_PROCEDURE (proc);
-#ifdef DEVAL
debug.info->a.proc = proc;
-#endif
if (!SCM_CLOSUREP (proc))
goto evap2;
/* fallthrough */
|| (scm_is_pair (SCM_CDR (formals))
&& scm_is_pair (SCM_CDDR (formals))))))
goto wrongnumargs;
-#ifdef DEVAL
env = SCM_EXTEND_ENV (formals,
debug.info->a.args,
SCM_ENV (proc));
-#else
- env = SCM_EXTEND_ENV (formals,
- scm_list_2 (arg1, arg2),
- SCM_ENV (proc));
-#endif
x = SCM_CLOSURE_BODY (proc);
goto nontoplevel_begin;
}
}
if (SCM_UNLIKELY (!scm_is_pair (x)))
scm_wrong_num_args (proc);
-#ifdef DEVAL
debug.info->a.args = scm_cons2 (arg1, arg2,
deval_args (x, env, proc,
SCM_CDRLOC (SCM_CDR (debug.info->a.args))));
-#endif
ENTER_APPLY;
evap3:
SCM_ASRTGO (!SCM_IMP (proc), badfun);
switch (SCM_TYP7 (proc))
{ /* have 3 or more arguments */
-#ifdef DEVAL
case scm_tc7_subr_3:
if (!scm_is_null (SCM_CDR (x)))
scm_wrong_num_args (proc);
x = SCM_CLOSURE_BODY (proc);
goto nontoplevel_begin;
}
-#else /* DEVAL */
- case scm_tc7_subr_3:
- if (SCM_UNLIKELY (!scm_is_null (SCM_CDR (x))))
- scm_wrong_num_args (proc);
- else
- RETURN (SCM_SUBRF (proc) (arg1, arg2, EVALCAR (x, env)));
- case scm_tc7_asubr:
- arg1 = SCM_SUBRF (proc) (arg1, arg2);
- do
- {
- arg1 = SCM_SUBRF(proc)(arg1, EVALCAR(x, env));
- x = SCM_CDR(x);
- }
- while (!scm_is_null (x));
- RETURN (arg1);
- case scm_tc7_rpsubr:
- if (scm_is_false (SCM_SUBRF (proc) (arg1, arg2)))
- RETURN (SCM_BOOL_F);
- do
- {
- arg1 = EVALCAR (x, env);
- if (scm_is_false (SCM_SUBRF (proc) (arg2, arg1)))
- RETURN (SCM_BOOL_F);
- arg2 = arg1;
- x = SCM_CDR (x);
- }
- while (!scm_is_null (x));
- RETURN (SCM_BOOL_T);
- case scm_tc7_lsubr_2:
- RETURN (SCM_SUBRF (proc) (arg1, arg2, scm_ceval_args (x, env, proc)));
- case scm_tc7_lsubr:
- RETURN (SCM_SUBRF (proc) (scm_cons2 (arg1,
- arg2,
- scm_ceval_args (x, env, proc))));
- case scm_tc7_smob:
- if (!SCM_SMOB_APPLICABLE_P (proc))
- goto badfun;
- RETURN (SCM_SMOB_APPLY_3 (proc, arg1, arg2,
- scm_ceval_args (x, env, proc)));
- case scm_tc7_gsubr:
- if (scm_is_null (SCM_CDR (x)))
- /* 3 arguments */
- RETURN (scm_i_gsubr_apply (proc, arg1, arg2, EVALCAR (x, env),
- SCM_UNDEFINED));
- else
- RETURN (scm_i_gsubr_apply_list (proc,
- scm_cons2 (arg1, arg2,
- scm_ceval_args (x, env,
- proc))));
- case scm_tc7_program:
- RETURN (scm_vm_apply
- (scm_the_vm (), proc,
- scm_cons (arg1, scm_cons (arg2,
- scm_ceval_args (x, env, proc)))));
- case scm_tc7_pws:
- proc = SCM_PROCEDURE (proc);
- if (!SCM_CLOSUREP (proc))
- goto evap3;
- /* fallthrough */
- case scm_tcs_closures:
- {
- const SCM formals = SCM_CLOSURE_FORMALS (proc);
- if (scm_is_null (formals)
- || (scm_is_pair (formals)
- && (scm_is_null (SCM_CDR (formals))
- || (scm_is_pair (SCM_CDR (formals))
- && scm_badargsp (SCM_CDDR (formals), x)))))
- goto wrongnumargs;
- env = SCM_EXTEND_ENV (formals,
- scm_cons2 (arg1,
- arg2,
- scm_ceval_args (x, env, proc)),
- SCM_ENV (proc));
- x = SCM_CLOSURE_BODY (proc);
- goto nontoplevel_begin;
- }
-#endif /* DEVAL */
case scm_tcs_struct:
if (SCM_STRUCT_APPLICABLE_P (proc))
goto operatorn;
}
}
}
-#ifdef DEVAL
exit:
if (scm_check_exit_p && SCM_TRAPS_P)
if (SCM_EXIT_FRAME_P || (SCM_TRACE_P && SCM_TRACED_FRAME_P (debug)))
}
scm_i_set_last_debug_frame (debug.prev);
return proc;
-#endif
}
SCM
SCM_APPLY (SCM proc, SCM arg1, SCM args)
{
-#ifdef DEVAL
scm_t_debug_frame debug;
scm_t_debug_info debug_vect_body;
debug.prev = scm_i_last_debug_frame ();
debug.vect[0].a.proc = proc;
debug.vect[0].a.args = SCM_EOL;
scm_i_set_last_debug_frame (&debug);
-#else
- if (scm_debug_mode_p)
- return scm_dapply (proc, arg1, args);
-#endif
SCM_ASRTGO (SCM_NIMP (proc), badproc);
if (scm_is_null (arg1))
{
arg1 = SCM_UNDEFINED;
-#ifdef DEVAL
debug.vect[0].a.args = SCM_EOL;
-#endif
}
else
{
-#ifdef DEVAL
debug.vect[0].a.args = arg1;
-#endif
args = SCM_CDR (arg1);
arg1 = SCM_CAR (arg1);
}
else
{
args = scm_nconc2last (args);
-#ifdef DEVAL
debug.vect[0].a.args = scm_cons (arg1, args);
-#endif
}
-#ifdef DEVAL
if (SCM_ENTER_FRAME_P && SCM_TRAPS_P)
{
SCM tmp = scm_make_debugobj (&debug);
SCM_TRAPS_P = 1;
}
ENTER_APPLY;
-#endif
tail:
switch (SCM_TYP7 (proc))
{
else
RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CADR (args)));
case scm_tc7_lsubr:
-#ifdef DEVAL
RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : debug.vect[0].a.args));
-#else
- RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : scm_cons (arg1, args)));
-#endif
case scm_tc7_lsubr_2:
if (SCM_UNLIKELY (!scm_is_pair (args)))
scm_wrong_num_args (proc);
}
RETURN (SCM_BOOL_T);
case scm_tcs_closures:
-#ifdef DEVAL
arg1 = (SCM_UNBNDP (arg1) ? SCM_EOL : debug.vect[0].a.args);
-#else
- arg1 = (SCM_UNBNDP (arg1) ? SCM_EOL : scm_cons (arg1, args));
-#endif
if (SCM_UNLIKELY (scm_badargsp (SCM_CLOSURE_FORMALS (proc), arg1)))
scm_wrong_num_args (proc);
else
RETURN (SCM_SMOB_APPLY_3 (proc, arg1, SCM_CAR (args), SCM_CDR (args)));
case scm_tc7_gsubr:
-#ifdef DEVAL
args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args);
debug.vect[0].a.proc = proc;
debug.vect[0].a.args = args;
-#else
- args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args));
-#endif
RETURN (scm_i_gsubr_apply_list (proc, args));
case scm_tc7_pws:
proc = SCM_PROCEDURE (proc);
-#ifdef DEVAL
debug.vect[0].a.proc = proc;
-#endif
goto tail;
case scm_tcs_struct:
if (SCM_STRUCT_APPLICABLE_P (proc))
{
proc = SCM_STRUCT_PROCEDURE (proc);
-#ifdef DEVAL
debug.vect[0].a.proc = proc;
-#endif
if (SCM_NIMP (proc))
goto tail;
else
}
else if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
{
-#ifdef DEVAL
args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args);
-#else
- args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args));
-#endif
RETURN (scm_apply_generic (proc, args));
}
else
badproc:
scm_wrong_type_arg ("apply", SCM_ARG1, proc);
}
-#ifdef DEVAL
exit:
if (scm_check_exit_p && SCM_TRAPS_P)
if (SCM_EXIT_FRAME_P || (SCM_TRACE_P && SCM_TRACED_FRAME_P (debug)))
}
scm_i_set_last_debug_frame (debug.prev);
return proc;
-#endif
}