summaryrefslogtreecommitdiff
path: root/libguile/eval.c
diff options
context:
space:
mode:
Diffstat (limited to 'libguile/eval.c')
-rw-r--r--libguile/eval.c242
1 files changed, 175 insertions, 67 deletions
diff --git a/libguile/eval.c b/libguile/eval.c
index a6c8d3ccc..a709d4f69 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -2099,6 +2099,27 @@ evapply:
x = SCM_CODE (proc);
env = EXTEND_ENV (SCM_CAR (x), SCM_EOL, SCM_ENV (proc));
goto cdrxbegin;
+ case scm_tcs_cons_gloc:
+ if (SCM_I_OPERATORP (proc))
+ {
+ x = (SCM_I_ENTITYP (proc)
+ ? 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;
+#ifdef DEVAL
+ debug.info->a.args = scm_cons (t.arg1, SCM_EOL);
+ debug.info->a.proc = proc;
+#endif
+ goto clos1;
+ }
+ /* Fall through. */
+ }
case scm_tc7_contin:
case scm_tc7_subr_1:
case scm_tc7_subr_2:
@@ -2196,6 +2217,7 @@ evapply:
goto evap2;
#endif
case scm_tcs_closures:
+ clos1:
x = SCM_CODE (proc);
#ifdef DEVAL
env = EXTEND_ENV (SCM_CAR (x), debug.info->a.args, SCM_ENV (proc));
@@ -2203,27 +2225,30 @@ evapply:
env = EXTEND_ENV (SCM_CAR (x), scm_cons (t.arg1, SCM_EOL), SCM_ENV (proc));
#endif
goto cdrxbegin;
- case scm_tc7_contin:
- scm_call_continuation (proc, t.arg1);
case scm_tcs_cons_gloc:
- if (SCM_I_ENTITYP (proc))
+ if (SCM_I_OPERATORP (proc))
{
- x = SCM_ENTITY_PROC_1 (proc);
- 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;
+ x = (SCM_I_ENTITYP (proc)
+ ? 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;
#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:
+ scm_call_continuation (proc, t.arg1);
case scm_tc7_subr_2:
case scm_tc7_subr_0:
case scm_tc7_subr_3:
@@ -2273,7 +2298,8 @@ evapply:
#else
RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc), proc,
scm_cons2 (t.arg1, arg2,
- scm_cons (scm_eval_args (x, env), SCM_EOL))));
+ scm_cons (scm_eval_args (x, env),
+ SCM_EOL))));
#endif
/* case scm_tc7_cclo:
x = scm_cons(arg2, scm_eval_args(x, env));
@@ -2283,25 +2309,28 @@ evapply:
goto evap3; */
#endif
case scm_tcs_cons_gloc:
- if (SCM_I_ENTITYP (proc))
+ if (SCM_I_OPERATORP (proc))
{
- x = SCM_ENTITY_PROC_2 (proc);
- if (SCM_TYP7 (x) == scm_tc7_subr_3)
- RETURN (SCM_SUBRF (x) (proc, t.arg1, arg2))
- else if (SCM_CLOSUREP (x))
- {
+ x = (SCM_I_ENTITYP (proc)
+ ? 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))
+ {
#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 (proc));
- x = SCM_CODE (proc);
- 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:
@@ -2316,9 +2345,12 @@ evapply:
case scm_tcs_closures:
clos2:
#ifdef DEVAL
- env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)), debug.info->a.args, SCM_ENV (proc));
+ env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)),
+ debug.info->a.args,
+ SCM_ENV (proc));
#else
- env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)), scm_cons2 (t.arg1, arg2, SCM_EOL), SCM_ENV (proc));
+ env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)),
+ scm_cons2 (t.arg1, arg2, SCM_EOL), SCM_ENV (proc));
#endif
x = SCM_CODE (proc);
goto cdrxbegin;
@@ -2326,24 +2358,26 @@ evapply:
}
#ifdef DEVAL
debug.info->a.args = scm_cons2 (t.arg1, arg2,
- scm_deval_args (x, env, SCM_CDRLOC (SCM_CDR (debug.info->a.args))));
+ scm_deval_args (x, env, 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) (t.arg1, arg2, SCM_CAR (SCM_CDR (SCM_CDR (debug.info->a.args)))));
+ RETURN (SCM_SUBRF (proc) (t.arg1, arg2,
+ SCM_CADDR (debug.info->a.args)));
case scm_tc7_asubr:
#ifdef BUILTIN_RPASUBR
t.arg1 = SCM_SUBRF(proc)(t.arg1, arg2);
arg2 = SCM_CDR (SCM_CDR (debug.info->a.args));
- do {
- t.arg1 = SCM_SUBRF(proc)(t.arg1, SCM_CAR (arg2));
- arg2 = SCM_CDR (arg2);
- } while (SCM_NIMP (arg2));
+ do
+ {
+ t.arg1 = SCM_SUBRF(proc)(t.arg1, SCM_CAR (arg2));
+ arg2 = SCM_CDR (arg2);
+ }
+ while (SCM_NIMP (arg2));
RETURN (t.arg1)
#endif /* BUILTIN_RPASUBR */
case scm_tc7_rpsubr:
@@ -2351,18 +2385,24 @@ evapply:
if (SCM_FALSEP (SCM_SUBRF (proc) (t.arg1, arg2)))
RETURN (SCM_BOOL_F)
t.arg1 = SCM_CDR (SCM_CDR (debug.info->a.args));
- do {
- if (SCM_FALSEP (SCM_SUBRF (proc) (arg2, SCM_CAR (t.arg1))))
- RETURN (SCM_BOOL_F)
- arg2 = SCM_CAR (t.arg1);
- t.arg1 = SCM_CDR (t.arg1);
- } while (SCM_NIMP (t.arg1));
+ do
+ {
+ if (SCM_FALSEP (SCM_SUBRF (proc) (arg2, SCM_CAR (t.arg1))))
+ RETURN (SCM_BOOL_F)
+ arg2 = SCM_CAR (t.arg1);
+ t.arg1 = SCM_CDR (t.arg1);
+ }
+ while (SCM_NIMP (t.arg1));
RETURN (SCM_BOOL_T)
#else /* BUILTIN_RPASUBR */
- RETURN (SCM_APPLY (proc, t.arg1, scm_acons (arg2, SCM_CDR (SCM_CDR (debug.info->a.args)), SCM_EOL)))
+ RETURN (SCM_APPLY (proc, t.arg1,
+ scm_acons (arg2,
+ SCM_CDR (SCM_CDR (debug.info->a.args)),
+ SCM_EOL)))
#endif /* BUILTIN_RPASUBR */
case scm_tc7_lsubr_2:
- RETURN (SCM_SUBRF (proc) (t.arg1, arg2, SCM_CDR (SCM_CDR (debug.info->a.args))))
+ RETURN (SCM_SUBRF (proc) (t.arg1, arg2,
+ SCM_CDR (SCM_CDR (debug.info->a.args))))
case scm_tc7_lsubr:
RETURN (SCM_SUBRF (proc) (debug.info->a.args))
#ifdef CCLO
@@ -2382,27 +2422,32 @@ evapply:
RETURN (SCM_SUBRF (proc) (t.arg1, arg2, EVALCAR (x, env)));
case scm_tc7_asubr:
#ifdef BUILTIN_RPASUBR
- t.arg1 = SCM_SUBRF(proc)(t.arg1, arg2);
- do {
- t.arg1 = SCM_SUBRF(proc)(t.arg1, EVALCAR(x, env));
- x = SCM_CDR(x);
- } while (SCM_NIMP (x));
+ t.arg1 = SCM_SUBRF (proc) (t.arg1, arg2);
+ do
+ {
+ t.arg1 = SCM_SUBRF(proc)(t.arg1, EVALCAR(x, env));
+ x = SCM_CDR(x);
+ }
+ while (SCM_NIMP (x));
RETURN (t.arg1)
#endif /* BUILTIN_RPASUBR */
case scm_tc7_rpsubr:
#ifdef BUILTIN_RPASUBR
if (SCM_FALSEP (SCM_SUBRF (proc) (t.arg1, arg2)))
RETURN (SCM_BOOL_F)
- do {
- t.arg1 = EVALCAR (x, env);
- if (SCM_FALSEP (SCM_SUBRF (proc) (arg2, t.arg1)))
- RETURN (SCM_BOOL_F)
- arg2 = t.arg1;
- x = SCM_CDR (x);
- } while (SCM_NIMP (x));
+ do
+ {
+ t.arg1 = EVALCAR (x, env);
+ if (SCM_FALSEP (SCM_SUBRF (proc) (arg2, t.arg1)))
+ RETURN (SCM_BOOL_F)
+ arg2 = t.arg1;
+ x = SCM_CDR (x);
+ }
+ while (SCM_NIMP (x));
RETURN (SCM_BOOL_T)
#else /* BUILTIN_RPASUBR */
- RETURN (SCM_APPLY (proc, t.arg1, scm_acons (arg2, scm_eval_args (x, env), SCM_EOL)));
+ RETURN (SCM_APPLY (proc, t.arg1,
+ scm_acons (arg2, scm_eval_args (x, env), SCM_EOL)));
#endif /* BUILTIN_RPASUBR */
case scm_tc7_lsubr_2:
RETURN (SCM_SUBRF (proc) (t.arg1, arg2, scm_eval_args (x, env)));
@@ -2423,8 +2468,44 @@ evapply:
goto cdrxbegin;
#endif /* DEVAL */
case scm_tcs_cons_gloc:
- if (SCM_I_ENTITYP (proc))
- ;
+ if (SCM_I_OPERATORP (proc))
+ {
+ SCM p = (SCM_I_ENTITYP (proc)
+ ? SCM_ENTITY_PROC_3 (proc)
+ : SCM_OPERATOR_PROC_3 (proc));
+ if (SCM_NIMP (p))
+ 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))))
+#else
+ RETURN (SCM_SUBRF (p) (proc, t.arg1,
+ scm_cons (arg2,
+ scm_eval_args (x, env))))
+#endif
+ 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));
+#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;
+ }
+ /* Fall through. */
+ }
case scm_tc7_subr_2:
case scm_tc7_subr_1o:
case scm_tc7_subr_2o:
@@ -2777,8 +2858,35 @@ tail:
goto tail;
#endif
case scm_tcs_cons_gloc:
- if (SCM_I_ENTITYP (proc))
- ;
+ if (SCM_I_OPERATORP (proc))
+ {
+#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
+ arg1 = proc;
+ proc = (SCM_NULLP (args)
+ ? (SCM_I_ENTITYP (proc)
+ ? SCM_ENTITY_PROC_0 (proc)
+ : SCM_OPERATOR_PROC_0 (proc))
+ : SCM_NULLP (SCM_CDR (args))
+ ? (SCM_I_ENTITYP (proc)
+ ? SCM_ENTITY_PROC_1 (proc)
+ : SCM_OPERATOR_PROC_1 (proc))
+ : SCM_NULLP (SCM_CDDR (args))
+ ? (SCM_I_ENTITYP (proc)
+ ? SCM_ENTITY_PROC_2 (proc)
+ : SCM_OPERATOR_PROC_2 (proc))
+ : (SCM_I_ENTITYP (proc)
+ ? SCM_ENTITY_PROC_3 (proc)
+ : SCM_OPERATOR_PROC_3 (proc)));
+#ifdef DEVAL
+ debug.vect[0].a.proc = proc;
+ debug.vect[0].a.args = scm_cons (arg1, args);
+#endif
+ goto tail;
+ }
wrongnumargs:
scm_wrong_num_args (proc);
default: