From 879f4fa041cfdefee655eb877f1a91f86a9c62b7 Mon Sep 17 00:00:00 2001 From: Bryan Newbold Date: Fri, 3 Mar 2017 00:56:40 -0800 Subject: New upstream version 5f2 --- eval.c | 53 +++++++++++++++++++++++++++++++---------------------- 1 file changed, 31 insertions(+), 22 deletions(-) mode change 100644 => 100755 eval.c (limited to 'eval.c') diff --git a/eval.c b/eval.c old mode 100644 new mode 100755 index 407efc4..eda526d --- a/eval.c +++ b/eval.c @@ -116,7 +116,6 @@ SCM m_letrec P((SCM xorig, SCM env, SCM ctxt)); SCM m_let P((SCM xorig, SCM env, SCM ctxt)); SCM m_apply P((SCM xorig, SCM env, SCM ctxt)); SCM m_syn_quote P((SCM xorig, SCM env, SCM ctxt)); -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)); @@ -130,7 +129,7 @@ static SCM *lookupcar P((SCM vloc)); static SCM scm_lookupval P((SCM vloc, int memo)); static SCM asubr_apply P((SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM args)); static SCM ceval_1 P((SCM x)); -static SCM evalatomcar P((SCM x, int toplevelp)); +static SCM evalatomcar P((SCM x, int no_error)); static SCM evalcar P((SCM x)); static SCM id2sym P((SCM id)); static SCM iqq P((SCM form)); @@ -577,9 +576,9 @@ static SCM scm_lookupval(vloc, memo) } /* CAR(x) is known to be a cell but not a cons */ -static SCM evalatomcar(x, toplevelp) +static SCM evalatomcar(x, no_error) SCM x; - int toplevelp; + int no_error; { SCM ret; switch TYP7(CAR(x)) { @@ -597,7 +596,7 @@ static SCM evalatomcar(x, toplevelp) switch (MAC_TYPE(mac) & ~MAC_PRIMITIVE) { default: #ifdef MACRO - if (!toplevelp) + if (!no_error) everr(x, argv[1], argv[0], s_badkey, "", 0); #endif return ret; @@ -610,7 +609,7 @@ static SCM evalatomcar(x, toplevelp) return ret; case tc7_vector: #ifndef RECKLESS - if (2 <= verbose) scm_warn("unquoted ", s_vector, CAR(x)); + if (2 <= scm_verbose) scm_warn("unquoted ", s_vector, CAR(x)); #endif ret = cons2(IM_QUOTE, CAR(x), EOL); CAR(x) = ret; @@ -1490,14 +1489,14 @@ static void checked_define(name, val, what) if ('@'==CHARS(name)[0] && UNDEFINED != old) scm_warn(s_redefining, "internal name ", name); if (KEYWORDP(old)) { - if (1 <= verbose && built_inp(name, KEYWORD_MACRO(old))) + if (1 <= scm_verbose && built_inp(name, KEYWORD_MACRO(old))) scm_warn(s_redefining, s_built_in_syntax, name); - else if (3 <= verbose) + else if (3 <= scm_verbose) scm_warn(s_redefining, s_syntax, name); } - else if (2 <= verbose && built_inp(name, old) && (old != val)) + else if (2 <= scm_verbose && built_inp(name, old) && (old != val)) scm_warn(s_redefining, "built-in ", name); - else if (5 <= verbose && UNDEFINED != old) + else if (5 <= scm_verbose && UNDEFINED != old) scm_warn(s_redefining, "", name); #endif CDR(vcell) = val; @@ -1657,7 +1656,9 @@ static SCM m_body(xorig, env, ctxt) } ASSYNT(ilength(x) > 0, xorig, s_body, what); if (IMP(defs)) return x; - return cons(m_letrec1(IM_DEFINE, cons2(i_define, defs, x), env, ctxt), EOL); + return + cons(m_letrec1(IM_DEFINE, cons2(i_define, reverse(defs), x), env, ctxt), + EOL); } static SCM m_binding(name, value, env, ctxt) @@ -1746,18 +1747,19 @@ static SCM macroexp1(xorig, env, ctxt, mode) MACROEXP_TRACE(xorig, env); #endif x = scm_check_linum(xorig, &linum); - if (IMP(x) || NCONSP(x)) { /* Happens for unquoted vectors. */ + if (IMP(x) || VECTORP(x)) { /* Happens for unquoted vectors. */ if (NIMP(x)) x = evalatomcar(cons(x, EOL), 0); x = cons2(IM_QUOTE, x, EOL); goto retx; } - else if (IDENTP(x)) { /* Happens for @macroexpand1 */ + else if (IDENTP(x)) { /* Happens for @macroexpand1 */ + ASRTER(0==mode, x, "macroexp1", "internal error"); proc = x; - x = cons(proc, EOL); } - else + else { proc = CAR(x); + } ASRTGO(NIMP(proc), errout); if (CONSP(proc)) { if (mode < 3) { @@ -2071,7 +2073,7 @@ SCM scm_apply_cxr(proc, arg1) } # ifdef BIGDIG if (BIGP(arg1)) { - y = DSUBRF(proc)(big2dbl(arg1)); + y = DSUBRF(proc)(int2dbl(arg1)); goto ret; } # endif @@ -2685,13 +2687,13 @@ evap1: goto apply4; /* Jumping to apply code results in extra list copy for >=3 args, but we want to minimize bloat. */ } + case tc7_contin: + scm_dynthrow(proc, arg1, arg2, EOL); case tc7_subr_0: case tc7_cxr: case tc7_subr_1o: case tc7_subr_1: case tc7_subr_3: - case tc7_contin: - scm_dynthrow(proc, arg1, arg2, EOL); goto wrongnumargs; default: goto badfun; @@ -3252,14 +3254,21 @@ static char s_macroexpand1[] = "@macroexpand1"; SCM scm_macroexpand1(x, env) SCM x, env; { - SCM name; + SCM proc; if (IMP(x)) return BOOL_F; if (CONSP(x)) { - name = CAR(x); - if (IMP(name) || !IDENTP(name)) return BOOL_F; /* probably an error */ + proc = CAR(x); + if (IMP(proc) || !IDENTP(proc)) return BOOL_F; /* probably an error */ } else if (IDENTP(x)) { - name = x; + proc = scm_env_lookup(x, env); + if (IMP(proc)) /* local binding */ + return BOOL_F; + if (SYMBOLP(proc)) { /* global variable */ + proc = CDR(sym2vcell(proc)); + if (!KEYWORDP(proc)) + return BOOL_F; + } } else return BOOL_F; -- cgit v1.2.3