diff options
author | Steve Langasek <vorlon@debian.org> | 2004-12-07 23:23:48 -0800 |
---|---|---|
committer | Bryan Newbold <bnewbold@robocracy.org> | 2017-02-20 00:05:28 -0800 |
commit | 37f2f5e0bb11a18deecf48c7ad6bcbf7bd932db2 (patch) | |
tree | 692caebb60ec5f80ce528a403b69351ca756d530 /eval.c | |
parent | e21d47d7813159bb71e0671df9b52ec0470c358d (diff) | |
parent | c7d035ae1a729232579a0fe41ed5affa131d3623 (diff) | |
download | scm-37f2f5e0bb11a18deecf48c7ad6bcbf7bd932db2.tar.gz scm-37f2f5e0bb11a18deecf48c7ad6bcbf7bd932db2.zip |
Import Debian changes 5d9-4.1debian/5d9-4.1
scm (5d9-4.1) unstable; urgency=high
* Non-maintainer upload.
* High-urgency upload for sarge-targetted RC bugfix.
* Revert upstream "CAUTIOUS" define, which causes the scm build to
fail its test suite on alpha (and, it appears, powerpc as well).
Closes: #245810.
scm (5d9-4) unstable; urgency=low
* Apply patch from 144062 to fix hppa build (Closes: #144062)
* Change scm.1 section from Jan 4 200 to 1. (lintian)
scm (5d9-3) unstable; urgency=low
* Properly clean up info files.
* Make and install Xlibscm.info.
scm (5d9-2) unstable; urgency=low
* Fix path problem in slibcat. Hack at mklibcat.scm. (Closes: #241510)
scm (5d9-1) unstable; urgency=low
* New upstream release
* Merge NMU sparc changes (Closes: #191171, #191356)
* SHORT_INT is defined for ia64 upstream (Closes: #141928)
* Scheme imps now grouped in info file (has been for a while)
(Closes: #115452)
Diffstat (limited to 'eval.c')
-rw-r--r-- | eval.c | 341 |
1 files changed, 190 insertions, 151 deletions
@@ -45,8 +45,16 @@ #include "scm.h" #include "setjump.h" -#define I_SYM(x) (CAR((x)-1L)) -#define I_VAL(x) (CDR((x)-1L)) +#ifdef _M_ARM +/* The Microsoft CLARM compiler has a bug in pointer arithmetic. + It doesn't always take into account that data acceses have to be + DWORD aligned. The MS_CLARM_dumy assignment resolves this problem. */ +# define I_SYM(x) (CAR((SCM)(MS_CLARM_dumy = (x)-1L))) +# define I_VAL(x) (CDR((SCM)(MS_CLARM_dumy = (x)-1L))) +#else +# define I_SYM(x) (CAR((x)-1L)) +# define I_VAL(x) (CDR((x)-1L)) +#endif #define ATOMP(x) (5==(5 & (int)CAR(x))) #define EVALCELLCAR(x) (ATOMP(CAR(x))?evalatomcar(x, 0):ceval_1(CAR(x))) #define EVALIMP(x) (ILOCP(x)?*ilookup(x):x) @@ -103,7 +111,7 @@ #endif #define EXTEND_ENV cons -SCM scm_env = EOL, scm_env_tmp = UNSPECIFIED; +SCM scm_env, scm_env_tmp; long tc16_env; /* Type code for environments passed to macro transformers. */ @@ -221,8 +229,7 @@ static void debug_env_save P((char *fnam, int line)); #endif #ifndef RECKLESS -SCM scm_trace = BOOL_F; -SCM scm_trace_env = EOL; +SCM scm_trace, scm_trace_env; #endif #define ENV_MAY_POP(p, guard) if (p>0 && !(guard)) {ENV_POP; p=-1;} #define ENV_MAY_PUSH(p) if (p<=0) {ENV_PUSH; p=1;} @@ -250,8 +257,8 @@ long tc16_macro; /* Type code for macros */ #define MAC_MACRO 0x8L #define MAC_MMACRO 0x2L #define MAC_IDMACRO 0x6L -/* uncomment this to experiment with inline procedures - #define MAC_INLINE 0x10L */ +/* Uncomment this to experiment with inline procedures: */ +/* #define MAC_INLINE 0x10L */ #ifdef MACRO long tc16_ident; /* synthetic macro identifier */ @@ -272,11 +279,16 @@ long eval_clo_cases[5][4]; /* actual args, required args */ SCM scm_profile(resetp) SCM resetp; { - SCM ev = make_uve(sizeof(eval_cases)/sizeof(long), MAKINUM(-1)); - SCM evo = make_uve(sizeof(eval_cases_other)/sizeof(long), MAKINUM(-1)); + SCM ev = make_uve(sizeof(eval_cases)/sizeof(long), + MAKINUM(-8L*sizeof(long))); + SCM evo = make_uve(sizeof(eval_cases_other)/sizeof(long), + MAKINUM(-8L*sizeof(long))); SCM il = dims2ura(cons2(MAKINUM(10), MAKINUM(10), cons(MAKINUM(2), EOL)), - MAKINUM(-1), EOL); - SCM evc = dims2ura(cons2(MAKINUM(5), MAKINUM(4), EOL), MAKINUM(-1), EOL); + MAKINUM(-8L*sizeof(long)), + EOL); + SCM evc = dims2ura(cons2(MAKINUM(5), MAKINUM(4), EOL), + MAKINUM(-8L*sizeof(long)), + EOL); long *v = (long *)VELTS(ev); int i; for (i = 0; i < sizeof(eval_cases)/sizeof(long); i++) @@ -291,14 +303,14 @@ SCM scm_profile(resetp) for (i = 0; i < sizeof(eval_clo_cases)/sizeof(long); i++) v[i] = ((long *)eval_clo_cases)[i]; if (! UNBNDP(resetp)) { - for (i = 0; i < sizeof(eval_cases)/sizeof(long); i++) - eval_cases[i] = 0; - for (i = 0; i < sizeof(eval_cases_other)/sizeof(long); i++) - eval_cases_other[i] = 0; - for (i = 0; i < sizeof(ilookup_cases)/sizeof(long); i++) - ((long *)ilookup_cases)[i] = 0; - for (i = 0; i < sizeof(eval_clo_cases)/sizeof(long); i++) - ((long *)eval_clo_cases)[i] = 0; + for (i = 0; i < sizeof(eval_cases)/sizeof(long); i++) + eval_cases[i] = 0; + for (i = 0; i < sizeof(eval_cases_other)/sizeof(long); i++) + eval_cases_other[i] = 0; + for (i = 0; i < sizeof(ilookup_cases)/sizeof(long); i++) + ((long *)ilookup_cases)[i] = 0; + for (i = 0; i < sizeof(eval_clo_cases)/sizeof(long); i++) + ((long *)eval_clo_cases)[i] = 0; } return cons2(ev, evo, cons2(il, evc, EOL)); } @@ -540,7 +552,7 @@ static SCM *lookupcar(vloc) #endif else { /* global ref */ #ifdef MACRO - ASSERT(SYMBOLP(addr), var, s_escaped, ""); + ASRTER(SYMBOLP(addr), var, s_escaped, ""); #endif val = sym2vcell(addr); addr = val + tc3_cons_gloc; @@ -549,7 +561,7 @@ static SCM *lookupcar(vloc) ASRTGO(!KEYWORDP(*pv), badkey); #endif } - ASSERT(!UNBNDP(*pv) && undefineds != *pv, var, s_unbnd, ""); + ASRTER(!UNBNDP(*pv) && undefineds != *pv, var, s_unbnd, ""); CAR(vloc) = addr; return pv; } @@ -576,13 +588,13 @@ static SCM scm_lookupval(vloc, memo) } else { /* global ref */ #ifdef MACRO - ASSERT(SYMBOLP(addr), var, s_escaped, ""); + ASRTER(SYMBOLP(addr), var, s_escaped, ""); #endif addr = sym2vcell(addr); val = CDR(addr); addr += tc3_cons_gloc; } - ASSERT(!UNBNDP(val) && val != undefineds, var, s_unbnd, ""); + ASRTER(!UNBNDP(val) && val != undefineds, var, s_unbnd, ""); if (memo && !KEYWORDP(val)) /* Don't memoize forms to be macroexpanded. */ CAR(vloc) = addr; return val; @@ -643,7 +655,7 @@ SCM scm_multi_set(syms, vals) SCM res = EOL, *pres = &res; SCM *loc; do { - ASSERT(NIMP(vals) && CONSP(vals), vals, WNA, s_set); + ASRTER(NIMP(vals) && CONSP(vals), vals, WNA, s_set); switch (7 & (int)(CAR(syms))) { case 0: loc = lookupcar(syms); @@ -661,7 +673,7 @@ SCM scm_multi_set(syms, vals) syms = CDR(syms); vals = CDR(vals); } while (NIMP(syms)); - ASSERT(NULLP(vals) && NULLP(syms), vals, WNA, s_set); + ASRTER(NULLP(vals) && NULLP(syms), vals, WNA, s_set); return res; } @@ -743,7 +755,7 @@ static SCM toplevel_define(xorig, env) { SCM x = CDR(xorig); SCM name = CAR(x); - ASSERT(scm_nullenv_p(env), xorig, s_placement, s_define); + ASRTER(scm_nullenv_p(env), xorig, s_placement, s_define); ENV_PUSH; x = cons(m_binding(name, CAR(CDR(x)), env, EOL), EOL); x = evalcar(x); @@ -845,7 +857,7 @@ SCM scm_values(arg1, arg2, rest, what) char *what; { DEFER_INTS_EGC; - ASSERT(IM_VALUES_TOKEN==scm_env_tmp, UNDEFINED, "one value expected", what); + ASRTER(IM_VALUES_TOKEN==scm_env_tmp, UNDEFINED, "one value expected", what); if (! UNBNDP(arg2)) scm_env_cons(arg2, rest); return arg1; @@ -1051,7 +1063,7 @@ SCM m_case(xorig, env, ctxt) while(NIMP(x = CDR(x))) { clause = CAR(x); s = scm_check_linum(clause, 0L); - ASSYNT(ilength(clause) >= 2, clause /* xorig */, s_clauses, s_case); + ASSYNT(ilength(s) >= 2, clause /* xorig */, s_clauses, s_case); clause = s; if (TOPDENOTE_EQ(i_else, CAR(clause), env)) { ASSYNT(NULLP(CDR(x)), xorig, s_bad_else_clause, s_case); @@ -1165,7 +1177,7 @@ SCM m_lambda(xorig, env, ctxt) SCM name, linum; #endif int argc; - ASSERT(ilength(x) > 1, x, s_body, s_lambda); + ASRTER(ilength(x) > 1, x, s_body, s_lambda); formals = CAR(x); argc = varcheck(formals, IM_LAMBDA, s_formals); formals = scm_check_linum(formals, 0L); @@ -1219,8 +1231,8 @@ SCM m_inline_lambda(xorig, env) SCM x = CDR(xorig); SCM typ = (SCM)(tc16_macro | (MAC_INLINE << 16)); int depth = env_depth(); - ASSERT(ilength(x) > 1, xorig, s_formals, s_lambda); - ASSERT(ilength(CAR(x)) >= 0, xorig, s_formals, s_lambda); + ASRTER(ilength(x) > 1, xorig, s_formals, s_lambda); + ASRTER(ilength(CAR(x)) >= 0, xorig, s_formals, s_lambda); varcheck(CAR(x), IM_LAMBDA, s_formals); x = cons2(typ, MAKINUM((long)depth), cons(CAR(x), m_body(CDR(x), env))); @@ -1235,13 +1247,13 @@ int scm_nullenv_p(env) SCM fr, e; if (IMP(env)) return !0; for (e = env; NIMP(e); e = CDR(e)) { - ASSERT(CONSP(e), e, s_badenv, s_nullenv_p); + ASRTER(CONSP(e), e, s_badenv, s_nullenv_p); fr = CAR(e); if (IMP(fr)) { if (NULLP(fr)) return 0; if (INUMP(fr)) { /* These frames are for meta-data, not bindings. */ e = CDR(e); - ASSERT(NIMP(e), env, s_badenv, s_nullenv_p); + ASRTER(NIMP(e), env, s_badenv, s_nullenv_p); } } else return 0; } @@ -1314,7 +1326,6 @@ SCM m_do(xorig, env, ctxt) x = CDR(x); test = scm_check_linum(CAR(x), 0L); ASSYNT(ilength(test) >= 1, CAR(x), s_test, s_do); - test = m_seq(test, env, ctxt); if (IMP(CDR(test))) test = cons(CAR(test), list_unspecified); ASSYNT(ilength(CDR(x))>=0, xorig, s_expression, s_do); varcheck(vars, IM_DO, s_variable); @@ -1396,7 +1407,7 @@ static SCM m_iqq(form, depth, env, ctxt) if (0==depth) tmp = IM_UNQUOTE; label: form = CDR(form); - ASSERT(NIMP(form) && ECONSP(form) && NULLP(CDR(form)), + ASRTER(NIMP(form) && ECONSP(form) && NULLP(CDR(form)), form, ARG1, s_quasiquote); if (0!=depth) form = cons(m_iqq(CAR(form), depth, env, ctxt), EOL); @@ -1444,6 +1455,11 @@ static int built_inp(name, x) return 0; } +extern char s_redefining[]; +#ifndef RECKLESS +char s_built_in_syntax[] = "built-in syntax "; +# define s_syntax (&s_built_in_syntax[9]) +#endif static void checked_define(name, val, what) SCM name, val; char *what; @@ -1451,7 +1467,7 @@ static void checked_define(name, val, what) SCM old, vcell; #ifdef MACRO while (M_IDENTP(name)) { - ASSERT(IMP(IDENT_ENV(name)), name, s_escaped, what); + ASRTER(IMP(IDENT_ENV(name)), name, s_escaped, what); name = IDENT_PARENT(name); } #endif @@ -1459,17 +1475,17 @@ static void checked_define(name, val, what) old = CDR(vcell); #ifndef RECKLESS if ('@'==CHARS(name)[0] && UNDEFINED != old) - scm_warn("redefining internal name ", "", name); + scm_warn(s_redefining, "internal name ", name); if (KEYWORDP(old)) { if (1 <= verbose && built_inp(name, KEYWORD_MACRO(old))) - scm_warn("redefining built-in syntax ", "", name); + scm_warn(s_redefining, s_built_in_syntax, name); else if (3 <= verbose) - scm_warn("redefining syntax ", "", name); + scm_warn(s_redefining, s_syntax, name); } else if (2 <= verbose && built_inp(name, old) && (old != val)) - scm_warn("redefining built-in ", "", name); + scm_warn(s_redefining, "built-in ", name); else if (5 <= verbose && UNDEFINED != old) - scm_warn("redefining ", "", name); + scm_warn(s_redefining, "", name); #endif CDR(vcell) = val; } @@ -1594,7 +1610,7 @@ static SCM m_body(xorig, env, ctxt) SCM xorig, env, ctxt; { SCM form, denv = env, x = xorig, defs = EOL; - char *what = ISYMCHARS(CAR(xorig)) + 2; + char *what = 0; /* Should this be passed in? */ ASRTSYNTAX(ilength(xorig) >= 1, s_expression); while NIMP(x) { form = scm_check_linum(CAR(x), 0L); @@ -1627,9 +1643,9 @@ static SCM m_body(xorig, env, ctxt) } } #ifdef CAUTIOUS - ASSYNT(ilength(x) > 0, x, s_body, what); + ASSYNT(ilength(x) > 0, xorig, s_body, what); #else - ASSYNT(ilength(x) > 0, CDR(xorig), s_body, what); + ASSYNT(ilength(x) > 0, xorig, s_body, what); #endif if (IMP(defs)) return x; return cons(m_letrec1(IM_DEFINE, cons2(i_define, defs, x), env, ctxt), EOL); @@ -2019,11 +2035,26 @@ SCM scm_eval_values(x, env, valenv) return res; } +#ifdef __GNUC__ +# define GCC_VERSION (__GNUC__ * 100 + __GNUC_MINOR__) +/* __GNUC_PATCHLEVEL__ */ +# if 302 == GCC_VERSION +# ifdef sparc +# define GCC_SPARC_BUG +# endif +# endif +#endif + static SCM ceval_1(x) SCM x; { - union {SCM *lloc; SCM arg1;} t; - SCM proc, arg2, arg3; +#ifdef GCC_SPARC_BUG + SCM arg1; +#else + struct {SCM arg_1;} t; +# define arg1 t.arg_1 +#endif + SCM arg2, arg3, proc; int envpp = 0; /* 1 means an environment has been pushed in this invocation of ceval_1, -1 means pushed and then popped. */ #ifdef CAUTIOUS @@ -2044,19 +2075,19 @@ static SCM ceval_1(x) goto retx; case (127 & IM_AND): x = CDR(x); - t.arg1 = x; - while(NNULLP(t.arg1 = CDR(t.arg1))) + arg1 = x; + while(NNULLP(arg1 = CDR(arg1))) if (FALSEP(EVALCAR(x))) {x = BOOL_F; goto retx;} - else x = t.arg1; + else x = arg1; goto carloop; cdrxbegin: case (127 & IM_BEGIN): x = CDR(x); begin: - t.arg1 = x; - while(NNULLP(t.arg1 = CDR(t.arg1))) { + arg1 = x; + while(NNULLP(arg1 = CDR(arg1))) { if (NIMP(CAR(x))) ceval_1(CAR(x)); - x = t.arg1; + x = arg1; } carloop: /* eval car of last form in list */ if NCELLP(CAR(x)) { @@ -2080,11 +2111,11 @@ static SCM ceval_1(x) case (127 & IM_COND): while(NIMP(x = CDR(x))) { proc = CAR(x); - t.arg1 = EVALCAR(proc); - if NFALSEP(t.arg1) { + arg1 = EVALCAR(proc); + if NFALSEP(arg1) { x = CDR(proc); if NULLP(x) { - x = t.arg1; + x = arg1; goto retx; } if (IM_ARROW != CAR(x)) goto begin; @@ -2106,8 +2137,8 @@ static SCM ceval_1(x) x = CDR(CDR(x)); while (proc = CAR(x), FALSEP(EVALCAR(proc))) { for(proc = CAR(CDR(x));NIMP(proc);proc = CDR(proc)) { - t.arg1 = CAR(proc); /* body */ - SIDEVAL_1(t.arg1); + arg1 = CAR(proc); /* body */ + SIDEVAL_1(arg1); } ecache_evalx(CDR(CDR(x))); /* steps */ scm_env = CDR(scm_env); @@ -2125,13 +2156,13 @@ static SCM ceval_1(x) ENV_MAY_PUSH(envpp); TRACE(x); #ifdef MAC_INLINE - t.arg1 = CAR(x); + arg1 = CAR(x); #endif x = CDR(x); ecache_evalx(CAR(CDR(x))); #ifdef MAC_INLINE - if (t.arg1 != IM_LET) /* inline call */ - env_tail(ISYMVAL(t.arg1)); + if (arg1 != IM_LET) /* inline call */ + env_tail(ISYMVAL(arg1)); #endif STATIC_ENV = CAR(x); EXTEND_VALENV; @@ -2171,11 +2202,11 @@ static SCM ceval_1(x) goto cdrxbegin; case (127 & IM_OR): x = CDR(x); - t.arg1 = x; - while(NNULLP(t.arg1 = CDR(t.arg1))) { + arg1 = x; + while(NNULLP(arg1 = CDR(arg1))) { x = EVALCAR(x); if NFALSEP(x) goto retx; - x = t.arg1; + x = arg1; } goto carloop; case (127 & IM_LAMBDA): @@ -2226,18 +2257,18 @@ static SCM ceval_1(x) x = CDR(x); proc = evalcar(x); ASRTGO(NIMP(proc), badfun); - t.arg1 = evalcar(CDR(x)); + arg1 = evalcar(CDR(x)); if (CLOSUREP(proc)) { ENV_MAY_PUSH(envpp); TRACE(x); - scm_env_tmp = t.arg1; + scm_env_tmp = arg1; #ifndef RECKLESS goto clo_checked; #else goto clo_unchecked; #endif } - x = apply(proc, t.arg1, EOL); + x = apply(proc, arg1, EOL); goto retx; case (ISYMNUM(IM_DELAY)): x = makprom(closure(CDR(x), 0)); @@ -2338,13 +2369,13 @@ static SCM ceval_1(x) #ifdef CAUTIOUS if (0!=ARGC(proc)) { clo_checked: - t.arg1 = SCM_ENV_FORMALS(CAR(CODE(proc))); + arg1 = SCM_ENV_FORMALS(CAR(CODE(proc))); DEFER_INTS_EGC; arg2 = scm_env_tmp; - while NIMP(t.arg1) { - if NCONSP(t.arg1) goto clo_unchecked; + while NIMP(arg1) { + if NCONSP(arg1) goto clo_unchecked; if IMP(arg2) goto umwrongnumargs; - t.arg1 = CDR(t.arg1); + arg1 = CDR(arg1); arg2 = CDR(arg2); } if NNULLP(arg2) goto umwrongnumargs; @@ -2364,7 +2395,7 @@ static SCM ceval_1(x) /* default: break; */ #ifdef CCLO case tc16_cclo: - t.arg1 = proc; + arg1 = proc; proc = CCLO_SUBR(proc); goto evap1; #endif @@ -2400,77 +2431,77 @@ static SCM ceval_1(x) if (IMP(x)) goto wrongnumargs; #endif - t.arg1 = EVALCAR(x); + arg1 = EVALCAR(x); x = CDR(x); if NULLP(x) { TOP_TRACE(xorig, STATIC_ENV); evap1: ENV_MAY_POP(envpp, CLOSUREP(proc)); ALLOW_INTS_EGC; - switch TYP7(proc) { /* have one argument in t.arg1 */ + switch TYP7(proc) { /* have one argument in arg1 */ case tc7_subr_2o: - return SUBRF(proc)(t.arg1, UNDEFINED); + return SUBRF(proc)(arg1, UNDEFINED); case tc7_subr_1: case tc7_subr_1o: - return SUBRF(proc)(t.arg1); + return SUBRF(proc)(arg1); case tc7_cxr: #ifdef FLOATS if SUBRF(proc) { - if INUMP(t.arg1) - return makdbl(DSUBRF(proc)((double) INUM(t.arg1)), 0.0); - ASRTGO(NIMP(t.arg1), floerr); - if REALP(t.arg1) - return makdbl(DSUBRF(proc)(REALPART(t.arg1)), 0.0); + if INUMP(arg1) + return makdbl(DSUBRF(proc)((double) INUM(arg1)), 0.0); + ASRTGO(NIMP(arg1), floerr); + if REALP(arg1) + return makdbl(DSUBRF(proc)(REALPART(arg1)), 0.0); # ifdef BIGDIG - if BIGP(t.arg1) - return makdbl(DSUBRF(proc)(big2dbl(t.arg1)), 0.0); + if BIGP(arg1) + return makdbl(DSUBRF(proc)(big2dbl(arg1)), 0.0); # endif floerr: - wta(t.arg1, (char *)ARG1, SNAME(proc)); + wta(arg1, (char *)ARG1, SNAME(proc)); } #endif { int op = CXR_OP(proc); #ifndef RECKLESS - x = t.arg1; + x = arg1; #endif while (op) { - ASSERT(NIMP(t.arg1) && CONSP(t.arg1), + ASRTER(NIMP(arg1) && CONSP(arg1), x, ARG1, SNAME(proc)); - t.arg1 = (1 & op ? CAR(t.arg1) : CDR(t.arg1)); + arg1 = (1 & op ? CAR(arg1) : CDR(arg1)); op >>= 2; } - return t.arg1; + return arg1; } case tc7_rpsubr: return BOOL_T; case tc7_asubr: - return SUBRF(proc)(t.arg1, UNDEFINED); + return SUBRF(proc)(arg1, UNDEFINED); case tc7_lsubr: - return SUBRF(proc)(cons(t.arg1, EOL)); + return SUBRF(proc)(cons(arg1, EOL)); case tcs_closures: ENV_MAY_PUSH(envpp); #ifdef SCM_PROFILE eval_clo_cases[1][ARGC(proc)]++; #endif if (1==ARGC(proc)) { - scm_env_cons(t.arg1, EOL); + scm_env_cons(arg1, EOL); goto clo_unchecked; } else { - scm_env_tmp = cons(t.arg1, EOL); + scm_env_tmp = cons(arg1, EOL); goto clo_checked; } case tc7_contin: - scm_dynthrow(proc, t.arg1); + scm_dynthrow(proc, arg1); case tc7_specfun: switch TYP16(proc) { case tc16_call_cc: - proc = t.arg1; + proc = arg1; DEFER_INTS_EGC; - t.arg1 = scm_make_cont(); - EGC_ROOT(t.arg1); - x = setjump(CONT(t.arg1)->jmpbuf); + arg1 = scm_make_cont(); + EGC_ROOT(arg1); + x = setjump(CONT(arg1)->jmpbuf); if (x) { #ifdef SHORT_INT x = (SCM)thrown_value; @@ -2484,22 +2515,22 @@ evap1: goto evap1; case tc16_eval: ENV_MAY_PUSH(envpp); - TRACE(t.arg1); + TRACE(arg1); STATIC_ENV = eval_env; scm_env = EOL; - x = t.arg1; + x = arg1; if (IMP(x)) goto retx; goto loop; #ifdef CCLO case tc16_cclo: arg2 = UNDEFINED; goto cclon; - /* arg2 = t.arg1; - t.arg1 = proc; + /* arg2 = arg1; + arg1 = proc; proc = CCLO_SUBR(proc); goto evap2; */ #endif - case tc16_values: return t.arg1; + case tc16_values: return arg1; } case tc7_subr_2: case tc7_subr_0: @@ -2524,25 +2555,25 @@ evap1: switch TYP7(proc) { case tc7_subr_2: case tc7_subr_2o: - return SUBRF(proc)(t.arg1, arg2); + return SUBRF(proc)(arg1, arg2); case tc7_lsubr: - return SUBRF(proc)(cons2(t.arg1, arg2, EOL)); + return SUBRF(proc)(cons2(arg1, arg2, EOL)); case tc7_lsubr_2: - return SUBRF(proc)(t.arg1, arg2, EOL); + return SUBRF(proc)(arg1, arg2, EOL); case tc7_rpsubr: case tc7_asubr: - return SUBRF(proc)(t.arg1, arg2); + return SUBRF(proc)(arg1, arg2); case tc7_specfun: switch TYP16(proc) { case tc16_apply: - proc = t.arg1; + proc = arg1; ASRTGO(NIMP(proc), badfun); if NULLP(arg2) goto evap0; if (IMP(arg2) || NCONSP(arg2)) { x = arg2; badlst: wta(x, (char *)ARGn, s_apply); } - t.arg1 = CAR(arg2); + arg1 = CAR(arg2); x = CDR(arg2); apply3: if NULLP(x) goto evap1; @@ -2562,25 +2593,25 @@ evap1: #ifdef CCLO case tc16_cclo: cclon: arg3 = arg2; - arg2 = t.arg1; - t.arg1 = proc; + arg2 = arg1; + arg1 = proc; proc = CCLO_SUBR(proc); if (UNBNDP(arg3)) goto evap2; goto evap3; /* return apply(CCLO_SUBR(proc), - cons2(proc, t.arg1, cons(arg2, x)), EOL); */ + cons2(proc, arg1, cons(arg2, x)), EOL); */ #endif case tc16_values: - return scm_values(t.arg1, arg2, EOL, s_values); + return scm_values(arg1, arg2, EOL, s_values); case tc16_call_wv: ENV_MAY_PUSH(envpp); scm_env_tmp = IM_VALUES_TOKEN; /* Magic value recognized by VALUES */ - t.arg1 = apply(t.arg1, EOL, EOL); + arg1 = apply(arg1, EOL, EOL); proc = arg2; DEFER_INTS_EGC; if (IM_VALUES_TOKEN==scm_env_tmp) { scm_env_tmp = EOL; - if (UNBNDP(t.arg1)) goto evap0; + if (UNBNDP(arg1)) goto evap0; goto evap1; } arg2 = CAR(scm_env_tmp); @@ -2604,14 +2635,14 @@ evap1: #endif switch ARGC(proc) { case 2: - scm_env_cons2(t.arg1, arg2, EOL); + scm_env_cons2(arg1, arg2, EOL); goto clo_unchecked; case 1: - scm_env_cons(t.arg1, cons(arg2, EOL)); + scm_env_cons(arg1, cons(arg2, EOL)); goto clo_checked; case 0: case 3: /* Error, will be caught at clo_checked: */ - scm_env_tmp = cons2(t.arg1, arg2, EOL); + scm_env_tmp = cons2(arg1, arg2, EOL); goto clo_checked; } } @@ -2623,7 +2654,7 @@ evap1: if (CLOSUREP(proc) && 3==ARGC(proc)) { ALLOW_INTS_EGC; ENV_MAY_PUSH(envpp); - if (ecache_eval_args(proc, t.arg1, arg2, arg3, x)) + if (ecache_eval_args(proc, arg1, arg2, arg3, x)) goto clo_unchecked; goto umwrongnumargs; } @@ -2636,15 +2667,15 @@ evap1: switch TYP7(proc) { case tc7_subr_3: ASRTGO(NULLP(x), wrongnumargs); - return SUBRF(proc)(t.arg1, arg2, arg3); + return SUBRF(proc)(arg1, arg2, arg3); case tc7_asubr: case tc7_rpsubr: - return asubr_apply(proc, t.arg1, arg2, arg3, x); - /* return apply(proc, cons2(t.arg1, arg2, cons(arg3, x)), EOL); */ + return asubr_apply(proc, arg1, arg2, arg3, x); + /* return apply(proc, cons2(arg1, arg2, cons(arg3, x)), EOL); */ case tc7_lsubr_2: - return SUBRF(proc)(t.arg1, arg2, cons(arg3, x)); + return SUBRF(proc)(arg1, arg2, cons(arg3, x)); case tc7_lsubr: - return SUBRF(proc)(cons2(t.arg1, arg2, cons(arg3, x))); + return SUBRF(proc)(cons2(arg1, arg2, cons(arg3, x))); case tcs_closures: ENV_MAY_PUSH(envpp); #ifdef SCM_PROFILE @@ -2652,24 +2683,24 @@ evap1: #endif switch ARGC(proc) { case 3: - scm_env_cons3(t.arg1, arg2, arg3, x); + scm_env_cons3(arg1, arg2, arg3, x); goto clo_checked; case 2: - scm_env_cons2(t.arg1, arg2, cons(arg3, x)); + scm_env_cons2(arg1, arg2, cons(arg3, x)); goto clo_checked; case 1: - scm_env_cons(t.arg1, cons2(arg2, arg3, x)); + scm_env_cons(arg1, cons2(arg2, arg3, x)); goto clo_checked; case 0: - scm_env_tmp = cons2(t.arg1, arg2, cons(arg3, x)); + scm_env_tmp = cons2(arg1, arg2, cons(arg3, x)); goto clo_checked; } case tc7_specfun: switch TYP16(proc) { case tc16_apply: - proc = t.arg1; + proc = arg1; ASRTGO(NIMP(proc), badfun); - t.arg1 = arg2; + arg1 = arg2; if IMP(x) { x = arg3; goto apply3; @@ -2688,7 +2719,7 @@ evap1: goto cclon; #endif case tc16_values: - return scm_values(t.arg1, arg2, cons(arg3, x), s_values); + return scm_values(arg1, arg2, cons(arg3, x), s_values); } case tc7_subr_2: case tc7_subr_1o: @@ -2703,6 +2734,7 @@ evap1: } } } +#undef arg1 } SCM procedurep(obj) @@ -2723,7 +2755,7 @@ SCM l_proc_doc(proc) SCM proc; { SCM env; - ASSERT(BOOL_T==procedurep(proc) && NIMP(proc) && TYP7(proc) != tc7_contin, + ASRTER(BOOL_T==procedurep(proc) && NIMP(proc) && TYP7(proc) != tc7_contin, proc, ARG1, s_proc_doc); switch TYP7(proc) { case tcs_closures: @@ -2747,11 +2779,11 @@ SCM nconc2copy(lst) { SCM last, *lloc = &lst; #ifdef CAUTIOUS - ASSERT(ilength(lst) >= 1, lst, WNA, s_apply); + ASRTER(ilength(lst) >= 1, lst, WNA, s_apply); #endif while NNULLP(CDR(*lloc)) lloc = &CDR(*lloc); #ifdef CAUTIOUS - ASSERT(ilength(CAR(*lloc)) >= 0, lst, ARGn, s_apply); + ASRTER(ilength(CAR(*lloc)) >= 0, lst, ARGn, s_apply); #endif last = CAR(*lloc); *lloc = EOL; @@ -2846,7 +2878,7 @@ SCM apply(proc, arg1, args) args = arg1; #endif while (op) { - ASSERT(NIMP(arg1) && CONSP(arg1), + ASRTER(NIMP(arg1) && CONSP(arg1), args, ARG1, SNAME(proc)); arg1 = (1 & op ? CAR(arg1) : CDR(arg1)); op >>= 2; @@ -2865,7 +2897,7 @@ SCM apply(proc, arg1, args) case tc7_asubr: if NULLP(args) return SUBRF(proc)(arg1, UNDEFINED); while NIMP(args) { - ASSERT(CONSP(args), args, ARG2, s_apply); + ASRTER(CONSP(args), args, ARG2, s_apply); arg1 = SUBRF(proc)(arg1, CAR(args)); args = CDR(args); } @@ -2873,7 +2905,7 @@ SCM apply(proc, arg1, args) case tc7_rpsubr: if NULLP(args) return BOOL_T; while NIMP(args) { - ASSERT(CONSP(args), args, ARG2, s_apply); + ASRTER(CONSP(args), args, ARG2, s_apply); if FALSEP(SUBRF(proc)(arg1, CAR(args))) return BOOL_F; arg1 = CAR(args); args = CDR(args); @@ -2948,7 +2980,7 @@ SCM scm_cvapply(proc, n, argv) int op = CXR_OP(proc); res = argv[0]; while (op) { - ASSERT(NIMP(res) && CONSP(res), + ASRTER(NIMP(res) && CONSP(res), argv[0], ARG1, SNAME(proc)); res = (1 & op ? CAR(res) : CDR(res)); op >>= 2; @@ -3024,7 +3056,7 @@ SCM map(proc, arg1, args) #ifndef RECKLESS scm_arity_check(proc, n, s_map); #endif - ASSERT(NIMP(arg1), arg1, ARG2, s_map); + ASRTER(NIMP(arg1), arg1, ARG2, s_map); #ifdef CCLO if (tc16_cclo==TYP16(proc)) { args = cons(arg1, args); @@ -3040,10 +3072,10 @@ SCM map(proc, arg1, args) ave = &(ve[n]); } ve[0] = arg1; - ASSERT(NIMP(ve[0]), arg1, ARG2, s_map); + ASRTER(NIMP(ve[0]), arg1, ARG2, s_map); for (i = 1; i < n; i++) { ve[i] = CAR(args); - ASSERT(NIMP(ve[i]), ve[i], ARGn, s_map); + ASRTER(NIMP(ve[i]), ve[i], ARGn, s_map); args = CDR(args); } while (1) { @@ -3053,7 +3085,7 @@ SCM map(proc, arg1, args) /* We could check for lists the same length here. */ return res; } - ASSERT(CONSP(ve[i]), ve[i], 0==i ? ARG2 : ARGn, s_map); + ASRTER(CONSP(ve[i]), ve[i], 0==i ? ARG2 : ARGn, s_map); ave[i] = CAR(ve[i]); ve[i] = CDR(ve[i]); } @@ -3070,9 +3102,9 @@ SCM for_each(proc, arg1, args) scm_protect_temp(&heap_ve); /* Keep heap_ve from being optimized away. */ if NULLP(arg1) return UNSPECIFIED; #ifndef RECKLESS - scm_arity_check(proc, n, s_map); + scm_arity_check(proc, n, s_for_each); #endif - ASSERT(NIMP(arg1), arg1, ARG2, s_for_each); + ASRTER(NIMP(arg1), arg1, ARG2, s_for_each); #ifdef CCLO if (tc16_cclo==TYP16(proc)) { args = cons(arg1, args); @@ -3088,10 +3120,10 @@ SCM for_each(proc, arg1, args) ave = &(ve[n]); } ve[0] = arg1; - ASSERT(NIMP(ve[0]), arg1, ARG2, s_for_each); + ASRTER(NIMP(ve[0]), arg1, ARG2, s_for_each); for (i = 1; i < n; i++) { ve[i] = CAR(args); - ASSERT(NIMP(ve[i]), args, ARGn, s_for_each); + ASRTER(NIMP(ve[i]), args, ARGn, s_for_each); args = CDR(args); } while (1) { @@ -3100,7 +3132,7 @@ SCM for_each(proc, arg1, args) if IMP(ve[i]) { return UNSPECIFIED; } - ASSERT(CONSP(ve[i]), ve[i], 0==i ? ARG2 : ARGn, s_for_each); + ASRTER(CONSP(ve[i]), ve[i], 0==i ? ARG2 : ARGn, s_for_each); ave[i] = CAR(ve[i]); ve[i] = CDR(ve[i]); } @@ -3158,7 +3190,7 @@ static SCM makro(code, flags, what) char *what; { register SCM z; - ASSERT(scm_arity_check(code, (MAC_PRIMITIVE & flags ? 3L : 2L), + ASRTER(scm_arity_check(code, (MAC_PRIMITIVE & flags ? 3L : 2L), (char *)0), code, ARG1, what); NEWCELL(z); CDR(z) = code; @@ -3193,7 +3225,7 @@ SCM makidmacro(code) /* Functions for smart expansion */ /* @MACROEXPAND1 returns: - #F if its argument is not a macro invocation, + '#F' if its argument is not a macro invocation, the argument if the argument is a primitive syntax invocation, the result of expansion if the argument is a macro invocation (BEGIN #F) will be returned instead of #F if #F is the result. @@ -3394,7 +3426,7 @@ SCM ident2sym(id) SCM id; { id = id2sym(id); - ASSERT(NIMP(id) && SYMBOLP(id), id, ARG1, s_ident2sym); + ASRTER(NIMP(id) && SYMBOLP(id), id, ARG1, s_ident2sym); return id; } @@ -3403,18 +3435,18 @@ SCM renamed_ident(id, env) SCM id, env; { SCM z; - ASSERT(NIMP(id) && IDENTP(id), id, ARG1, s_renamed_ident); + ASRTER(NIMP(id) && IDENTP(id), id, ARG1, s_renamed_ident); NEWCELL(z); while (NIMP(env)) { if (INUMP(CAR(env))) { - ASSERT(NIMP(CDR(env)), env, s_badenv, s_renamed_ident); + ASRTER(NIMP(CDR(env)), env, s_badenv, s_renamed_ident); env = CDR(CDR(env)); } else if (SCM_LINUMP(CAR(env))) { env = CDR(env); } else { - ASSERT(NULLP(env) || (NIMP(env) && CONSP(env)), + ASRTER(NULLP(env) || (NIMP(env) && CONSP(env)), env, s_badenv, s_renamed_ident); break; } @@ -3587,6 +3619,12 @@ SCM make_specfun(name, typ, flags) } void init_eval() { + scm_env = EOL; + scm_env_tmp = UNSPECIFIED; +#ifndef RECKLESS + scm_trace = BOOL_F; + scm_trace_env = EOL; +#endif tc16_promise = newsmob(&promsmob); tc16_macro = newsmob(¯osmob); tc16_env = newsmob(&envsmob); @@ -3653,6 +3691,7 @@ void init_eval() make_synt(s_letrec_syntax, MAC_MMACRO, m_letrec_syntax); make_synt(s_the_macro, MAC_ACRO, m_the_macro); + add_feature("primitive-hygiene"); #endif f_begin = CDR(CDR(KEYWORD_MACRO(sym2vcell(i_begin)))); |