summaryrefslogtreecommitdiffstats
path: root/eval.c
diff options
context:
space:
mode:
Diffstat (limited to 'eval.c')
-rw-r--r--eval.c341
1 files changed, 190 insertions, 151 deletions
diff --git a/eval.c b/eval.c
index 7b0e983..d5bba5f 100644
--- a/eval.c
+++ b/eval.c
@@ -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(&macrosmob);
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))));
generated by cgit v1.2.3 (git 2.39.1) at 2024-04-27 10:27:32 +0000