diff options
Diffstat (limited to 'libguile/eval.c')
-rw-r--r-- | libguile/eval.c | 214 |
1 files changed, 136 insertions, 78 deletions
diff --git a/libguile/eval.c b/libguile/eval.c index 3b71dc093..f8dbff3ab 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -280,6 +280,7 @@ scm_lookupcar1 (vloc, genv) for (fl = SCM_CAR (*al); SCM_NIMP (fl); fl = SCM_CDR (fl)) { if (SCM_NCONSP (fl)) + { if (fl == var) { #ifdef MEMOIZE_LOCALS @@ -291,8 +292,9 @@ scm_lookupcar1 (vloc, genv) #endif return SCM_CDRLOC (*al); } - else - break; + else + break; + } al = SCM_CDRLOC (*al); if (SCM_CAR (fl) == var) { @@ -652,23 +654,23 @@ scm_m_lambda (xorig, env) if (scm_ilength (x) < 2) goto badforms; proc = SCM_CAR (x); - if SCM_NULLP - (proc) goto memlambda; - if SCM_IMP - (proc) goto badforms; - if SCM_SYMBOLP - (proc) goto memlambda; - if SCM_NCONSP - (proc) goto badforms; - while SCM_NIMP - (proc) + if (SCM_NULLP (proc)) + goto memlambda; + if (SCM_IMP (proc)) + goto badforms; + if (SCM_SYMBOLP (proc)) + goto memlambda; + if (SCM_NCONSP (proc)) + goto badforms; + while (SCM_NIMP (proc)) { - if SCM_NCONSP - (proc) + if (SCM_NCONSP (proc)) + { if (!SCM_SYMBOLP (proc)) - goto badforms; - else - goto memlambda; + goto badforms; + else + goto memlambda; + } if (!(SCM_NIMP (SCM_CAR (proc)) && SCM_SYMBOLP (SCM_CAR (proc)))) goto badforms; proc = SCM_CDR (proc); @@ -1316,6 +1318,7 @@ scm_eval_args (l, env) returns, rendering the jump buffer invalid. Duh. Gotta find a better way... -JimB */ #define safe_setjmp(x) setjmp (x) +#if 0 static int unsafe_setjmp (jmp_buf env) { @@ -1326,6 +1329,7 @@ unsafe_setjmp (jmp_buf env) val = setjmp (env); return val; } +#endif #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; +scm_option scm_eval_opts[] = { + { SCM_OPTION_INTEGER, "stack", 0x10000, "Size of thread stacks." } +}; + scm_option scm_debug_opts[] = { { SCM_OPTION_BOOLEAN, "cheap", 1, "*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_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_deval_args (l, env, lloc) SCM l, env, *lloc; @@ -2104,18 +2145,20 @@ evapply: ? SCM_ENTITY_PROC_0 (proc) : SCM_OPERATOR_PROC_0 (proc)); if (SCM_NIMP (x)) - if (SCM_TYP7 (x) == scm_tc7_subr_1) - RETURN (SCM_SUBRF (x) (proc)) - else if (SCM_CLOSUREP (x)) - { - t.arg1 = proc; - proc = x; + { + if (SCM_TYP7 (x) == scm_tc7_subr_1) + RETURN (SCM_SUBRF (x) (proc)) + else if (SCM_CLOSUREP (x)) + { + t.arg1 = proc; + proc = x; #ifdef DEVAL - debug.info->a.args = scm_cons (t.arg1, SCM_EOL); - debug.info->a.proc = proc; + debug.info->a.args = scm_cons (t.arg1, SCM_EOL); + debug.info->a.proc = proc; #endif - goto clos1; - } + goto clos1; + } + } /* Fall through. */ } case scm_tc7_contin: @@ -2230,19 +2273,22 @@ evapply: ? SCM_ENTITY_PROC_1 (proc) : SCM_OPERATOR_PROC_1 (proc)); if (SCM_NIMP (x)) - if (SCM_TYP7 (x) == scm_tc7_subr_2) - RETURN (SCM_SUBRF (x) (proc, t.arg1)) - else if (SCM_CLOSUREP (x)) - { - arg2 = t.arg1; - t.arg1 = proc; - proc = x; + { + if (SCM_TYP7 (x) == scm_tc7_subr_2) + RETURN (SCM_SUBRF (x) (proc, t.arg1)) + else if (SCM_CLOSUREP (x)) + { + arg2 = t.arg1; + t.arg1 = proc; + proc = x; #ifdef DEVAL - debug.info->a.args = scm_cons (t.arg1, debug.info->a.args); - debug.info->a.proc = proc; + debug.info->a.args = scm_cons (t.arg1, + debug.info->a.args); + debug.info->a.proc = proc; #endif - goto clos2; - } + goto clos2; + } + } /* Fall through. */ } case scm_tc7_contin: @@ -2313,22 +2359,25 @@ evapply: ? SCM_ENTITY_PROC_2 (proc) : SCM_OPERATOR_PROC_2 (proc)); if (SCM_NIMP (x)) - if (SCM_TYP7 (x) == scm_tc7_subr_3) - RETURN (SCM_SUBRF (x) (proc, t.arg1, arg2)) - else if (SCM_CLOSUREP (x)) - { + { + if (SCM_TYP7 (x) == scm_tc7_subr_3) + RETURN (SCM_SUBRF (x) (proc, t.arg1, arg2)) + else if (SCM_CLOSUREP (x)) + { #ifdef DEVAL - SCM_SET_ARGSREADY (debug); - debug.info->a.args = scm_cons (proc, debug.info->a.args); - debug.info->a.proc = x; -#endif - env = EXTEND_ENV (SCM_CAR (SCM_CODE (x)), - scm_cons2 (proc, t.arg1, - scm_cons (arg2, env)), - SCM_ENV (x)); - x = SCM_CODE (x); - goto cdrxbegin; - } + SCM_SET_ARGSREADY (debug); + debug.info->a.args = scm_cons (proc, + debug.info->a.args); + debug.info->a.proc = x; +#endif + env = EXTEND_ENV (SCM_CAR (SCM_CODE (x)), + scm_cons2 (proc, t.arg1, + scm_cons (arg2, env)), + SCM_ENV (x)); + x = SCM_CODE (x); + goto cdrxbegin; + } + } /* Fall through. */ } case scm_tc7_subr_0: @@ -2472,36 +2521,38 @@ evapply: ? SCM_ENTITY_PROC_3 (proc) : SCM_OPERATOR_PROC_3 (proc)); if (SCM_NIMP (p)) - if (SCM_TYP7 (p) == scm_tc7_lsubr_2) + { + if (SCM_TYP7 (p) == scm_tc7_lsubr_2) #ifdef DEVAL - RETURN (SCM_SUBRF (p) (proc, t.arg1, - scm_cons (arg2, SCM_CDDR (debug.info->a.args)))) + RETURN (SCM_SUBRF (p) (proc, t.arg1, + scm_cons (arg2, SCM_CDDR (debug.info->a.args)))) #else - RETURN (SCM_SUBRF (p) (proc, t.arg1, - scm_cons (arg2, - scm_eval_args (x, env)))) + RETURN (SCM_SUBRF (p) (proc, t.arg1, + scm_cons (arg2, + scm_eval_args (x, env)))) #endif - else if (SCM_CLOSUREP (p)) - { + else if (SCM_CLOSUREP (p)) + { #ifdef DEVAL - SCM_SET_ARGSREADY (debug); - debug.info->a.args = scm_cons (proc, debug.info->a.args); - debug.info->a.proc = p; - env = EXTEND_ENV (SCM_CAR (SCM_CODE (p)), - scm_cons2 (proc, t.arg1, - scm_cons (arg2, - SCM_CDDDR (debug.info->a.args))), - SCM_ENV (p)); + SCM_SET_ARGSREADY (debug); + debug.info->a.args = scm_cons (proc, debug.info->a.args); + debug.info->a.proc = p; + env = EXTEND_ENV (SCM_CAR (SCM_CODE (p)), + scm_cons2 (proc, t.arg1, + scm_cons (arg2, + SCM_CDDDR (debug.info->a.args))), + SCM_ENV (p)); #else - env = EXTEND_ENV (SCM_CAR (SCM_CODE (p)), - scm_cons2 (proc, t.arg1, - scm_cons (arg2, - scm_eval_args (x, env))), - SCM_ENV (p)); -#endif - x = SCM_CODE (p); - goto cdrxbegin; - } + env = EXTEND_ENV (SCM_CAR (SCM_CODE (p)), + scm_cons2 (proc, t.arg1, + scm_cons (arg2, + scm_eval_args (x, env))), + SCM_ENV (p)); +#endif + x = SCM_CODE (p); + goto cdrxbegin; + } + } /* Fall through. */ } case scm_tc7_subr_2: @@ -3348,6 +3399,13 @@ scm_make_synt (name, macroizer, fcn) void 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_macro = scm_newsmob (¯osmob); scm_i_apply = scm_make_subr ("apply", scm_tc7_lsubr_2, scm_apply); |