summaryrefslogtreecommitdiffstats
path: root/eval.c
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:29 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:29 -0800
commit302e3218b7d487539ec305bf23881a6ee7d5be99 (patch)
treebf1adafe552a17b3b78522048bb7c24787696dd3 /eval.c
parentc7d035ae1a729232579a0fe41ed5affa131d3623 (diff)
downloadscm-302e3218b7d487539ec305bf23881a6ee7d5be99.tar.gz
scm-302e3218b7d487539ec305bf23881a6ee7d5be99.zip
Import Upstream version 5e1upstream/5e1
Diffstat (limited to 'eval.c')
-rw-r--r--eval.c47
1 files changed, 35 insertions, 12 deletions
diff --git a/eval.c b/eval.c
index d5bba5f..3e39bee 100644
--- a/eval.c
+++ b/eval.c
@@ -144,7 +144,7 @@ SCM m_define_syntax P((SCM xorig, SCM env, SCM ctxt));
SCM m_let_syntax P((SCM xorig, SCM env, SCM ctxt));
SCM m_letrec_syntax P((SCM xorig, SCM env, SCM ctxt));
SCM m_the_macro P((SCM xorig, SCM env, SCM ctxt));
-void scm_dynthrow P((SCM cont, SCM val));
+void scm_dynthrow P((SCM cont, SCM arg1, SCM arg2, SCM rest));
void scm_egc P((void));
void scm_estk_grow P((void));
void scm_estk_shrink P((void));
@@ -757,6 +757,7 @@ static SCM toplevel_define(xorig, env)
SCM name = CAR(x);
ASRTER(scm_nullenv_p(env), xorig, s_placement, s_define);
ENV_PUSH;
+ scm_env_tmp = EOL; /* Make sure multiple values -> error */
x = cons(m_binding(name, CAR(CDR(x)), env, EOL), EOL);
x = evalcar(x);
ENV_POP;
@@ -1056,10 +1057,12 @@ static int in_atcase_aux = 0;
SCM m_case(xorig, env, ctxt)
SCM xorig, env, ctxt;
{
- SCM clause, x = CDR(xorig), key_expr = CAR(x);
+ SCM clause, key_expr, x = CDR(xorig);
SCM s, keys = EOL, action, actions = EOL, else_action = list_unspecified;
int opt = !scm_nullenv_p(env);
+
ASSYNT(ilength(x) >= 2, xorig, s_clauses, s_case);
+ key_expr = CAR(x);
while(NIMP(x = CDR(x))) {
clause = CAR(x);
s = scm_check_linum(clause, 0L);
@@ -1773,6 +1776,12 @@ static SCM macroexp1(xorig, env, ctxt, mode)
goto retx;
}
}
+#ifndef RECKLESS
+ if (ilength(x) < 0) {
+ what = s_expr;
+ goto errout;
+ }
+#endif
x = cons2(IM_FUNCALL, proc, CDR(x));
goto retx;
}
@@ -1930,8 +1939,10 @@ int scm_arity_check(proc, argc, what)
if (what) wta(proc, (char *)WNA, what);
return 0;
case tc7_subr_0: ASRTGO(0==argc, wrongnumargs) return !0;
- case tc7_cxr:
case tc7_contin:
+ if (IM_VALUES_TOKEN == CONT(proc)->other.stkframe[1]) return !0;
+ /* else fall through */
+ case tc7_cxr:
case tc7_subr_1: ASRTGO(1==argc, wrongnumargs) return !0;
case tc7_subr_1o: ASRTGO(0==argc || 1==argc, wrongnumargs) return !0;
case tc7_subr_2: ASRTGO(2==argc, wrongnumargs) return !0;
@@ -2193,6 +2204,8 @@ static SCM ceval_1(x)
goto cdrxbegin;
}
*/
+ scm_env_tmp = EOL; /* needed so multiple values cause an error
+ to be signaled when this is a top-level form. */
do {
scm_env_tmp = EVALCAR(proc);
proc = CDR(proc);
@@ -2403,6 +2416,7 @@ static SCM ceval_1(x)
return scm_values(UNDEFINED, UNDEFINED, EOL, s_values);
}
case tc7_contin:
+ scm_dynthrow(proc, UNDEFINED, UNDEFINED, EOL);
case tc7_subr_1:
case tc7_subr_2:
case tc7_subr_2o:
@@ -2493,7 +2507,7 @@ evap1:
goto clo_checked;
}
case tc7_contin:
- scm_dynthrow(proc, arg1);
+ scm_dynthrow(proc, arg1, UNDEFINED, EOL);
case tc7_specfun:
switch TYP16(proc) {
case tc16_call_cc:
@@ -2625,6 +2639,7 @@ evap1:
case tc7_subr_1:
case tc7_subr_3:
case tc7_contin:
+ scm_dynthrow(proc, arg1, arg2, EOL);
goto wrongnumargs;
default:
goto badfun;
@@ -2721,13 +2736,14 @@ evap1:
case tc16_values:
return scm_values(arg1, arg2, cons(arg3, x), s_values);
}
+ case tc7_contin:
+ scm_dynthrow(proc, arg1, arg2, cons(arg3, x));
case tc7_subr_2:
case tc7_subr_1o:
case tc7_subr_2o:
case tc7_subr_0:
case tc7_cxr:
case tc7_subr_1:
- case tc7_contin:
goto wrongnumargs;
default:
goto badfun;
@@ -2922,8 +2938,8 @@ SCM apply(proc, arg1, args)
return arg1;
}
case tc7_contin:
- ASRTGO(NULLP(args), wrongnumargs);
- scm_dynthrow(proc, arg1);
+ if (NULLP(args)) scm_dynthrow(proc, arg1, UNDEFINED, EOL);
+ /* else fall through */
case tc7_specfun:
args = UNBNDP(arg1) ? EOL : cons(arg1, args);
arg1 = proc;
@@ -3023,7 +3039,8 @@ SCM scm_cvapply(proc, n, argv)
return res;
}
case tc7_contin:
- scm_dynthrow(proc, argv[0]);
+ if (1 == n) scm_dynthrow(proc, argv[0], UNDEFINED, EOL);
+ goto call_apply;
case tc7_specfun:
if (tc16_apply==TYP16(proc)) {
proc = argv[0];
@@ -3034,6 +3051,7 @@ SCM scm_cvapply(proc, n, argv)
#endif
goto tail;
}
+ call_apply:
res = cons(proc, 0==n ? EOL : scm_v2lst(n, argv, EOL));
#ifdef CCLO
proc = (TYP16(proc)==tc16_cclo ? CCLO_SUBR(proc) : f_apply_closure);
@@ -3375,10 +3393,15 @@ SCM eval(obj)
return EVAL(obj, EOL, EOL);
}
-SCM definedp(x, env)
- SCM x, env;
+static char s_definedp[] = "defined?";
+SCM definedp(xorig, env, ctxt)
+ SCM xorig, env, ctxt;
{
- SCM proc = CAR(x = CDR(x));
+ SCM x = CDR(xorig);
+ SCM proc;
+
+ ASSYNT(1 == ilength(x), xorig, s_body, s_definedp);
+ proc = CAR(x);
#ifdef MACRO
proc = id2sym(proc);
#endif
@@ -3661,7 +3684,7 @@ void init_eval()
loc_atcase_aux = &CDR(sysintern("@case-aux", UNDEFINED));
/* acros */
- make_synt("defined?", MAC_ACRO, definedp);
+ make_synt(s_definedp, MAC_ACRO, definedp);
/* end of acros */
make_synt(s_and, MAC_MMACRO, m_and);