diff options
Diffstat (limited to 'eval.c')
| -rw-r--r-- | eval.c | 47 |
1 files changed, 35 insertions, 12 deletions
@@ -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); |