summaryrefslogtreecommitdiff
path: root/libguile/eval.c
diff options
context:
space:
mode:
authorDirk Herrmann <dirk@dirk-herrmanns-seiten.de>2002-03-21 00:36:03 +0000
committerDirk Herrmann <dirk@dirk-herrmanns-seiten.de>2002-03-21 00:36:03 +0000
commit42030fb2757235458db8f78a5218581d8f1a94a8 (patch)
tree1e45c66ef41a51541d64cf8e188927ce5abb45db /libguile/eval.c
parente050d4f8240ff1b123ccd5687633d5be241c445c (diff)
downloadguile-42030fb2757235458db8f78a5218581d8f1a94a8.tar.gz
* eval.c (SCM_CEVAL): Minimized scope of variable arg2.
Eliminated redundant SCM_IMP check. Exlined call to EVALCAR. Re-enabled handing of rpsubrs and asubrs.
Diffstat (limited to 'libguile/eval.c')
-rw-r--r--libguile/eval.c697
1 files changed, 338 insertions, 359 deletions
diff --git a/libguile/eval.c b/libguile/eval.c
index f8a52afd0..bd1059b87 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -1884,7 +1884,7 @@ scm_deval (SCM x, SCM env)
SCM
SCM_CEVAL (SCM x, SCM env)
{
- SCM proc, arg1, arg2;
+ SCM proc, arg1;
#ifdef DEVAL
scm_t_debug_frame debug;
scm_t_debug_info *debug_info_end;
@@ -2925,423 +2925,402 @@ evapply: /* inputs: x, proc */
debug.info->a.args = scm_list_1 (arg1);
#endif
x = SCM_CDR (x);
- if (SCM_NULLP (x))
- {
- ENTER_APPLY;
- evap1:
- switch (SCM_TYP7 (proc))
- { /* have one argument in arg1 */
- case scm_tc7_subr_2o:
- RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED));
- case scm_tc7_subr_1:
- case scm_tc7_subr_1o:
- RETURN (SCM_SUBRF (proc) (arg1));
- case scm_tc7_cxr:
- if (SCM_SUBRF (proc))
- {
- if (SCM_INUMP (arg1))
- {
- RETURN (scm_make_real (SCM_DSUBRF (proc) ((double) SCM_INUM (arg1))));
- }
- else if (SCM_REALP (arg1))
- {
- RETURN (scm_make_real (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1))));
- }
+ {
+ SCM arg2;
+ if (SCM_NULLP (x))
+ {
+ ENTER_APPLY;
+ evap1: /* inputs: proc, arg1 */
+ switch (SCM_TYP7 (proc))
+ { /* have one argument in arg1 */
+ case scm_tc7_subr_2o:
+ RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED));
+ case scm_tc7_subr_1:
+ case scm_tc7_subr_1o:
+ RETURN (SCM_SUBRF (proc) (arg1));
+ case scm_tc7_cxr:
+ if (SCM_SUBRF (proc))
+ {
+ if (SCM_INUMP (arg1))
+ {
+ RETURN (scm_make_real (SCM_DSUBRF (proc) ((double) SCM_INUM (arg1))));
+ }
+ else if (SCM_REALP (arg1))
+ {
+ RETURN (scm_make_real (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1))));
+ }
#ifdef SCM_BIGDIG
- else if (SCM_BIGP (arg1))
+ else if (SCM_BIGP (arg1))
+ {
+ RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1))));
+ }
+#endif
+ SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1,
+ SCM_ARG1, SCM_SYMBOL_CHARS (SCM_SNAME (proc)));
+ }
+ proc = SCM_SNAME (proc);
+ {
+ char *chrs = SCM_SYMBOL_CHARS (proc) + SCM_SYMBOL_LENGTH (proc) - 1;
+ while ('c' != *--chrs)
{
- RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1))));
+ SCM_ASSERT (SCM_CONSP (arg1),
+ arg1, SCM_ARG1, SCM_SYMBOL_CHARS (proc));
+ arg1 = ('a' == *chrs) ? SCM_CAR (arg1) : SCM_CDR (arg1);
}
-#endif
- SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1,
- SCM_ARG1, SCM_SYMBOL_CHARS (SCM_SNAME (proc)));
+ RETURN (arg1);
}
- proc = SCM_SNAME (proc);
- {
- char *chrs = SCM_SYMBOL_CHARS (proc) + SCM_SYMBOL_LENGTH (proc) - 1;
- while ('c' != *--chrs)
- {
- SCM_ASSERT (SCM_CONSP (arg1),
- arg1, SCM_ARG1, SCM_SYMBOL_CHARS (proc));
- arg1 = ('a' == *chrs) ? SCM_CAR (arg1) : SCM_CDR (arg1);
- }
- RETURN (arg1);
- }
- case scm_tc7_rpsubr:
- RETURN (SCM_BOOL_T);
- case scm_tc7_asubr:
- RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED));
- case scm_tc7_lsubr:
+ case scm_tc7_rpsubr:
+ RETURN (SCM_BOOL_T);
+ 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));
+ RETURN (SCM_SUBRF (proc) (debug.info->a.args));
#else
- RETURN (SCM_SUBRF (proc) (scm_list_1 (arg1)));
+ 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_cclo:
- arg2 = arg1;
- arg1 = proc;
- proc = SCM_CCLO_SUBR (proc);
+ case scm_tc7_smob:
+ if (!SCM_SMOB_APPLICABLE_P (proc))
+ goto badfun;
+ RETURN (SCM_SMOB_APPLY_1 (proc, arg1));
+ case scm_tc7_cclo:
+ arg2 = arg1;
+ arg1 = proc;
+ proc = SCM_CCLO_SUBR (proc);
#ifdef DEVAL
- debug.info->a.args = scm_cons (arg1, debug.info->a.args);
- debug.info->a.proc = proc;
+ debug.info->a.args = scm_cons (arg1, debug.info->a.args);
+ debug.info->a.proc = proc;
#endif
- goto evap2;
- case scm_tc7_pws:
- proc = SCM_PROCEDURE (proc);
+ goto evap2;
+ case scm_tc7_pws:
+ proc = SCM_PROCEDURE (proc);
#ifdef DEVAL
- debug.info->a.proc = proc;
+ debug.info->a.proc = proc;
#endif
- if (!SCM_CLOSUREP (proc))
- goto evap1;
- if (scm_badformalsp (proc, 1))
- goto umwrongnumargs;
- case scm_tcs_closures:
- /* clos1: */
- x = SCM_CLOSURE_BODY (proc);
+ if (!SCM_CLOSUREP (proc))
+ goto evap1;
+ if (scm_badformalsp (proc, 1))
+ goto umwrongnumargs;
+ case scm_tcs_closures:
+ /* clos1: */
+ x = SCM_CLOSURE_BODY (proc);
#ifdef DEVAL
- env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), debug.info->a.args, SCM_ENV (proc));
+ env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), debug.info->a.args, SCM_ENV (proc));
#else
- env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), scm_list_1 (arg1), SCM_ENV (proc));
+ env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), scm_list_1 (arg1), SCM_ENV (proc));
#endif
- goto nontoplevel_begin;
- case scm_tcs_struct:
- if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
- {
- x = SCM_ENTITY_PROCEDURE (proc);
+ goto nontoplevel_begin;
+ case scm_tcs_struct:
+ if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
+ {
+ x = SCM_ENTITY_PROCEDURE (proc);
#ifdef DEVAL
- arg1 = debug.info->a.args;
+ arg1 = debug.info->a.args;
#else
- arg1 = scm_list_1 (arg1);
+ arg1 = scm_list_1 (arg1);
#endif
- goto type_dispatch;
- }
- else if (!SCM_I_OPERATORP (proc))
- goto badfun;
- else
- {
- arg2 = arg1;
- arg1 = proc;
- proc = (SCM_I_ENTITYP (proc)
- ? SCM_ENTITY_PROCEDURE (proc)
- : SCM_OPERATOR_PROCEDURE (proc));
+ goto type_dispatch;
+ }
+ else if (!SCM_I_OPERATORP (proc))
+ goto badfun;
+ else
+ {
+ arg2 = arg1;
+ arg1 = proc;
+ proc = (SCM_I_ENTITYP (proc)
+ ? SCM_ENTITY_PROCEDURE (proc)
+ : SCM_OPERATOR_PROCEDURE (proc));
#ifdef DEVAL
- debug.info->a.args = scm_cons (arg1, debug.info->a.args);
- debug.info->a.proc = proc;
+ debug.info->a.args = scm_cons (arg1, debug.info->a.args);
+ debug.info->a.proc = proc;
#endif
- if (SCM_NIMP (proc))
- goto evap2;
- else
- goto badfun;
- }
- case scm_tc7_subr_2:
- case scm_tc7_subr_0:
- case scm_tc7_subr_3:
- case scm_tc7_lsubr_2:
- goto wrongnumargs;
- default:
- goto badfun;
- }
- }
+ if (SCM_NIMP (proc))
+ goto evap2;
+ else
+ goto badfun;
+ }
+ case scm_tc7_subr_2:
+ case scm_tc7_subr_0:
+ case scm_tc7_subr_3:
+ case scm_tc7_lsubr_2:
+ goto wrongnumargs;
+ default:
+ goto badfun;
+ }
+ }
#ifdef SCM_CAUTIOUS
- if (SCM_IMP (x))
- goto wrongnumargs;
- else if (SCM_CONSP (x))
- {
- if (SCM_IMP (SCM_CAR (x)))
- arg2 = SCM_EVALIM (SCM_CAR (x), env);
- else
- arg2 = EVALCELLCAR (x, env);
- }
- else
- goto wrongnumargs;
+ if (SCM_CONSP (x))
+ arg2 = EVALCAR (x, env);
+ else
+ goto wrongnumargs;
#else
- arg2 = EVALCAR (x, env);
+ arg2 = EVALCAR (x, env);
#endif
- { /* have two or more arguments */
+ { /* have two or more arguments */
#ifdef DEVAL
- debug.info->a.args = scm_list_2 (arg1, arg2);
+ debug.info->a.args = scm_list_2 (arg1, arg2);
#endif
- x = SCM_CDR (x);
- if (SCM_NULLP (x)) {
- ENTER_APPLY;
- evap2:
- switch (SCM_TYP7 (proc))
- { /* have two arguments */
- case scm_tc7_subr_2:
- case scm_tc7_subr_2o:
- RETURN (SCM_SUBRF (proc) (arg1, arg2));
- case scm_tc7_lsubr:
+ x = SCM_CDR (x);
+ if (SCM_NULLP (x)) {
+ ENTER_APPLY;
+ evap2:
+ switch (SCM_TYP7 (proc))
+ { /* have two arguments */
+ case scm_tc7_subr_2:
+ 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));
+ RETURN (SCM_SUBRF (proc) (debug.info->a.args));
#else
- RETURN (SCM_SUBRF (proc) (scm_list_2 (arg1, arg2)));
+ 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:
- case scm_tc7_asubr:
- RETURN (SCM_SUBRF (proc) (arg1, arg2));
- case scm_tc7_smob:
- if (!SCM_SMOB_APPLICABLE_P (proc))
- goto badfun;
- RETURN (SCM_SMOB_APPLY_2 (proc, arg1, arg2));
- cclon:
- case scm_tc7_cclo:
+ case scm_tc7_lsubr_2:
+ RETURN (SCM_SUBRF (proc) (arg1, arg2, SCM_EOL));
+ case scm_tc7_rpsubr:
+ case scm_tc7_asubr:
+ RETURN (SCM_SUBRF (proc) (arg1, arg2));
+ case scm_tc7_smob:
+ if (!SCM_SMOB_APPLICABLE_P (proc))
+ goto badfun;
+ RETURN (SCM_SMOB_APPLY_2 (proc, arg1, arg2));
+ cclon:
+ case scm_tc7_cclo:
#ifdef DEVAL
- RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc),
- scm_cons (proc, debug.info->a.args),
- SCM_EOL));
+ RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc),
+ scm_cons (proc, debug.info->a.args),
+ SCM_EOL));
#else
- RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc),
- scm_cons2 (proc, arg1,
- scm_cons (arg2,
- scm_eval_args (x,
- env,
- proc))),
- SCM_EOL));
+ RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc),
+ scm_cons2 (proc, arg1,
+ scm_cons (arg2,
+ scm_eval_args (x,
+ env,
+ proc))),
+ SCM_EOL));
#endif
- case scm_tcs_struct:
- if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
- {
- x = SCM_ENTITY_PROCEDURE (proc);
+ case scm_tcs_struct:
+ if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
+ {
+ x = SCM_ENTITY_PROCEDURE (proc);
#ifdef DEVAL
- arg1 = debug.info->a.args;
+ arg1 = debug.info->a.args;
#else
- arg1 = scm_list_2 (arg1, arg2);
+ arg1 = scm_list_2 (arg1, arg2);
#endif
- goto type_dispatch;
- }
- else if (!SCM_I_OPERATORP (proc))
+ goto type_dispatch;
+ }
+ else if (!SCM_I_OPERATORP (proc))
+ goto badfun;
+ else
+ {
+ operatorn:
+#ifdef DEVAL
+ RETURN (SCM_APPLY (SCM_I_ENTITYP (proc)
+ ? SCM_ENTITY_PROCEDURE (proc)
+ : SCM_OPERATOR_PROCEDURE (proc),
+ scm_cons (proc, debug.info->a.args),
+ SCM_EOL));
+#else
+ RETURN (SCM_APPLY (SCM_I_ENTITYP (proc)
+ ? SCM_ENTITY_PROCEDURE (proc)
+ : SCM_OPERATOR_PROCEDURE (proc),
+ scm_cons2 (proc, arg1,
+ scm_cons (arg2,
+ scm_eval_args (x,
+ env,
+ proc))),
+ SCM_EOL));
+#endif
+ }
+ case scm_tc7_subr_0:
+ case scm_tc7_cxr:
+ case scm_tc7_subr_1o:
+ case scm_tc7_subr_1:
+ case scm_tc7_subr_3:
+ goto wrongnumargs;
+ default:
goto badfun;
- else
- {
- operatorn:
+ case scm_tc7_pws:
+ proc = SCM_PROCEDURE (proc);
+#ifdef DEVAL
+ debug.info->a.proc = proc;
+#endif
+ if (!SCM_CLOSUREP (proc))
+ goto evap2;
+ if (scm_badformalsp (proc, 2))
+ goto umwrongnumargs;
+ case scm_tcs_closures:
+ /* clos2: */
#ifdef DEVAL
- RETURN (SCM_APPLY (SCM_I_ENTITYP (proc)
- ? SCM_ENTITY_PROCEDURE (proc)
- : SCM_OPERATOR_PROCEDURE (proc),
- scm_cons (proc, debug.info->a.args),
- SCM_EOL));
+ env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
+ debug.info->a.args,
+ SCM_ENV (proc));
#else
- RETURN (SCM_APPLY (SCM_I_ENTITYP (proc)
- ? SCM_ENTITY_PROCEDURE (proc)
- : SCM_OPERATOR_PROCEDURE (proc),
- scm_cons2 (proc, arg1,
- scm_cons (arg2,
- scm_eval_args (x,
- env,
- proc))),
- SCM_EOL));
+ env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
+ scm_list_2 (arg1, arg2), SCM_ENV (proc));
#endif
- }
- case scm_tc7_subr_0:
- case scm_tc7_cxr:
- case scm_tc7_subr_1o:
- case scm_tc7_subr_1:
+ x = SCM_CLOSURE_BODY (proc);
+ goto nontoplevel_begin;
+ }
+ }
+#ifdef SCM_CAUTIOUS
+ if (!SCM_CONSP (x))
+ goto wrongnumargs;
+#endif
+#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:
+ switch (SCM_TYP7 (proc))
+ { /* have 3 or more arguments */
+#ifdef DEVAL
case scm_tc7_subr_3:
- goto wrongnumargs;
- default:
- goto badfun;
+ SCM_ASRTGO (SCM_NULLP (SCM_CDR (x)), wrongnumargs);
+ RETURN (SCM_SUBRF (proc) (arg1, arg2,
+ SCM_CADDR (debug.info->a.args)));
+ case scm_tc7_asubr:
+ arg1 = SCM_SUBRF(proc)(arg1, arg2);
+ arg2 = SCM_CDDR (debug.info->a.args);
+ do
+ {
+ arg1 = SCM_SUBRF(proc)(arg1, SCM_CAR (arg2));
+ arg2 = SCM_CDR (arg2);
+ }
+ while (SCM_NIMP (arg2));
+ RETURN (arg1);
+ case scm_tc7_rpsubr:
+ if (SCM_FALSEP (SCM_SUBRF (proc) (arg1, arg2)))
+ RETURN (SCM_BOOL_F);
+ arg1 = SCM_CDDR (debug.info->a.args);
+ do
+ {
+ if (SCM_FALSEP (SCM_SUBRF (proc) (arg2, SCM_CAR (arg1))))
+ RETURN (SCM_BOOL_F);
+ arg2 = SCM_CAR (arg1);
+ arg1 = SCM_CDR (arg1);
+ }
+ while (SCM_NIMP (arg1));
+ RETURN (SCM_BOOL_T);
+ case scm_tc7_lsubr_2:
+ RETURN (SCM_SUBRF (proc) (arg1, arg2,
+ SCM_CDDR (debug.info->a.args)));
+ case scm_tc7_lsubr:
+ RETURN (SCM_SUBRF (proc) (debug.info->a.args));
+ case scm_tc7_smob:
+ if (!SCM_SMOB_APPLICABLE_P (proc))
+ goto badfun;
+ RETURN (SCM_SMOB_APPLY_3 (proc, arg1, arg2,
+ SCM_CDDR (debug.info->a.args)));
+ case scm_tc7_cclo:
+ goto cclon;
case scm_tc7_pws:
proc = SCM_PROCEDURE (proc);
-#ifdef DEVAL
debug.info->a.proc = proc;
-#endif
if (!SCM_CLOSUREP (proc))
- goto evap2;
- if (scm_badformalsp (proc, 2))
+ goto evap3;
+ if (scm_badargsp (SCM_CLOSURE_FORMALS (proc), debug.info->a.args))
goto umwrongnumargs;
case scm_tcs_closures:
- /* clos2: */
-#ifdef DEVAL
+ SCM_SET_ARGSREADY (debug);
env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
debug.info->a.args,
SCM_ENV (proc));
-#else
- env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
- scm_list_2 (arg1, arg2), SCM_ENV (proc));
-#endif
x = SCM_CLOSURE_BODY (proc);
goto nontoplevel_begin;
- }
- }
-#ifdef SCM_CAUTIOUS
- if (SCM_IMP (x) || !SCM_CONSP (x))
- goto wrongnumargs;
-#endif
-#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:
- switch (SCM_TYP7 (proc))
- { /* have 3 or more arguments */
-#ifdef DEVAL
- case scm_tc7_subr_3:
- SCM_ASRTGO (SCM_NULLP (SCM_CDR (x)), wrongnumargs);
- RETURN (SCM_SUBRF (proc) (arg1, arg2,
- SCM_CADDR (debug.info->a.args)));
- case scm_tc7_asubr:
-#ifdef BUILTIN_RPASUBR
- arg1 = SCM_SUBRF(proc)(arg1, arg2);
- arg2 = SCM_CDDR (debug.info->a.args);
- do
- {
- arg1 = SCM_SUBRF(proc)(arg1, SCM_CAR (arg2));
- arg2 = SCM_CDR (arg2);
- }
- while (SCM_NIMP (arg2));
- RETURN (arg1);
-#endif /* BUILTIN_RPASUBR */
- case scm_tc7_rpsubr:
-#ifdef BUILTIN_RPASUBR
- if (SCM_FALSEP (SCM_SUBRF (proc) (arg1, arg2)))
- RETURN (SCM_BOOL_F);
- arg1 = SCM_CDDR (debug.info->a.args);
- do
- {
- if (SCM_FALSEP (SCM_SUBRF (proc) (arg2, SCM_CAR (arg1))))
- RETURN (SCM_BOOL_F);
- arg2 = SCM_CAR (arg1);
- arg1 = SCM_CDR (arg1);
- }
- while (SCM_NIMP (arg1));
- RETURN (SCM_BOOL_T);
-#else /* BUILTIN_RPASUBR */
- RETURN (SCM_APPLY (proc, arg1,
- scm_acons (arg2,
- SCM_CDDR (debug.info->a.args),
- SCM_EOL)));
-#endif /* BUILTIN_RPASUBR */
- case scm_tc7_lsubr_2:
- RETURN (SCM_SUBRF (proc) (arg1, arg2,
- SCM_CDDR (debug.info->a.args)));
- case scm_tc7_lsubr:
- RETURN (SCM_SUBRF (proc) (debug.info->a.args));
- case scm_tc7_smob:
- if (!SCM_SMOB_APPLICABLE_P (proc))
- goto badfun;
- RETURN (SCM_SMOB_APPLY_3 (proc, arg1, arg2,
- SCM_CDDR (debug.info->a.args)));
- case scm_tc7_cclo:
- goto cclon;
- case scm_tc7_pws:
- proc = SCM_PROCEDURE (proc);
- debug.info->a.proc = proc;
- if (!SCM_CLOSUREP (proc))
- goto evap3;
- if (scm_badargsp (SCM_CLOSURE_FORMALS (proc), debug.info->a.args))
- goto umwrongnumargs;
- case scm_tcs_closures:
- SCM_SET_ARGSREADY (debug);
- env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
- debug.info->a.args,
- SCM_ENV (proc));
- x = SCM_CLOSURE_BODY (proc);
- goto nontoplevel_begin;
#else /* DEVAL */
- case scm_tc7_subr_3:
- SCM_ASRTGO (SCM_NULLP (SCM_CDR (x)), wrongnumargs);
- RETURN (SCM_SUBRF (proc) (arg1, arg2, EVALCAR (x, env)));
- case scm_tc7_asubr:
-#ifdef BUILTIN_RPASUBR
- arg1 = SCM_SUBRF (proc) (arg1, arg2);
- do
- {
- arg1 = SCM_SUBRF(proc)(arg1, EVALCAR(x, env));
- x = SCM_CDR(x);
- }
- while (SCM_NIMP (x));
- RETURN (arg1);
-#endif /* BUILTIN_RPASUBR */
- case scm_tc7_rpsubr:
-#ifdef BUILTIN_RPASUBR
- if (SCM_FALSEP (SCM_SUBRF (proc) (arg1, arg2)))
- RETURN (SCM_BOOL_F);
- do
+ case scm_tc7_subr_3:
+ SCM_ASRTGO (SCM_NULLP (SCM_CDR (x)), wrongnumargs);
+ 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_NIMP (x));
+ RETURN (arg1);
+ case scm_tc7_rpsubr:
+ if (SCM_FALSEP (SCM_SUBRF (proc) (arg1, arg2)))
+ RETURN (SCM_BOOL_F);
+ do
+ {
+ arg1 = EVALCAR (x, env);
+ if (SCM_FALSEP (SCM_SUBRF (proc) (arg2, arg1)))
+ RETURN (SCM_BOOL_F);
+ arg2 = arg1;
+ x = SCM_CDR (x);
+ }
+ while (SCM_NIMP (x));
+ RETURN (SCM_BOOL_T);
+ case scm_tc7_lsubr_2:
+ RETURN (SCM_SUBRF (proc) (arg1, arg2, scm_eval_args (x, env, proc)));
+ case scm_tc7_lsubr:
+ RETURN (SCM_SUBRF (proc) (scm_cons2 (arg1,
+ arg2,
+ scm_eval_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_eval_args (x, env, proc)));
+ case scm_tc7_cclo:
+ goto cclon;
+ case scm_tc7_pws:
+ proc = SCM_PROCEDURE (proc);
+ if (!SCM_CLOSUREP (proc))
+ goto evap3;
{
- arg1 = EVALCAR (x, env);
- if (SCM_FALSEP (SCM_SUBRF (proc) (arg2, arg1)))
- RETURN (SCM_BOOL_F);
- arg2 = arg1;
- x = SCM_CDR (x);
+ SCM formals = SCM_CLOSURE_FORMALS (proc);
+ if (SCM_NULLP (formals)
+ || (SCM_CONSP (formals)
+ && (SCM_NULLP (SCM_CDR (formals))
+ || (SCM_CONSP (SCM_CDR (formals))
+ && scm_badargsp (SCM_CDDR (formals), x)))))
+ goto umwrongnumargs;
}
- while (SCM_NIMP (x));
- RETURN (SCM_BOOL_T);
-#else /* BUILTIN_RPASUBR */
- RETURN (SCM_APPLY (proc, arg1,
- scm_acons (arg2,
- scm_eval_args (x, env, proc),
- SCM_EOL)));
-#endif /* BUILTIN_RPASUBR */
- case scm_tc7_lsubr_2:
- RETURN (SCM_SUBRF (proc) (arg1, arg2, scm_eval_args (x, env, proc)));
- case scm_tc7_lsubr:
- RETURN (SCM_SUBRF (proc) (scm_cons2 (arg1,
- arg2,
- scm_eval_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_eval_args (x, env, proc)));
- case scm_tc7_cclo:
- goto cclon;
- case scm_tc7_pws:
- proc = SCM_PROCEDURE (proc);
- if (!SCM_CLOSUREP (proc))
- goto evap3;
- {
- SCM formals = SCM_CLOSURE_FORMALS (proc);
- if (SCM_NULLP (formals)
- || (SCM_CONSP (formals)
- && (SCM_NULLP (SCM_CDR (formals))
- || (SCM_CONSP (SCM_CDR (formals))
- && scm_badargsp (SCM_CDDR (formals), x)))))
- goto umwrongnumargs;
- }
- case scm_tcs_closures:
+ case scm_tcs_closures:
#ifdef DEVAL
- SCM_SET_ARGSREADY (debug);
+ SCM_SET_ARGSREADY (debug);
#endif
- env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
- scm_cons2 (arg1,
- arg2,
- scm_eval_args (x, env, proc)),
- SCM_ENV (proc));
- x = SCM_CLOSURE_BODY (proc);
- goto nontoplevel_begin;
+ env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
+ scm_cons2 (arg1,
+ arg2,
+ scm_eval_args (x, env, proc)),
+ SCM_ENV (proc));
+ x = SCM_CLOSURE_BODY (proc);
+ goto nontoplevel_begin;
#endif /* DEVAL */
- case scm_tcs_struct:
- if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
- {
+ case scm_tcs_struct:
+ if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
+ {
#ifdef DEVAL
- arg1 = debug.info->a.args;
+ arg1 = debug.info->a.args;
#else
- arg1 = scm_cons2 (arg1, arg2, scm_eval_args (x, env, proc));
+ arg1 = scm_cons2 (arg1, arg2, scm_eval_args (x, env, proc));
#endif
- x = SCM_ENTITY_PROCEDURE (proc);
- goto type_dispatch;
- }
- else if (!SCM_I_OPERATORP (proc))
+ x = SCM_ENTITY_PROCEDURE (proc);
+ goto type_dispatch;
+ }
+ else if (!SCM_I_OPERATORP (proc))
+ goto badfun;
+ else
+ goto operatorn;
+ case scm_tc7_subr_2:
+ case scm_tc7_subr_1o:
+ case scm_tc7_subr_2o:
+ case scm_tc7_subr_0:
+ case scm_tc7_cxr:
+ case scm_tc7_subr_1:
+ goto wrongnumargs;
+ default:
goto badfun;
- else
- goto operatorn;
- case scm_tc7_subr_2:
- case scm_tc7_subr_1o:
- case scm_tc7_subr_2o:
- case scm_tc7_subr_0:
- case scm_tc7_cxr:
- case scm_tc7_subr_1:
- goto wrongnumargs;
- default:
- goto badfun;
- }
+ }
+ }
}
#ifdef DEVAL
exit: