summaryrefslogtreecommitdiffstats
path: root/eval.c
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:25 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:25 -0800
commitdb04688faa20f3576257c0fe41752ec435beab9a (patch)
tree6d638c2e1f65afd5f49d20b2d22ce35bd74705ff /eval.c
parent1edcb9b62a1a520eddae8403c19d841c9b18737f (diff)
downloadscm-db04688faa20f3576257c0fe41752ec435beab9a.tar.gz
scm-db04688faa20f3576257c0fe41752ec435beab9a.zip
Import Upstream version 5c3upstream/5c3
Diffstat (limited to 'eval.c')
-rw-r--r--eval.c1681
1 files changed, 1200 insertions, 481 deletions
diff --git a/eval.c b/eval.c
index 8620edc..335be3b 100644
--- a/eval.c
+++ b/eval.c
@@ -47,18 +47,130 @@
#define I_SYM(x) (CAR((x)-1L))
#define I_VAL(x) (CDR((x)-1L))
-#ifdef MACRO
-# define ATOMP(x) (5==(5 & (int)CAR(x)))
-# define EVALCELLCAR(x,env) (ATOMP(CAR(x))?evalatomcar(x,env):ceval(CAR(x),env))
+#define ATOMP(x) (5==(5 & (int)CAR(x)))
+#define EVALCELLCAR(x) (ATOMP(CAR(x))?evalatomcar(x):ceval_1(CAR(x)))
+
+/* Environment frames are initially allocated in a small cache ("ecache").
+ This cache is subject to copying gc, cells in it may be moved to the
+ general purpose Scheme heap by a call to any routine that allocates cells
+ in the cache.
+
+ Global variables scm_env and scm_env_tmp are used as software
+ registers: scm_env is the current lexical environment, scm_env_tmp
+ is used for protecting environment frames under construction and not
+ yet linked into the environment.
+
+ In order to protect environments from garbage collection, a stack of
+ environments (scm_estk) is maintained. scm_env and scm_env_tmp may
+ be pushed on or popped off the stack using the macros ENV_PUSH and
+ ENV_POP.
+
+ It is not safe to pass objects that may allocated in the ecache as
+ arguments to C functions, or to return them from C functions, since
+ such objects may be moved by the ecache gc. Ecache gc may happen
+ anywhere interrupts are not deferred, because some interrupt
+ handlers may evaluate Scheme code and then return.
+
+ Interrupts may be deferred with DEFER_INTS_EGC: This will prevent
+ interrupts until an ALLOW_INTS or ALLOW_INTS_EGC, which may happen
+ any time Scheme code is evaluated. It is not necessary to strictly
+ nest DEFER_INTS_EGC and ALLOW_INTS_EGC since ALLOW_INTS_EGC is
+ called in ceval_1 before any subrs are called.
+
+ Instead of using the C stack and deferring interrupts, objects which
+ might have been allocated in the ecache may be passed using the
+ global variables scm_env_tmp and scm_env.
+
+ If the CDR of a cell that might be allocated in the regular heap is
+ made to point to a cell allocated in the cache, then the first cell
+ must be recorded as a gc root, using the macro EGC_ROOT. There is
+ no provision for allowing the CAR of a regular cell to point to a
+ cache cell. */
+
+#ifdef NO_ENV_CACHE
+# define scm_env_cons(a,b) {scm_env_tmp=cons((a),(b));}
+# define scm_env_cons2(a,b,c) {scm_env_tmp=cons2((a),(b),(c));}
+# define scm_env_cons_tmp(a) {scm_env_tmp=cons((a),scm_env_tmp);}
+# define EXTEND_ENV(names) {scm_env=acons((names),scm_env_tmp,scm_env);}
#else
-# define EVALCELLCAR(x, env) SYMBOLP(CAR(x))?*lookupcar(x, env):ceval(CAR(x), env)
+# define EXTEND_ENV scm_extend_env
+#endif
+
+SCM scm_env = EOL, scm_env_tmp = UNSPECIFIED;
+long tc16_env; /* Type code for environments passed to macro
+ transformers. */
+SCM nconc2copy P((SCM x));
+SCM copy_list P((SCM x));
+SCM rename_ident P((SCM id, SCM env));
+SCM eqv P((SCM x, SCM y));
+void scm_dynthrow P((CONTINUATION *cont, SCM val));
+void scm_egc P((void));
+void scm_estk_grow P((sizet inc));
+void scm_estk_shrink P((void));
+int badargsp P((SCM proc, SCM args));
+
+static SCM ceval_1 P((SCM x));
+static SCM evalatomcar P((SCM x));
+static SCM evalcar P((SCM x));
+static SCM id2sym P((SCM id));
+static SCM iqq P((SCM form));
+static SCM m_body P((SCM op, SCM xorig, char *what));
+static SCM m_iqq P((SCM form, int depth, SCM env));
+static SCM m_letrec1 P((SCM op, SCM imm, SCM xorig, SCM env));
+static SCM macroexp1 P((SCM x, int check));
+static SCM unmemocar P((SCM x));
+static SCM wrapenv P((void));
+static SCM *id_denote P((SCM var));
+static int prinenv P((SCM exp, SCM port, int writing));
+static int prinid P((SCM exp, SCM port, int writing));
+static int prinmacro P((SCM exp, SCM port, int writing));
+static int prinprom P((SCM exp, SCM port, int writing));
+static void bodycheck P((SCM xorig, SCM *bodyloc, char *what));
+static void unpaint P((SCM *p));
+#ifdef CAREFUL_INTS
+static void debug_env_warn P((char *fnam, long line, char *what));
+#endif
+
+/* Flush global variable state to estk. */
+#define ENV_SAVE {scm_estk_ptr[0]=scm_env; scm_estk_ptr[1]=scm_env_tmp;}
+
+/* Make global variable state consistent with estk. */
+#define ENV_RESTORE {scm_env=scm_estk_ptr[0]; scm_env_tmp=scm_estk_ptr[1];}
+
+#define ENV_PUSH {DEFER_INTS_EGC; ENV_SAVE;\
+ if (INUM0==scm_estk_ptr[SCM_ESTK_FRLEN]) scm_estk_grow(20);\
+ else scm_estk_ptr += SCM_ESTK_FRLEN;}
+
+#define ENV_POP {DEFER_INTS_EGC;\
+ if (INUM0==scm_estk_ptr[-SCM_ESTK_FRLEN]) scm_estk_shrink();\
+ else scm_estk_ptr -= SCM_ESTK_FRLEN; ENV_RESTORE;}
+
+#ifdef NO_ENV_CACHE
+# define EGC_ROOT(x) /**/
+#else
+# ifdef CAREFUL_INTS
+# define EGC_ROOT(x) {if (!ints_disabled) \
+ debug_env_warn(__FILE__,__LINE__,"EGC_ROOT"); \
+ scm_egc_roots[--scm_egc_root_index] = (x); \
+ if (0==scm_egc_root_index) scm_egc();}
+# else
+# define EGC_ROOT(x) {scm_egc_roots[--scm_egc_root_index] = (x);\
+ if (0==scm_egc_root_index) scm_egc();}
+# endif
#endif
-#define EVALIMP(x, env) (ILOCP(x)?*ilookup((x), env):x)
-#define EVALCAR(x, env) (NCELLP(CAR(x))?(IMP(CAR(x))?EVALIMP(CAR(x), env):\
- I_VAL(CAR(x))):EVALCELLCAR(x, env))
-#define EXTEND_ENV acons
+#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;}
+#define SIDEVAL_1(x) if NIMP(x) ceval_1(x)
+#ifdef CAUTIOUS
+# define TRACE(x) scm_estk_ptr[2]=(x)
+#else
+# define TRACE(x) /**/
+#endif
+#define EVALIMP(x) (ILOCP(x)?*ilookup(x):x)
+#define EVALCAR(x) (NCELLP(CAR(x))?(IMP(CAR(x))?EVALIMP(CAR(x)):\
+ I_VAL(CAR(x))):EVALCELLCAR(x))
long tc16_macro; /* Type code for macros */
#define MACROP(x) (tc16_macro==TYP16(x))
@@ -75,26 +187,148 @@ static char s_escaped[] = "escaped synthetic identifier";
# define ENV_MARK BOOL_T
#else
# define IDENTP SYMBOLP
+# define M_IDENTP(x) (0)
#endif
-SCM *ilookup(iloc, env)
- SCM iloc, env;
+/* #define SCM_PROFILE */
+#ifdef SCM_PROFILE
+long eval_cases[128];
+long eval_cases_other[NUM_ISYMS];
+long ilookup_cases[10][10][2]; /* frame, dist, icdrp */
+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 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);
+ long *v = (long *)VELTS(ev);
+ int i;
+ for (i = 0; i < sizeof(eval_cases)/sizeof(long); i++)
+ v[i] = eval_cases[i];
+ v = (long *)VELTS(evo);
+ for (i = 0; i < sizeof(eval_cases_other)/sizeof(long); i++)
+ v[i] = eval_cases_other[i];
+ v = (long *)VELTS(ARRAY_V(il));
+ for (i = 0; i < sizeof(ilookup_cases)/sizeof(long); i++)
+ v[i] = ((long *)ilookup_cases)[i];
+ v = (long *)VELTS(ARRAY_V(evc));
+ 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;
+ }
+ return cons2(ev, evo, cons2(il, evc, EOL));
+}
+#endif
+
+#ifdef CAREFUL_INTS
+# undef CAR
+# define CAR(x) (*debug_env_car((x), __FILE__, __LINE__))
+# undef CDR
+# define CDR(x) (*debug_env_cdr((x), __FILE__, __LINE__))
+/* Inhibit warnings for ARGC, is not changed by egc. */
+# undef ARGC
+# define ARGC(x) ((6L & (((cell *)(SCM2PTR(x)))->cdr))>>1)
+#include <signal.h>
+SCM test_ints(x)
+ SCM x;
+{
+ static int cnt = 100;
+ if (0==--cnt) {
+ cnt = 100;
+ DEFER_INTS;
+ scm_egc();
+ ALLOW_INTS;
+ /* l_raise(MAKINUM(SIGALRM)); */
+ }
+ return x;
+}
+int ecache_p(x)
+ SCM x;
+{
+ register CELLPTR ptr;
+ if NCELLP(x) return 0;
+ ptr = (CELLPTR)SCM2PTR(x);
+ if (PTR_LE(scm_ecache, ptr)
+ && PTR_GT(scm_ecache+scm_ecache_len, ptr))
+ return !0;
+ return 0;
+}
+static void debug_env_warn(fnam, line, what)
+ char *fnam;
+ long line;
+ char *what;
+{
+ lputs(fnam, cur_errp);
+ lputc(':', cur_errp);
+ intprint(line, 10, cur_errp);
+ lputs(": unprotected ", cur_errp);
+ lputs(what, cur_errp);
+ lputs(" of ecache value\n", cur_errp);
+}
+SCM *debug_env_car(x, fnam, line)
+ SCM x;
+ char *fnam;
+ long line;
+{
+ SCM *ret;
+ if (!ints_disabled && ecache_p(x))
+ debug_env_warn(fnam, line, "CAR");
+ ret = &(((cell *)(SCM2PTR(x)))->car);
+ if (!ints_disabled && NIMP(*ret) && ecache_p(*ret))
+ debug_env_warn(fnam, line, "CAR");
+ return ret;
+}
+SCM *debug_env_cdr(x, fnam, line)
+ SCM x;
+ char *fnam;
+ long line;
+{
+ SCM *ret;
+ if (!ints_disabled && ecache_p(x))
+ debug_env_warn(fnam, line, "CDR");
+ ret = &(((cell *)(SCM2PTR(x)))->cdr);
+ if (!ints_disabled && NIMP(*ret) && ecache_p(*ret))
+ debug_env_warn(fnam, line, "CAR");
+ return ret;
+}
+#endif /* CAREFUL_INTS */
+
+SCM *ilookup(iloc)
+ SCM iloc;
{
register int ir = IFRAME(iloc);
- register SCM er = env;
+ register SCM er;
+#ifdef SCM_PROFILE
+ ilookup_cases[ir<10 ? ir : 9]
+ [IDIST(iloc)<10 ? IDIST(iloc) : 9][ICDRP(iloc)?1:0]++;
+#endif
+ DEFER_INTS_EGC;
+ er = scm_env;
for(;0 != ir;--ir) er = CDR(er);
er = CAR(er);
for(ir = IDIST(iloc);0 != ir;--ir) er = CDR(er);
if ICDRP(iloc) return &CDR(er);
return &CAR(CDR(er));
}
-
-SCM *farlookup(farloc, env)
- SCM farloc, env;
+SCM *farlookup(farloc)
+ SCM farloc;
{
register int ir;
- register SCM er = env;
+ register SCM er;
SCM x = CDR(farloc);
+ DEFER_INTS_EGC;
+ er = scm_env;
for (ir = INUM(CAR(x)); 0 != ir; --ir) er = CDR(er);
er = CAR(er);
for (ir = INUM(CDR(x)); 0 != ir; --ir) er = CDR(er);
@@ -102,15 +336,23 @@ SCM *farlookup(farloc, env)
return &CAR(CDR(er));
}
-SCM *lookupcar(vloc, genv)
- SCM vloc, genv;
+static char s_badkey[] = "Use of keyword as variable",
+ s_unbnd[] = "unbound variable: ", s_wtap[] = "Wrong type to apply: ";
+/* check is logical OR of LOOKUP_UNDEFP and LOOKUP_MACROP */
+#define LOOKUP_UNDEFP 1
+#define LOOKUP_MACROP 2
+SCM *lookupcar(vloc, check)
+ SCM vloc;
+ int check;
{
- SCM env = genv;
+ SCM env;
register SCM *al, fl, var = CAR(vloc);
register unsigned int idist, iframe = 0;
#ifdef MACRO
SCM mark = IDENT_MARK(var);
#endif
+ DEFER_INTS_EGC;
+ env = scm_env;
for(; NIMP(env); env = CDR(env)) {
idist = 0;
al = &CAR(env);
@@ -123,6 +365,14 @@ SCM *lookupcar(vloc, genv)
#endif
if NCONSP(fl)
if (fl==var) {
+#ifndef RECKLESS
+ if ((check & LOOKUP_UNDEFP)
+ && UNBNDP(CDR(*al))) { env = EOL; goto errout; }
+# ifdef MACRO
+ if ((check & LOOKUP_MACROP)
+ && (NIMP(CDR(*al)) && MACROP(CDR(*al)))) goto badkey;
+# endif
+#endif
#ifndef TEST_FARLOC
if (iframe < 4096 && idist < (1L<<(LONG_BIT-20)))
CAR(vloc) = MAKILOC(iframe, idist) + ICDR;
@@ -135,7 +385,12 @@ SCM *lookupcar(vloc, genv)
al = &CDR(*al);
if (CAR(fl)==var) {
#ifndef RECKLESS /* letrec inits to UNDEFINED */
- if UNBNDP(CAR(*al)) {env = EOL; goto errout;}
+ if ((check & LOOKUP_UNDEFP)
+ && UNBNDP(CAR(*al))) {env = EOL; goto errout;}
+# ifdef MACRO
+ if ((check & LOOKUP_MACROP)
+ && NIMP(CAR(*al)) && MACROP(CAR(*al))) goto badkey;
+# endif
#endif
#ifndef TEST_FARLOC
if (iframe < 4096 && idist < (1L<<(LONG_BIT-20)))
@@ -157,24 +412,33 @@ SCM *lookupcar(vloc, genv)
#endif
var = sym2vcell(var);
#ifndef RECKLESS
- if (NNULLP(env) || UNBNDP(CDR(var))) {
+ if (NNULLP(env) || ((check & LOOKUP_UNDEFP) && UNBNDP(CDR(var)))) {
var = CAR(var);
errout:
- everr(vloc, genv, var,
+ everr(vloc, wrapenv() /*scm_env*/, var,
# ifdef MACRO
M_IDENTP(var) ? s_escaped :
# endif
- (NULLP(env) ? "unbound variable: " : "damaged environment"), "");
+ (NULLP(env) ? s_unbnd : "damaged environment"), "");
+ }
+# ifdef MACRO
+ if ((check & LOOKUP_MACROP) && NIMP(CDR(var)) && MACROP(CDR(var))) {
+ var = CAR(var);
+ badkey: everr(vloc, wrapenv()/*scm_env*/, var, s_badkey, "");
}
+# endif
#endif
CAR(vloc) = var + 1;
return &CDR(var);
}
-static SCM unmemocar(form, env)
- SCM form, env;
+static SCM unmemocar(form)
+ SCM form;
{
+ SCM env;
register int ir;
+ DEFER_INTS_EGC;
+ env = scm_env;
if IMP(form) return form;
if (1==TYP3(form))
CAR(form) = I_SYM(CAR(form));
@@ -187,47 +451,44 @@ static SCM unmemocar(form, env)
return form;
}
-#ifdef MACRO
/* CAR(x) is known to be a cell but not a cons */
-static char s_badkey[] = "Use of keyword as variable";
-static SCM evalatomcar(x, env)
- SCM x, env;
+static SCM evalatomcar(x)
+ SCM x;
{
SCM r;
switch TYP7(CAR(x)) {
default:
- everr(x, env, CAR(x), "Cannot evaluate: ", "");
+ everr(x, wrapenv() /*scm_env*/, CAR(x), "Cannot evaluate: ", "");
case tcs_symbols:
lookup:
- r = *lookupcar(x, env);
-# ifndef RECKLESS
- if (NIMP(r) && MACROP(r)) {
- x = cons(CAR(x), CDR(x));
- unmemocar(x, env);
- everr(x, env, CAR(x), s_badkey, "");
- }
-# endif
- return r;
+ return *lookupcar(x, LOOKUP_UNDEFP|LOOKUP_MACROP);
case tc7_vector:
+#ifndef RECKLESS
+ if (2 <= verbose) warn("unquoted ", s_vector);
+#endif
+ r = cons2(IM_QUOTE, CAR(x), EOL);
+ CAR(x) = r;
+ return CAR(CDR(r));
+ case tc7_smob:
+#ifdef MACRO
+ if M_IDENTP(CAR(x)) goto lookup;
+#endif
+ /* fall through */
case tc7_string:
case tc7_bvect: case tc7_ivect: case tc7_uvect:
case tc7_fvect: case tc7_dvect: case tc7_cvect:
return CAR(x);
- case tc7_smob:
- if M_IDENTP(CAR(x)) goto lookup;
- return CAR(x);
}
}
-#endif /* def MACRO */
-SCM eval_args(l, env)
- SCM l, env;
+SCM eval_args(l)
+ SCM l;
{
SCM res = EOL, *lloc = &res;
while NIMP(l) {
- *lloc = cons(EVALCAR(l, env), EOL);
- lloc = &CDR(*lloc);
- l = CDR(l);
+ *lloc = cons(EVALCAR(l), EOL);
+ lloc = &CDR(*lloc);
+ l = CDR(l);
}
return res;
}
@@ -240,21 +501,21 @@ static char s_test[] = "bad test";
static char s_body[] = "bad body";
static char s_bindings[] = "bad bindings";
static char s_variable[] = "bad variable";
+static char s_bad_else_clause[] = "bad ELSE clause";
static char s_clauses[] = "bad or missing clauses";
static char s_formals[] = "bad formals";
#define ASSYNT(_cond, _arg, _pos, _subr) if(!(_cond))wta(_arg, (char *)_pos, _subr);
-SCM i_dot, i_quote, i_quasiquote, i_lambda,
- i_let, i_arrow, i_else, i_unquote, i_uq_splicing, i_apply;
+SCM i_dot, i_quote, i_quasiquote, i_lambda, i_define,
+ i_let, i_arrow, i_else, i_unquote, i_uq_splicing;
#define ASRTSYNTAX(cond_, msg_) if(!(cond_))wta(xorig, (msg_), what);
#ifdef MACRO
-SCM rename_ident P((SCM id, SCM env));
-# define TOPDENOTE_EQ(sym, x, env) ((sym)==ident2sym(x) && TOPLEVELP(x,env))
-# define TOPLEVELP(x,env) (0==id_denote(x,env))
+# define TOPDENOTE_EQ(sym, x, env) ((sym)==id2sym(x) && TOPLEVELP(x,env))
+# define TOPLEVELP(x,env) (0==id_denote(x))
# define TOPRENAME(v) (renamed_ident(v, BOOL_F))
-static SCM ident2sym(id)
+static SCM id2sym(id)
SCM id;
{
if NIMP(id)
@@ -263,11 +524,13 @@ static SCM ident2sym(id)
return id;
}
-static SCM *id_denote(var, env)
- SCM var, env;
+static SCM *id_denote(var)
+ SCM var;
{
register SCM *al, fl;
- SCM mark = IDENT_MARK(var);
+ SCM env, mark = IDENT_MARK(var);
+ DEFER_INTS_EGC;
+ env = scm_env;
for(;NIMP(env); env = CDR(env)) {
al = &CAR(env);
for(fl = CAR(*al);NIMP(fl);fl = CDR(fl)) {
@@ -294,6 +557,12 @@ static void unpaint(p)
if NIMP(CAR(x)) unpaint(&CAR(x));
p = &CDR(*p);
}
+ else if VECTORP(x) {
+ sizet i = LENGTH(x);
+ if (0==i) return;
+ while (i-- > 1) unpaint(&(VELTS(x)[i]));
+ p = VELTS(x);
+ }
else {
while M_IDENTP(x) *p = x = IDENT_PARENT(x);
return;
@@ -313,16 +582,33 @@ static void bodycheck(xorig, bodyloc, what)
ASRTSYNTAX(ilength(*bodyloc) >= 1, s_expression);
}
+static SCM m_body(op, xorig, what)
+ SCM op, xorig;
+ char *what;
+{
+ ASRTSYNTAX(ilength(xorig) >= 1, s_expression);
+ /* Don't add another ISYM if one is present already. */
+ if ISYMP(CAR(xorig)) return xorig;
+ /* Retain possible doc string. */
+ if (IMP(CAR(xorig)) || NCONSP(CAR(xorig))) {
+ if NNULLP(CDR(xorig))
+ return cons(CAR(xorig), m_body(op, CDR(xorig), what));
+ return xorig;
+ }
+ return cons2(op, CAR(xorig), CDR(xorig));
+}
+
SCM m_quote(xorig, env)
SCM xorig, env;
{
+ SCM x = copytree(CDR(xorig));
ASSYNT(ilength(CDR(xorig))==1, xorig, s_expression, s_quote);
#ifdef MACRO
DEFER_INTS;
- unpaint(&CAR(CDR(xorig)));
+ unpaint(&CAR(x));
ALLOW_INTS;
#endif
- return cons(IM_QUOTE, CDR(xorig));
+ return cons(IM_QUOTE, x);
}
SCM m_begin(xorig, env)
@@ -368,32 +654,47 @@ SCM m_or(xorig, env)
else return BOOL_F;
}
+#ifdef INUMS_ONLY
+# define memv memq
+#endif
SCM m_case(xorig, env)
SCM xorig, env;
{
- SCM proc, x = CDR(xorig);
+ SCM clause, cdrx = copy_list(CDR(xorig)), x = cdrx;
+#ifndef RECKLESS
+ SCM s, keys = EOL;
+#endif
ASSYNT(ilength(x) >= 2, xorig, s_clauses, s_case);
while(NIMP(x = CDR(x))) {
- proc = CAR(x);
- ASSYNT(ilength(proc) >= 2, xorig, s_clauses, s_case);
- if TOPDENOTE_EQ(i_else, CAR(proc), env)
- CAR(proc) = IM_ELSE;
+ clause = CAR(x);
+ ASSYNT(ilength(clause) >= 2, xorig, s_clauses, s_case);
+ if TOPDENOTE_EQ(i_else, CAR(clause), env) {
+ ASSYNT(NULLP(CDR(x)), xorig, s_bad_else_clause, s_case);
+ CAR(x) = cons(IM_ELSE, CDR(clause));
+ }
else {
- ASSYNT(ilength(CAR(proc)) >= 0, xorig, s_clauses, s_case);
+ ASSYNT(ilength(CAR(clause)) >= 0, xorig, s_clauses, s_case);
#ifdef MACRO
+ clause = cons(copy_list(CAR(clause)), CDR(clause));
DEFER_INTS;
- unpaint(&CAR(proc));
+ unpaint(&CAR(clause));
ALLOW_INTS;
+ CAR(x) = clause;
#endif
+#ifndef RECKLESS
+ for (s = CAR(clause); NIMP(s); s = CDR(s))
+ ASSYNT(FALSEP(memv(CAR(s),keys)), xorig, "duplicate key value", s_case);
+ keys = append(cons2(CAR(clause), keys, EOL));
+#endif
}
}
- return cons(IM_CASE, CDR(xorig));
+ return cons(IM_CASE, cdrx);
}
SCM m_cond(xorig, env)
SCM xorig, env;
{
- SCM arg1, x = CDR(xorig);
+ SCM arg1, cdrx = copy_list(CDR(xorig)), x = cdrx;
int len = ilength(x);
ASSYNT(len >= 1, xorig, s_clauses, s_cond);
while(NIMP(x)) {
@@ -401,26 +702,30 @@ SCM m_cond(xorig, env)
len = ilength(arg1);
ASSYNT(len >= 1, xorig, s_clauses, s_cond);
if TOPDENOTE_EQ(i_else, CAR(arg1), env) {
- ASSYNT(NULLP(CDR(x)) && len >= 2, xorig, "bad ELSE clause", s_cond);
- CAR(arg1) = BOOL_T;
+ ASSYNT(NULLP(CDR(x)) && len >= 2, xorig, s_bad_else_clause, s_cond);
+ CAR(x) = cons(BOOL_T, CDR(arg1));
}
- arg1 = CDR(arg1);
- if (len >= 2 && TOPDENOTE_EQ(i_arrow, CAR(arg1), env)) {
- ASSYNT(3==len && NIMP(CAR(CDR(arg1))), xorig, "bad recipient", s_cond);
- CAR(arg1) = IM_ARROW;
+ else {
+ arg1 = CDR(arg1);
+ if (len >= 2 && TOPDENOTE_EQ(i_arrow, CAR(arg1), env)) {
+ ASSYNT(3==len && NIMP(CAR(CDR(arg1))), xorig, "bad recipient", s_cond);
+ CAR(x) = cons2(CAR(CAR(x)), IM_ARROW, CDR(arg1));
+ }
}
x = CDR(x);
}
- return cons(IM_COND, CDR(xorig));
+ return cons(IM_COND, cdrx);
}
SCM m_lambda(xorig, env)
SCM xorig, env;
{
SCM proc, x = CDR(xorig);
+ int argc = 0; /* Number of required args */
if (ilength(x) < 2) goto badforms;
proc = CAR(x);
if NULLP(proc) goto memlambda;
+ if (IM_LET==proc) goto memlambda; /* named let */
if IMP(proc) goto badforms;
if IDENTP(proc) goto memlambda;
if NCONSP(proc) goto badforms;
@@ -430,12 +735,13 @@ SCM m_lambda(xorig, env)
else goto memlambda;
if (!(NIMP(CAR(proc)) && IDENTP(CAR(proc)))) goto badforms;
proc = CDR(proc);
+ argc++;
}
- if NNULLP(proc)
+ if (NNULLP(proc) && (IM_LET != proc)) /* IM_LET inserted by named let. */
badforms: wta(xorig, s_formals, s_lambda);
memlambda:
- bodycheck(xorig, &CDR(x), s_lambda);
- return cons(IM_LAMBDA, CDR(xorig));
+ return cons2(ISYMSETVAL(IM_LAMBDA, argc), CAR(x),
+ m_body(IM_LAMBDA, CDR(x), s_lambda));
}
SCM m_letstar(xorig, env)
SCM xorig, env;
@@ -454,8 +760,7 @@ SCM m_letstar(xorig, env)
proc = CDR(proc);
}
x = cons(vars, CDR(x));
- bodycheck(xorig, &CDR(x), s_letstar);
- return cons(IM_LETSTAR, x);
+ return cons2(IM_LETSTAR, CAR(x), m_body(IM_LETSTAR, CDR(x), s_letstar));
}
/* DO gets the most radically altered syntax
@@ -475,7 +780,7 @@ SCM m_do(xorig, env)
SCM xorig, env;
{
SCM x = CDR(xorig), arg1, proc;
- SCM vars = EOL, inits = EOL, steps = EOL;
+ SCM vars = IM_DO, inits = EOL, steps = EOL;
SCM *initloc = &inits, *steploc = &steps;
int len = ilength(x);
ASSYNT(len >= 2, xorig, s_test, s_do);
@@ -505,16 +810,16 @@ SCM m_do(xorig, env)
}
/* evalcar is small version of inline EVALCAR when we don't care about speed */
-static SCM evalcar(x, env)
- SCM x, env;
+static SCM evalcar(x)
+ SCM x;
{
- return EVALCAR(x, env);
+ return EVALCAR(x);
}
/* Here are acros which return values rather than code. */
-static SCM iqq(form, env)
- SCM form, env;
+static SCM iqq(form)
+ SCM form;
{
SCM tmp;
if IMP(form) return form;
@@ -523,15 +828,15 @@ static SCM iqq(form, env)
SCM *data = VELTS(form);
tmp = EOL;
for(;--i >= 0;) tmp = cons(data[i], tmp);
- return vector(iqq(tmp, env));
+ return vector(iqq(tmp));
}
if NCONSP(form) return form;
tmp = CAR(form);
if (IM_UNQUOTE==tmp)
- return evalcar(CDR(form), env);
+ return evalcar(CDR(form));
if (NIMP(tmp) && IM_UQ_SPLICING==CAR(tmp))
- return append(cons2(evalcar(CDR(tmp),env), iqq(CDR(form),env), EOL));
- return cons(iqq(CAR(form),env), iqq(CDR(form),env));
+ return append(cons2(evalcar(CDR(tmp)), iqq(CDR(form)), EOL));
+ return cons(iqq(CAR(form)), iqq(CDR(form)));
}
static SCM m_iqq(form, depth, env)
@@ -545,9 +850,7 @@ static SCM m_iqq(form, depth, env)
long i = LENGTH(form);
SCM *data = VELTS(form);
tmp = EOL;
- ALLOW_INTS;
for(;--i >= 0;) tmp = cons(data[i], tmp);
- DEFER_INTS;
tmp = m_iqq(tmp, depth, env);
for(i = 0; i < LENGTH(form); i++) {
data[i] = CAR(tmp);
@@ -603,9 +906,7 @@ SCM m_quasiquote(xorig, env)
{
SCM x = CDR(xorig);
ASSYNT(ilength(x)==1, xorig, s_expression, s_quasiquote);
- DEFER_INTS;
- x = m_iqq(x, 1, env);
- ALLOW_INTS;
+ x = m_iqq(copytree(x), 1, env);
return cons(IM_QUASIQUOTE, x);
}
@@ -616,7 +917,6 @@ SCM m_delay(xorig, env)
return cons2(IM_DELAY, EOL, CDR(xorig));
}
-extern int verbose;
SCM m_define(x, env)
SCM x, env;
{
@@ -630,8 +930,12 @@ SCM m_define(x, env)
}
ASSYNT(NIMP(proc) && IDENTP(proc), arg1, s_variable, s_define);
ASSYNT(1==ilength(x), arg1, s_expression, s_define);
+ if (NIMP(env) && tc16_env==CAR(env)) {
+ DEFER_INTS_EGC;
+ env = CDR(env);
+ }
if NULLP(env) {
- x = evalcar(x,env);
+ x = evalcar(x);
#ifdef MACRO
while M_IDENTP(proc) {
ASSYNT(IMP(IDENT_MARK(proc)), proc, s_escaped, s_define);
@@ -640,7 +944,8 @@ SCM m_define(x, env)
#endif
arg1 = sym2vcell(proc);
#ifndef RECKLESS
- if (NIMP(CDR(arg1)) &&
+ if (2 <= verbose &&
+ NIMP(CDR(arg1)) &&
(proc ==
((SCM) SNAME(MACROP(CDR(arg1)) ? CDR(CDR(arg1)) : CDR(arg1))))
&& (CDR(arg1) != x))
@@ -656,21 +961,25 @@ SCM m_define(x, env)
return UNSPECIFIED;
#endif
}
- return cons2(IM_DEFINE, cons(proc,CAR(CAR(env))), x);
+ return cons2(IM_DEFINE, proc, x);
+ /* return cons2(IM_DEFINE, cons(proc,CAR(CAR(env))), x); */
}
/* end of acros */
-SCM m_letrec(xorig, env)
- SCM xorig, env;
+static SCM m_letrec1(op, imm, xorig, env)
+ SCM op, imm, xorig, env;
{
SCM cdrx = CDR(xorig); /* locally mutable version of form */
char *what = CHARS(CAR(xorig));
SCM x = cdrx, proc, arg1; /* structure traversers */
- SCM vars = EOL, inits = EOL, *initloc = &inits;
+ SCM vars = imm, inits = EOL, *initloc = &inits;
- ASRTSYNTAX(ilength(x) >= 2, s_body);
+ /* ASRTSYNTAX(ilength(x) >= 2, s_body); */
proc = CAR(x);
- if NULLP(proc) return m_letstar(xorig, env); /* null binding, let* faster */
+#if 0
+ if NULLP(proc) /* null binding, let* faster */
+ return m_letstar(cons2(CAR(xorig), EOL, m_body(imm, CDR(x), what)), env);
+#endif
ASRTSYNTAX(ilength(proc) >= 1, s_bindings);
do {
/* vars list reversed here, inits reversed at evaluation */
@@ -681,9 +990,19 @@ SCM m_letrec(xorig, env)
*initloc = cons(CAR(CDR(arg1)), EOL);
initloc = &CDR(*initloc);
} while NIMP(proc = CDR(proc));
- cdrx = cons2(vars, inits, CDR(x));
- bodycheck(xorig, &CDR(CDR(cdrx)), what);
- return cons(IM_LETREC, cdrx);
+ return cons2(op, vars, cons(inits, m_body(imm, CDR(x), what)));
+}
+
+SCM m_letrec(xorig, env)
+ SCM xorig, env;
+{
+ SCM x = CDR(xorig);
+ ASSYNT(ilength(x) >= 2, xorig, s_body, s_letrec);
+ if NULLP(CAR(x)) /* null binding, let* faster */
+ return m_letstar(cons2(CAR(xorig), EOL,
+ m_body(IM_LETREC, CDR(x), s_letrec)),
+ env);
+ return m_letrec1(IM_LETREC, IM_LETREC, xorig, env);
}
SCM m_let(xorig, env)
@@ -691,17 +1010,18 @@ SCM m_let(xorig, env)
{
SCM cdrx = CDR(xorig); /* locally mutable version of form */
SCM x = cdrx, proc, arg1, name; /* structure traversers */
- SCM vars = EOL, inits = EOL, *varloc = &vars, *initloc = &inits;
+ SCM vars = IM_LET, inits = EOL, *varloc = &vars, *initloc = &inits;
ASSYNT(ilength(x) >= 2, xorig, s_body, s_let);
proc = CAR(x);
- if (NULLP(proc)
+ if (NULLP(proc) /* null or single binding, let* is faster */
|| (NIMP(proc) && CONSP(proc)
&& NIMP(CAR(proc)) && CONSP(CAR(proc)) && NULLP(CDR(proc))))
- return m_letstar(xorig, env); /* null or single binding, let* is faster */
+ return m_letstar(cons2(CAR(xorig), proc, m_body(IM_LET, CDR(x), s_let)),
+ env);
ASSYNT(NIMP(proc), xorig, s_bindings, s_let);
if CONSP(proc) /* plain let, proc is <bindings> */
- return cons(IM_LET, CDR(m_letrec(xorig, env)));
+ return m_letrec1(IM_LET, IM_LET, xorig, env);
if (!IDENTP(proc)) wta(xorig, s_bindings, s_let); /* bad let */
name = proc; /* named let, build equiv letrec */
x = CDR(x);
@@ -712,19 +1032,16 @@ SCM m_let(xorig, env)
arg1 = CAR(proc);
ASSYNT(2==ilength(arg1), xorig, s_bindings, s_let);
ASSYNT(NIMP(CAR(arg1)) && IDENTP(CAR(arg1)), xorig, s_variable, s_let);
- *varloc = cons(CAR(arg1), EOL);
+ *varloc = cons(CAR(arg1), IM_LET);
varloc = &CDR(*varloc);
*initloc = cons(CAR(CDR(arg1)), EOL);
initloc = &CDR(*initloc);
proc = CDR(proc);
}
- return
- m_letrec(cons2(i_let,
- cons(cons2(name,
- cons2(TOPRENAME(i_lambda), vars, CDR(x)), EOL),
- EOL),
- acons(name, inits, EOL)), /* body */
- env);
+ proc = cons2(TOPRENAME(i_lambda), vars, m_body(IM_LET, CDR(x), s_let));
+ proc = cons2(i_let, cons(cons2(name, proc, EOL), EOL),
+ acons(name, inits, EOL));
+ return m_letrec1(IM_LETREC, IM_LET, proc, env);
}
#define s_atapply (ISYMCHARS(IM_APPLY)+1)
@@ -736,19 +1053,154 @@ SCM m_apply(xorig, env)
return cons(IM_APPLY, CDR(xorig));
}
-#define s_atcall_cc (ISYMCHARS(IM_CONT)+1)
+SCM m_expand_body(xorig)
+ SCM xorig;
+{
+ SCM form, x = CDR(xorig), defs = EOL;
+ char *what = ISYMCHARS(CAR(xorig)) + 2;
+ while NIMP(x) {
+ form = CAR(x);
+ if (IMP(form) || NCONSP(form)) break;
+ if IMP(CAR(form)) break;
+ if (! IDENTP(CAR(form))) break;
+ form = macroexp1(cons(CAR(form), CDR(form)), 0);
+ if (IM_DEFINE==CAR(form)) {
+ defs = cons(CDR(form), defs);
+ x = CDR(x);
+ }
+ else if NIMP(defs) {
+ break;
+ }
+ else if (IM_BEGIN==CAR(form)) {
+ x = append(cons2(CDR(form), CDR(x), EOL));
+ }
+ else {
+ x = cons(form, CDR(x));
+ break;
+ }
+ }
+ ASSYNT(NIMP(x), CDR(xorig), s_body, what);
+ if NIMP(defs)
+ x = cons(m_letrec1(IM_LETREC, IM_DEFINE, cons2(i_define, defs, x),
+ wrapenv())
+ , EOL);
+ DEFER_INTS;
+ CAR(xorig) = CAR(x);
+ CDR(xorig) = CDR(x);
+ ALLOW_INTS;
+ return xorig;
+}
-SCM m_cont(xorig, env)
- SCM xorig, env;
+static SCM macroexp1(x, check)
+ SCM x;
+ int check;
{
- ASSYNT(ilength(CDR(xorig))==1, xorig, s_expression, s_atcall_cc);
- return cons(IM_CONT, CDR(xorig));
+ SCM res, proc;
+ int argc;
+ ASRTGO(IDENTP(CAR(x)), badfun);
+ macro_tail:
+ proc = *lookupcar(x, 0);
+ if (NIMP(proc) && MACROP(proc)) {
+ unmemocar(x);
+ res = apply(CDR(proc), cons2(x, wrapenv(), EOL), EOL);
+ switch ((int)(CAR(proc)>>16) & 0x7f) {
+ case 2: /* mmacro */
+ if (ilength(res) <= 0)
+ res = cons2(IM_BEGIN, res, EOL);
+ DEFER_INTS;
+ CAR(x) = CAR(res);
+ CDR(x) = CDR(res);
+ ALLOW_INTS;
+ break;
+ case 1: /* macro */
+ x = NIMP(res) ? res : cons2(IM_BEGIN, res, EOL);
+ break;
+ case 0: /* acro */
+ return cons2(IM_QUOTE, res, EOL);
+ }
+ if (NIMP(CAR(x)) && IDENTP(CAR(x))) goto macro_tail;
+#ifndef RECKLESS
+ if (check && IM_DEFINE==CAR(x))
+ everr(x, wrapenv() /*scm_env*/, i_define, "Bad placement", "");
+#endif
+ return x;
+ }
+ else if (!check) {
+ unmemocar(x);
+ return x;
+ }
+#ifdef RECKLESS
+ return x;
+#else
+ ASRTGO(NIMP(proc), badfun);
+ argc = ilength(CDR(x));
+# ifdef CCLO
+ cclo_tail:
+# endif
+ switch TYP7(proc) {
+ default:
+ badfun:
+ unmemocar(x);
+ everr(x, wrapenv(), UNBNDP(proc) ? CAR(x) : proc,
+ UNBNDP(proc) ? s_unbnd : s_wtap, "");
+ case tc7_lsubr:
+ case tc7_rpsubr:
+ case tc7_asubr:
+ return x;
+ case tc7_subr_0:
+ ASRTGO(0==argc, wrongnumargs);
+ return x;
+ case tc7_contin:
+ case tc7_subr_1:
+ case tc7_cxr:
+ ASRTGO(1==argc, wrongnumargs);
+ return x;
+ case tc7_subr_2:
+ ASRTGO(2==argc, wrongnumargs);
+ return x;
+ case tc7_subr_3:
+ ASRTGO(3==argc, wrongnumargs);
+ return x;
+ case tc7_subr_1o:
+ ASRTGO(0==argc || 1==argc, wrongnumargs);
+ return x;
+ case tc7_subr_2o:
+ ASRTGO(1==argc || 2==argc, wrongnumargs);
+ return x;
+ case tc7_lsubr_2:
+ ASRTGO(2<=argc, wrongnumargs);
+ return x;
+ case tc7_specfun:
+ switch TYP16(proc) {
+ case tc16_apply:
+ ASRTGO(2<=argc, wrongnumargs);
+ return x;
+ case tc16_call_cc:
+ ASRTGO(1==argc, wrongnumargs);
+ return x;
+# ifdef CCLO
+ case tc16_cclo:
+ proc = CCLO_SUBR(proc);
+ argc++;
+ goto cclo_tail;
+# endif
+ }
+ case tcs_closures:
+ if (badargsp(proc, CDR(x))) {
+ wrongnumargs:
+ unmemocar(x);
+ everr(x, wrapenv()/*scm_env*/, proc, (char *)WNA, "");
+ }
+ return x;
+ }
+#endif /* ndef RECKLESS */
}
#ifndef RECKLESS
-int badargsp(formals, args)
- SCM formals, args;
+int badargsp(proc, args)
+ SCM proc, args;
{
+ SCM formals = CAR(CODE(proc));
while NIMP(formals) {
if NCONSP(formals) return 0;
if IMP(args) return 1;
@@ -760,59 +1212,93 @@ int badargsp(formals, args)
#endif
char s_map[] = "map", s_for_each[] = "for-each", s_eval[] = "eval";
-SCM eqv P((SCM x, SCM y));
-#ifdef CAUTIOUS
-static char s_bottom[] = "stacktrace bottommed out";
-#endif
+char s_call_cc[] = "call-with-current-continuation"; /* s_apply[] = "apply"; */
+
+static SCM wrapenv()
+{
+ register SCM z;
+ NEWCELL(z);
+ DEFER_INTS_EGC;
+ CDR(z) = scm_env;
+ CAR(z) = tc16_env;
+ EGC_ROOT(z);
+ return z;
+}
SCM ceval(x, env)
SCM x, env;
{
+ DEFER_INTS_EGC;
+ ENV_PUSH;
+ scm_env = env;
+ TRACE(x);
+ x = ceval_1(x);
+ ENV_POP;
+ ALLOW_INTS_EGC;
+ return x;
+}
+
+static SCM ceval_1(x)
+ SCM x;
+{
union {SCM *lloc; SCM arg1;} t;
- SCM proc, arg2;
+ SCM proc, arg2, arg3;
+ int envpp = 0; /* 1 means an environment has been pushed in this
+ invocation of ceval_1, -1 means pushed and then popped. */
CHECK_STACK;
loop: POLL;
+ TRACE(x);
+#ifdef SCM_PROFILE
+ eval_cases[TYP7(x)]++;
+#endif
switch TYP7(x) {
case tcs_symbols:
/* only happens when called at top level */
- x = cons(x, UNDEFINED);
- goto retval;
+ x = *lookupcar(cons(x, UNDEFINED), LOOKUP_UNDEFP);
+ goto retx;
case (127 & IM_AND):
x = CDR(x);
t.arg1 = x;
while(NNULLP(t.arg1 = CDR(t.arg1)))
- if FALSEP(EVALCAR(x, env)) return BOOL_F;
+ if (FALSEP(EVALCAR(x))) {x = BOOL_F; goto retx;}
else x = t.arg1;
goto carloop;
- cdrtcdrxbegin:
-#ifdef CAUTIOUS
- ASSERT(NIMP(stacktrace), EOL, s_bottom, s_eval);
- stacktrace = CDR(stacktrace);
-#endif
cdrxbegin:
case (127 & IM_BEGIN):
x = CDR(x);
begin:
t.arg1 = x;
while(NNULLP(t.arg1 = CDR(t.arg1))) {
- SIDEVAL(CAR(x), env);
+ if IMP(CAR(x)) {
+ if ISYMP(CAR(x)) {
+ x = m_expand_body(x);
+ goto begin;
+ }
+ }
+ else
+ ceval_1(CAR(x));
x = t.arg1;
}
carloop: /* eval car of last form in list */
if NCELLP(CAR(x)) {
x = CAR(x);
- return IMP(x)?EVALIMP(x, env):I_VAL(x);
+ x = IMP(x) ? EVALIMP(x) : I_VAL(x);
+ goto retx;
}
- if IDENTP(CAR(x)) {
- retval:
- return *lookupcar(x, env);
+
+ if ATOMP(CAR(x)) {
+ x = evalatomcar(x);
+ retx:
+ ENV_MAY_POP(envpp, 0);
+ ALLOW_INTS_EGC;
+ return x;
}
x = CAR(x);
goto loop; /* tail recurse */
case (127 & IM_CASE):
x = CDR(x);
- t.arg1 = EVALCAR(x, env);
+ t.arg1 = EVALCAR(x);
#ifndef INUMS_ONLY
arg2 = (SCM)(IMP(t.arg1) || !NUMP(t.arg1));
#endif
@@ -835,331 +1321,312 @@ SCM ceval(x, env)
proc = CDR(proc);
}
}
+ retunspec:
+ ENV_MAY_POP(envpp, 0);
+ ALLOW_INTS_EGC;
return UNSPECIFIED;
case (127 & IM_COND):
while(NIMP(x = CDR(x))) {
proc = CAR(x);
- t.arg1 = EVALCAR(proc, env);
+ t.arg1 = EVALCAR(proc);
if NFALSEP(t.arg1) {
x = CDR(proc);
- if NULLP(x) return t.arg1;
+ if NULLP(x) {
+ x = t.arg1;
+ goto retx;
+ }
if (IM_ARROW != CAR(x)) goto begin;
proc = CDR(x);
- proc = EVALCAR(proc, env);
+ proc = EVALCAR(proc);
ASRTGO(NIMP(proc), badfun);
-#ifdef CAUTIOUS
- if CLOSUREP(proc) goto checkargs1;
-#endif
goto evap1;
}
}
- return UNSPECIFIED;
+ goto retunspec;
case (127 & IM_DO):
+ ENV_MAY_PUSH(envpp);
x = CDR(x);
proc = CAR(CDR(x)); /* inits */
- t.arg1 = EOL; /* values */
+ scm_env_tmp = EOL; /* values */
while NIMP(proc) {
- t.arg1 = cons(EVALCAR(proc, env), t.arg1);
+ scm_env_cons_tmp(EVALCAR(proc));
proc = CDR(proc);
}
- env = EXTEND_ENV(CAR(x), t.arg1, env);
+ EXTEND_ENV(CAR(x));
x = CDR(CDR(x));
- while (proc = CAR(x), FALSEP(EVALCAR(proc, env))) {
+ while (proc = CAR(x), FALSEP(EVALCAR(proc))) {
for(proc = CAR(CDR(x));NIMP(proc);proc = CDR(proc)) {
t.arg1 = CAR(proc); /* body */
- SIDEVAL(t.arg1, env);
+ SIDEVAL_1(t.arg1);
}
- for(t.arg1 = EOL, proc = CDR(CDR(x)); NIMP(proc); proc = CDR(proc))
- t.arg1 = cons(EVALCAR(proc, env), t.arg1); /* steps */
- env = EXTEND_ENV(CAR(CAR(env)), t.arg1, CDR(env));
+ scm_env_tmp = EOL;
+ for(proc = CDR(CDR(x)); NIMP(proc); proc = CDR(proc)) {
+ scm_env_cons_tmp(EVALCAR(proc)); /* steps */
+ }
+ DEFER_INTS_EGC;
+ t.arg1 = CAR(CAR(scm_env));
+ scm_env = CDR(scm_env);
+ EXTEND_ENV(t.arg1);
}
x = CDR(proc);
- if NULLP(x) return UNSPECIFIED;
+ if NULLP(x) goto retunspec;
goto begin;
case (127 & IM_IF):
x = CDR(x);
- if NFALSEP(EVALCAR(x, env)) x = CDR(x);
- else if IMP(x = CDR(CDR(x))) return UNSPECIFIED;
+ if NFALSEP(EVALCAR(x)) x = CDR(x);
+ else if IMP(x = CDR(CDR(x))) goto retunspec;
goto carloop;
case (127 & IM_LET):
+ ENV_MAY_PUSH(envpp);
x = CDR(x);
proc = CAR(CDR(x));
- t.arg1 = EOL;
+ scm_env_tmp = EOL;
do {
- t.arg1 = cons(EVALCAR(proc, env), t.arg1);
+ scm_env_cons_tmp(EVALCAR(proc));
} while NIMP(proc = CDR(proc));
- env = EXTEND_ENV(CAR(x), t.arg1, env);
+ EXTEND_ENV(CAR(x));
x = CDR(x);
goto cdrxbegin;
case (127 & IM_LETREC):
+ ENV_MAY_PUSH(envpp);
x = CDR(x);
- env = EXTEND_ENV(CAR(x), undefineds, env);
+ scm_env_tmp = undefineds;
+ EXTEND_ENV(CAR(x));
x = CDR(x);
proc = CAR(x);
- t.arg1 = EOL;
+ scm_env_tmp = EOL;
do {
- t.arg1 = cons(EVALCAR(proc, env), t.arg1);
+ scm_env_cons_tmp(EVALCAR(proc));
} while NIMP(proc = CDR(proc));
- CDR(CAR(env)) = t.arg1;
+ EGC_ROOT(CAR(scm_env));
+ CDR(CAR(scm_env)) = scm_env_tmp;
+ scm_env_tmp = EOL;
goto cdrxbegin;
case (127 & IM_LETSTAR):
+ ENV_MAY_PUSH(envpp);
x = CDR(x);
proc = CAR(x);
if IMP(proc) {
- env = EXTEND_ENV(EOL, EOL, env);
+ scm_env_tmp = EOL;
+ EXTEND_ENV(EOL);
goto cdrxbegin;
}
do {
t.arg1 = CAR(proc);
proc = CDR(proc);
- env = EXTEND_ENV(t.arg1, EVALCAR(proc, env), env);
+ scm_env_tmp = EVALCAR(proc);
+ EXTEND_ENV(t.arg1);
} while NIMP(proc = CDR(proc));
goto cdrxbegin;
case (127 & IM_OR):
x = CDR(x);
t.arg1 = x;
while(NNULLP(t.arg1 = CDR(t.arg1))) {
- x = EVALCAR(x, env);
- if NFALSEP(x) return x;
+ x = EVALCAR(x);
+ if NFALSEP(x) goto retx;
x = t.arg1;
}
goto carloop;
case (127 & IM_LAMBDA):
- return closure(CDR(x), env);
+ x = closure(CDR(x), ISYMVAL(CAR(x)));
+ goto retx;
case (127 & IM_QUOTE):
- return CAR(CDR(x));
+ x = CAR(CDR(x));
+ goto retx;
case (127 & IM_SET):
x = CDR(x);
+ arg2 = EVALCAR(CDR(x));
proc = CAR(x);
switch (7 & (int)proc) {
case 0:
if CONSP(proc)
- t.lloc = farlookup(proc,env);
- else {
- t.lloc = lookupcar(x,env);
-#ifdef MACRO
-# ifndef RECKLESS
- if (NIMP(*t.lloc) && MACROP(*t.lloc)) {
- unmemocar(x,env);
- everr(x, env, CAR(x), s_badkey, s_set);
- }
-# endif
-#endif
- }
+ *farlookup(proc) = arg2;
+ else
+ *lookupcar(x, LOOKUP_UNDEFP|LOOKUP_MACROP) = arg2;
break;
case 1:
- t.lloc = &I_VAL(proc);
+ I_VAL(proc) = arg2;
break;
case 4:
- t.lloc = ilookup(proc, env);
+ *ilookup(proc) = arg2;
break;
}
- x = CDR(x);
- *t.lloc = EVALCAR(x, env);
#ifdef SICP
- return *t.lloc;
-#else
- return UNSPECIFIED;
+ x = arg2;
+ goto retx;
#endif
+ goto retunspec;
case (127 & IM_DEFINE): /* only for internal defines */
+ goto badfun;
+#if 0
x = CDR(x);
proc = CAR(x);
x = CDR(x);
- x = evalcar(x, env);
- env = CAR(env);
- DEFER_INTS;
- CAR(env) = proc;
- CDR(env) = cons(x, CDR(env));
- ALLOW_INTS;
- return UNSPECIFIED;
+ x = evalcar(x);
+ DEFER_INTS_EGC;
+ scm_env_tmp = CDR(CAR(scm_env));
+ scm_env_cons_tmp(x);
+ EGC_ROOT(CAR(scm_env));
+ /* DEFER_INTS; */
+ CAR(CAR(scm_env)) = proc;
+ CDR(CAR(scm_env)) = scm_env_tmp;
+ /* ALLOW_INTS; */
+ goto retunspec;
+#endif
/* new syntactic forms go here. */
case (127 & MAKISYM(0)):
proc = CAR(x);
ASRTGO(ISYMP(proc), badfun);
+#ifdef SCM_PROFILE
+ eval_cases_other[ISYMNUM(proc)]++;
+#endif
switch ISYMNUM(proc) {
case (ISYMNUM(IM_APPLY)):
proc = CDR(x);
- proc = EVALCAR(proc, env);
+ proc = EVALCAR(proc);
ASRTGO(NIMP(proc), badfun);
+ t.arg1 = CDR(CDR(x));
+ t.arg1 = EVALCAR(t.arg1);
if (CLOSUREP(proc)) {
- t.arg1 = CDR(CDR(x));
- t.arg1 = EVALCAR(t.arg1, env);
+ ENV_MAY_PUSH(envpp);
+ scm_env_tmp = t.arg1;
#ifndef RECKLESS
- if (badargsp(CAR(CODE(proc)), t.arg1)) goto wrongnumargs;
-#endif
- env = EXTEND_ENV(CAR(CODE(proc)), t.arg1, ENV(proc));
- x = CODE(proc);
- goto cdrxbegin;
- }
- proc = i_apply;
- goto evapply;
- case (ISYMNUM(IM_CONT)):
- t.arg1 = scm_make_cont();
- if ((proc = setjump(CONT(t.arg1)->jmpbuf)))
-#ifdef SHORT_INT
- return (SCM)thrown_value;
+ goto clo_checked;
#else
- return (SCM)proc;
+ goto clo_unchecked;
#endif
- proc = CDR(x);
- proc = evalcar(proc, env);
- ASRTGO(NIMP(proc), badfun);
-#ifdef CAUTIOUS
- if CLOSUREP(proc) {
- checkargs1:
- stacktrace = cons(x, stacktrace);
- /* Check that argument list of proc can match 1 arg. */
- arg2 = CAR(CODE(proc));
- ASRTGO(NIMP(arg2), wrongnumargs);
- if NCONSP(arg2) goto evap1;
- arg2 = CDR(arg2);
- ASRTGO(NULLP(arg2) || NCONSP(arg2), wrongnumargs);
}
-#endif
- goto evap1;
+ x = apply(proc, t.arg1, EOL);
+ goto retx;
case (ISYMNUM(IM_DELAY)):
- return makprom(closure(CDR(x), env));
+ x = makprom(closure(CDR(x), 0));
+ goto retx;
case (ISYMNUM(IM_QUASIQUOTE)):
- return iqq(CAR(CDR(x)), env);
+ ALLOW_INTS_EGC;
+ x = iqq(CAR(CDR(x)));
+ goto retx;
case (ISYMNUM(IM_FARLOC_CAR)):
case (ISYMNUM(IM_FARLOC_CDR)):
- return *farlookup(x, env);
+ x = *farlookup(x);
+ goto retx;
default:
goto badfun;
}
default:
proc = x;
badfun:
- everr(x, env, proc, "Wrong type to apply: ", "");
+ everr(x, wrapenv() /*scm_env*/, proc, s_wtap, "");
case tc7_vector:
case tc7_bvect: case tc7_ivect: case tc7_uvect:
case tc7_fvect: case tc7_dvect: case tc7_cvect:
case tc7_string:
case tc7_smob:
-#ifdef MACRO
- if M_IDENTP(x) {
- x = cons(x, UNDEFINED);
- goto retval;
- }
-#endif
- return x;
+ goto retx;
case (127 & ILOC00):
- proc = *ilookup(CAR(x), env);
- ASRTGO(NIMP(proc), badfun);
-#ifndef RECKLESS
-# ifdef CAUTIOUS
- goto checkargs;
-# endif
-#endif
+ proc = *ilookup(CAR(x));
break;
case tcs_cons_gloc:
proc = I_VAL(CAR(x));
- ASRTGO(NIMP(proc), badfun);
-#ifndef RECKLESS
-# ifdef CAUTIOUS
- goto checkargs;
-# endif
-#endif
break;
case tcs_cons_nimcar:
- if IDENTP(CAR(x)) {
- proc = *lookupcar(x, env);
- if IMP(proc) {unmemocar(x, env); goto badfun;}
- if MACROP(proc) {
- unmemocar(x, env);
- t.arg1 = apply(CDR(proc), x, cons(env, listofnull));
- switch ((int)(CAR(proc)>>16)) {
- case 2: /* mmacro */
- if (ilength(t.arg1) <= 0)
- t.arg1 = cons2(IM_BEGIN, t.arg1, EOL);
- DEFER_INTS;
- CAR(x) = CAR(t.arg1);
- CDR(x) = CDR(t.arg1);
- ALLOW_INTS;
- goto loop;
- case 1: /* macro */
- if NIMP(x = t.arg1) goto loop;
- case 0: /* acro */
- return t.arg1;
- }
- }
+ if ATOMP(CAR(x)) {
+ x = macroexp1(x, !0);
+ goto loop;
}
- else proc = ceval(CAR(x), env);
- ASRTGO(NIMP(proc), badfun);
-#ifndef RECKLESS
-# ifdef CAUTIOUS
- checkargs:
-# endif
+ proc = ceval_1(CAR(x));
/* At this point proc is the evaluated procedure from the function
position and x has the form which is being evaluated. */
- if CLOSUREP(proc) {
-# ifdef CAUTIOUS
- stacktrace = cons(x, stacktrace);
-# endif
- arg2 = CAR(CODE(proc));
- t.arg1 = CDR(x);
- while NIMP(arg2) {
- if NCONSP(arg2) {
- goto evapply;
+ }
+ ASRTGO(NIMP(proc), badfun);
+ *scm_estk_ptr = scm_env; /* For error reporting at wrongnumargs. */
+ if NULLP(CDR(x)) {
+ evap0:
+ ENV_MAY_POP(envpp, CLOSUREP(proc));
+ ALLOW_INTS_EGC;
+ switch TYP7(proc) { /* no arguments given */
+ case tc7_subr_0:
+ return SUBRF(proc)();
+ case tc7_subr_1o:
+ return SUBRF(proc) (UNDEFINED);
+ case tc7_lsubr:
+ return SUBRF(proc)(EOL);
+ case tc7_rpsubr:
+ return BOOL_T;
+ case tc7_asubr:
+ return SUBRF(proc)(UNDEFINED, UNDEFINED);
+ case tcs_closures:
+ DEFER_INTS_EGC;
+ ENV_MAY_PUSH(envpp);
+ scm_env_tmp = EOL;
+#ifdef SCM_PROFILE
+ eval_clo_cases[0][0]++;
+#endif
+#ifdef CAUTIOUS
+ if (0!=ARGC(proc)) {
+ clo_checked:
+ DEFER_INTS_EGC;
+ t.arg1 = CAR(CODE(proc));
+ arg2 = scm_env_tmp;
+ while NIMP(t.arg1) {
+ if NCONSP(t.arg1) goto clo_unchecked;
+ if IMP(arg2) goto umwrongnumargs;
+ t.arg1 = CDR(t.arg1);
+ arg2 = CDR(arg2);
}
- if IMP(t.arg1) goto umwrongnumargs;
- arg2 = CDR(arg2);
- t.arg1 = CDR(t.arg1);
+ if NNULLP(arg2) goto umwrongnumargs;
}
- if NNULLP(t.arg1) goto umwrongnumargs;
- }
+#else /* def CAUTIOUS */
+ clo_checked:
#endif
- }
- evapply:
- if NULLP(CDR(x)) switch TYP7(proc) { /* no arguments given */
- case tc7_subr_0:
- return SUBRF(proc)();
- case tc7_subr_1o:
- return SUBRF(proc) (UNDEFINED);
- case tc7_lsubr:
- return SUBRF(proc)(EOL);
- case tc7_rpsubr:
- return BOOL_T;
- case tc7_asubr:
- return SUBRF(proc)(UNDEFINED, UNDEFINED);
+ clo_unchecked:
+ x = CODE(proc);
+ scm_env = ENV(proc);
+ EXTEND_ENV(CAR(x));
+ goto cdrxbegin;
+ case tc7_specfun:
#ifdef CCLO
- case tc7_cclo:
- t.arg1 = proc;
- proc = CCLO_SUBR(proc);
- goto evap1;
+ if (tc16_cclo==TYP16(proc)) {
+ t.arg1 = proc;
+ proc = CCLO_SUBR(proc);
+ goto evap1;
+ }
#endif
- case tcs_closures:
- x = CODE(proc);
- env = EXTEND_ENV(CAR(x), EOL, ENV(proc));
- goto cdrtcdrxbegin;
- case tc7_contin:
- case tc7_subr_1:
- case tc7_subr_2:
- case tc7_subr_2o:
- case tc7_cxr:
- case tc7_subr_3:
- case tc7_lsubr_2:
- umwrongnumargs:
- unmemocar(x, env);
- wrongnumargs:
- everr(x, env, proc, (char *)WNA, "");
- default:
- goto badfun;
+ case tc7_contin:
+ case tc7_subr_1:
+ case tc7_subr_2:
+ case tc7_subr_2o:
+ case tc7_cxr:
+ case tc7_subr_3:
+ case tc7_lsubr_2:
+ umwrongnumargs:
+ unmemocar(x);
+ wrongnumargs:
+ if (envpp < 0) {
+ scm_estk_ptr += SCM_ESTK_FRLEN;
+ scm_env = *scm_estk_ptr;
+ }
+ everr(x, wrapenv()/*scm_env*/, proc, (char *)WNA, "");
+ default:
+ goto badfun;
+ }
}
x = CDR(x);
#ifdef CAUTIOUS
if (IMP(x)) goto wrongnumargs;
#endif
- t.arg1 = EVALCAR(x, env);
+ t.arg1 = EVALCAR(x);
x = CDR(x);
- if NULLP(x)
-evap1: switch TYP7(proc) { /* have one argument in t.arg1 */
- case tc7_subr_2o:
- return SUBRF(proc)(t.arg1, UNDEFINED);
- case tc7_subr_1:
- case tc7_subr_1o:
- return SUBRF(proc)(t.arg1);
- case tc7_cxr:
+ if NULLP(x) {
+evap1:
+ ENV_MAY_POP(envpp, CLOSUREP(proc));
+ ALLOW_INTS_EGC;
+ switch TYP7(proc) { /* have one argument in t.arg1 */
+ case tc7_subr_2o:
+ return SUBRF(proc)(t.arg1, UNDEFINED);
+ case tc7_subr_1:
+ case tc7_subr_1o:
+ return SUBRF(proc)(t.arg1);
+ case tc7_cxr:
#ifdef FLOATS
if SUBRF(proc) {
if INUMP(t.arg1)
@@ -1191,109 +1658,214 @@ evap1: switch TYP7(proc) { /* have one argument in t.arg1 */
return SUBRF(proc)(t.arg1, UNDEFINED);
case tc7_lsubr:
return SUBRF(proc)(cons(t.arg1, EOL));
-#ifdef CCLO
- case tc7_cclo:
- arg2 = t.arg1;
- t.arg1 = proc;
- proc = CCLO_SUBR(proc);
- goto evap2;
+ case tcs_closures:
+ ENV_MAY_PUSH(envpp);
+#ifdef SCM_PROFILE
+ eval_clo_cases[1][ARGC(proc)]++;
#endif
- case tcs_closures:
- x = CODE(proc);
- env = EXTEND_ENV(CAR(x), cons(t.arg1, EOL), ENV(proc));
- goto cdrtcdrxbegin;
- case tc7_contin:
- scm_dynthrow(CONT(proc), t.arg1);
- case tc7_subr_2:
- case tc7_subr_0:
- case tc7_subr_3:
- case tc7_lsubr_2:
- goto wrongnumargs;
- default:
- goto badfun;
- }
-#ifdef CAUTIOUS
- if (IMP(x)) goto wrongnumargs;
+ if (1==ARGC(proc)) {
+ scm_env_cons(t.arg1, EOL);
+ goto clo_unchecked;
+ }
+ else {
+ scm_env_tmp = cons(t.arg1, EOL);
+ goto clo_checked;
+ }
+ case tc7_contin:
+ scm_dynthrow(CONT(proc), t.arg1);
+ case tc7_specfun:
+ switch TYP16(proc) {
+ case tc16_call_cc:
+ proc = t.arg1;
+ DEFER_INTS_EGC;
+ t.arg1 = scm_make_cont();
+ EGC_ROOT(t.arg1);
+ if ((x = setjump(CONT(t.arg1)->jmpbuf))) {
+#ifdef SHORT_INT
+ x = (SCM)thrown_value;
#endif
- { /* have two or more arguments */
- arg2 = EVALCAR(x, env);
- x = CDR(x);
- if NULLP(x)
+ goto retx;
+ }
+ ASRTGO(NIMP(proc), badfun);
+ goto evap1;
#ifdef CCLO
- evap2:
+ case tc16_cclo:
+ arg2 = t.arg1;
+ t.arg1 = proc;
+ proc = CCLO_SUBR(proc);
+ goto evap2;
#endif
- switch TYP7(proc) { /* have two arguments */
+ }
case tc7_subr_2:
- case tc7_subr_2o:
- return SUBRF(proc)(t.arg1, arg2);
- case tc7_lsubr:
- return SUBRF(proc)(cons2(t.arg1, arg2, EOL));
- case tc7_lsubr_2:
- return SUBRF(proc)(t.arg1, arg2, EOL);
- case tc7_rpsubr:
- case tc7_asubr:
- return SUBRF(proc)(t.arg1, arg2);
-#ifdef CCLO
- cclon: case tc7_cclo:
- return apply(CCLO_SUBR(proc), proc,
- cons2(t.arg1, arg2, cons(eval_args(x, env), EOL)));
-/* case tc7_cclo:
- x = cons(arg2, eval_args(x, env));
- arg2 = t.arg1;
- t.arg1 = proc;
- proc = CCLO_SUBR(proc);
- goto evap3; */
-#endif
case tc7_subr_0:
- case tc7_cxr:
- case tc7_subr_1o:
- case tc7_subr_1:
case tc7_subr_3:
- case tc7_contin:
+ case tc7_lsubr_2:
goto wrongnumargs;
default:
goto badfun;
- case tcs_closures:
- env = EXTEND_ENV(CAR(CODE(proc)), cons2(t.arg1, arg2, EOL), ENV(proc));
- x = CODE(proc);
- goto cdrtcdrxbegin;
}
- switch TYP7(proc) { /* have 3 or more arguments */
- case tc7_subr_3:
- ASRTGO(NULLP(CDR(x)), wrongnumargs);
- return SUBRF(proc)(t.arg1, arg2, EVALCAR(x, env));
- case tc7_asubr:
-/* t.arg1 = SUBRF(proc)(t.arg1, arg2);
- while NIMP(x) {
- t.arg1 = SUBRF(proc)(t.arg1, EVALCAR(x, env));
- x = CDR(x);
+ }
+#ifdef CAUTIOUS
+ if (IMP(x)) goto wrongnumargs;
+#endif
+ { /* have two or more arguments */
+ arg2 = EVALCAR(x);
+ x = CDR(x);
+ if NULLP(x) { /* have two arguments */
+ evap2:
+ ENV_MAY_POP(envpp, CLOSUREP(proc));
+ ALLOW_INTS_EGC;
+ switch TYP7(proc) {
+ case tc7_subr_2:
+ case tc7_subr_2o:
+ return SUBRF(proc)(t.arg1, arg2);
+ case tc7_lsubr:
+ return SUBRF(proc)(cons2(t.arg1, arg2, EOL));
+ case tc7_lsubr_2:
+ return SUBRF(proc)(t.arg1, arg2, EOL);
+ case tc7_rpsubr:
+ case tc7_asubr:
+ return SUBRF(proc)(t.arg1, arg2);
+ case tc7_specfun:
+ switch TYP16(proc) {
+ case tc16_apply:
+ proc = t.arg1;
+ if NULLP(arg2) goto evap0;
+ if (IMP(arg2) || NCONSP(arg2)) {
+ x = arg2;
+ badlst: wta(x, (char *)ARGn, s_apply);
+ }
+ t.arg1 = CAR(arg2);
+ x = CDR(arg2);
+ apply3:
+ if NULLP(x) goto evap1;
+ ASRTGO(NIMP(x) && CONSP(x), badlst);
+ arg2 = CAR(x);
+ x = CDR(x);
+ apply4:
+ if NULLP(x) goto evap2;
+ ASRTGO(NIMP(x) && CONSP(x), badlst);
+ arg3 = CAR(x);
+ ASRTGO(0 <= ilength(x), badlst);
+ x = copy_list(CDR(x));
+ goto evap3;
+#ifdef CCLO
+ case tc16_cclo: cclon:
+ return apply(CCLO_SUBR(proc),
+ cons2(proc, t.arg1, cons(arg2, x)), EOL);
+ /* arg3 = arg2;
+ arg2 = t.arg1;
+ t.arg1 = proc;
+ proc = CCLO_SUBR(proc);
+ goto evap3; */
+#endif
+ }
+ case tc7_subr_0:
+ case tc7_cxr:
+ case tc7_subr_1o:
+ case tc7_subr_1:
+ case tc7_subr_3:
+ case tc7_contin:
+ goto wrongnumargs;
+ default:
+ goto badfun;
+ case tcs_closures:
+ ENV_MAY_PUSH(envpp);
+#ifdef SCM_PROFILE
+ eval_clo_cases[2][ARGC(proc)]++;
+#endif
+ switch ARGC(proc) {
+ case 2:
+ scm_env_cons2(t.arg1, arg2, EOL);
+ goto clo_unchecked;
+ case 1:
+ scm_env_cons(t.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);
+ goto clo_checked;
+ }
}
- return t.arg1; */
- case tc7_rpsubr:
- return apply(proc, t.arg1, acons(arg2, eval_args(x, env), EOL));
- case tc7_lsubr_2:
- return SUBRF(proc)(t.arg1, arg2, eval_args(x, env));
- case tc7_lsubr:
- return SUBRF(proc)(cons2(t.arg1, arg2, eval_args(x, env)));
+ }
+ { /* have 3 or more arguments */
+ arg3 = EVALCAR(x);
+ x = CDR(x);
+ if NIMP(x) x = eval_args(x);
+ evap3:
+ ENV_MAY_POP(envpp, CLOSUREP(proc));
+ ALLOW_INTS_EGC;
+ switch TYP7(proc) {
+ case tc7_subr_3:
+ ASRTGO(NULLP(x), wrongnumargs);
+ return SUBRF(proc)(t.arg1, arg2, arg3);
+ case tc7_asubr:
+ /* t.arg1 = SUBRF(proc)(t.arg1, arg2);
+ while NIMP(x) {
+ t.arg1 = SUBRF(proc)(t.arg1, EVALCAR(x, env));
+ x = CDR(x);
+ }
+ return t.arg1; */
+ case tc7_rpsubr:
+ return apply(proc, cons2(t.arg1, arg2, cons(arg3, x)), EOL);
+ case tc7_lsubr_2:
+ return SUBRF(proc)(t.arg1, arg2, cons(arg3, x));
+ case tc7_lsubr:
+ return SUBRF(proc)(cons2(t.arg1, arg2, cons(arg3, x)));
+ case tcs_closures:
+ ENV_MAY_PUSH(envpp);
+#ifdef SCM_PROFILE
+ eval_clo_cases[IMP(x)?3:4][ARGC(proc)]++;
+#endif
+ switch ARGC(proc) {
+ case 3:
+ scm_env_cons2(arg2, arg3, x);
+ scm_env_cons_tmp(t.arg1);
+ goto clo_checked;
+ case 2:
+ scm_env_cons2(t.arg1, arg2, cons(arg3, x));
+ goto clo_checked;
+ case 1:
+ scm_env_cons(t.arg1, cons2(arg2, arg3, x));
+ goto clo_checked;
+ case 0:
+ scm_env_tmp = cons2(t.arg1, arg2, cons(arg3, x));
+ goto clo_checked;
+ }
+ case tc7_specfun:
+ switch TYP16(proc) {
+ case tc16_apply:
+ proc = t.arg1;
+ t.arg1 = arg2;
+ if IMP(x) {
+ x = arg3;
+ goto apply3;
+ }
+ arg2 = arg3;
+ if IMP(CDR(x)) {
+ x = CAR(x);
+ goto apply4;
+ }
+ arg3 = CAR(x);
+ x = nconc2copy(CDR(x));
+ goto evap3;
#ifdef CCLO
- case tc7_cclo: goto cclon;
+ case tc16_cclo:
+ x = cons(arg3, x);
+ goto cclon;
#endif
- case tcs_closures:
- env = EXTEND_ENV(CAR(CODE(proc)),
- cons2(t.arg1, arg2, eval_args(x, env)),
- ENV(proc));
- x = CODE(proc);
- goto cdrtcdrxbegin;
- 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;
+ }
+ 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;
+ }
}
}
}
@@ -1305,9 +1877,7 @@ SCM procedurep(obj)
case tcs_closures:
case tc7_contin:
case tcs_subrs:
-#ifdef CCLO
- case tc7_cclo:
-#endif
+ case tc7_specfun:
return BOOL_T;
}
return BOOL_F;
@@ -1331,19 +1901,18 @@ SCM l_proc_doc(proc)
return BOOL_F;
/*
case tcs_subrs:
-#ifdef CCLO
- case tc7_cclo:
-#endif
+ case tc7_specfun:
*/
}
}
/* This code is for apply. it is destructive on multiple args.
This will only screw you if you do (apply apply '( ... )) */
-SCM nconc2last(lst)
+/* Copy last (list) argument, so SET! in a closure can't mutate it. */
+SCM nconc2copy(lst)
SCM lst;
{
- SCM *lloc = &lst;
+ SCM last, *lloc = &lst;
#ifdef CAUTIOUS
ASSERT(ilength(lst) >= 1, lst, WNA, s_apply);
#endif
@@ -1351,14 +1920,30 @@ SCM nconc2last(lst)
#ifdef CAUTIOUS
ASSERT(ilength(CAR(*lloc)) >= 0, lst, ARGn, s_apply);
#endif
- *lloc = CAR(*lloc);
+ last = CAR(*lloc);
+ *lloc = EOL;
+ for(; NIMP(last); last=CDR(last)) {
+ *lloc = cons(CAR(last), EOL);
+ lloc = &CDR(*lloc);
+ }
return lst;
}
-
-
+/* Shallow copy */
+SCM copy_list(lst)
+ SCM lst;
+{
+ SCM res, *lloc = &res;
+ res = EOL;
+ for(; NIMP(lst); lst = CDR(lst)) {
+ *lloc = cons(CAR(lst), EOL);
+ lloc = &CDR(*lloc);
+ }
+ return res;
+}
SCM apply(proc, arg1, args)
SCM proc, arg1, args;
{
+ apply_tail:
ASRTGO(NIMP(proc), badproc);
if NULLP(args)
if NULLP(arg1) arg1 = UNDEFINED;
@@ -1368,15 +1953,17 @@ SCM apply(proc, arg1, args)
}
else {
/* ASRTGO(NIMP(args) && CONSP(args), wrongnumargs); */
- args = nconc2last(args);
+ args = nconc2copy(args);
}
-#ifdef CCLO
- tail:
-#endif
+ cc_tail:
+ ALLOW_INTS_EGC;
switch TYP7(proc) {
case tc7_subr_2o:
- args = NULLP(args)?UNDEFINED:CAR(args);
- return SUBRF(proc)(arg1, args);
+ if NULLP(args) {
+ args = UNDEFINED;
+ return SUBRF(proc)(arg1, args);
+ }
+ /* Fall through */
case tc7_subr_2:
ASRTGO(NIMP(args) && NULLP(CDR(args)), wrongnumargs);
args = CAR(args);
@@ -1416,6 +2003,8 @@ SCM apply(proc, arg1, args)
return arg1;
}
case tc7_subr_3:
+ ASRTGO(NIMP(args) && NIMP(CDR(args)) && NULLP(CDR(CDR(args))),
+ wrongnumargs);
return SUBRF(proc)(arg1, CAR(args), CAR(CDR(args)));
case tc7_lsubr:
return SUBRF(proc)(UNBNDP(arg1) ? EOL : cons(arg1, args));
@@ -1442,22 +2031,54 @@ SCM apply(proc, arg1, args)
case tcs_closures:
arg1 = (UNBNDP(arg1) ? EOL : cons(arg1, args));
#ifndef RECKLESS
- if (badargsp(CAR(CODE(proc)), arg1)) goto wrongnumargs;
+ if (badargsp(proc, arg1)) goto wrongnumargs;
#endif
- args = EXTEND_ENV(CAR(CODE(proc)), arg1, ENV(proc));
+ DEFER_INTS_EGC;
+ ENV_PUSH;
+ TRACE(proc);
+ scm_env_tmp = arg1;
+ scm_env = ENV(proc);
+ EXTEND_ENV(CAR(CODE(proc)));
proc = CODE(proc);
- while NNULLP(proc = CDR(proc)) arg1 = EVALCAR(proc, args);
+ arg1 = ceval_1(cons(IM_BEGIN, CDR(proc)));
+ /* while NNULLP(proc = CDR(proc)) arg1 = EVALCAR(proc); */
+ ENV_POP;
return arg1;
case tc7_contin:
ASRTGO(NULLP(args), wrongnumargs);
scm_dynthrow(CONT(proc), arg1);
+ case tc7_specfun:
+ switch TYP16(proc) {
+ case tc16_apply:
+ ASRTGO(!UNBNDP(arg1), wrongnumargs);
+ proc = arg1;
+ arg1 = args;
+ args = EOL;
+ goto apply_tail;
+ case tc16_call_cc:
+ ASRTGO(NULLP(args), wrongnumargs);
+ proc = arg1;
+ ASRTGO(NIMP(proc), badproc);
+ DEFER_INTS_EGC;
+ arg1 = scm_make_cont();
+ EGC_ROOT(arg1);
+ if ((args = setjump(CONT(arg1)->jmpbuf))) {
+#ifdef SHORT_INT
+ args = (SCM)thrown_value;
+#endif
+ return args;
+ }
+ args = EOL;
+ goto cc_tail;
#ifdef CCLO
- case tc7_cclo:
- args = (UNBNDP(arg1) ? EOL : cons(arg1, args));
- arg1 = proc;
- proc = CCLO_SUBR(proc);
- goto tail;
+ case tc16_cclo:
+ args = (UNBNDP(arg1) ? EOL : cons(arg1, args));
+ arg1 = proc;
+ proc = CCLO_SUBR(proc);
+ goto cc_tail;
#endif
+ }
+ goto badproc;
wrongnumargs:
wta(proc, (char *)WNA, s_apply);
default:
@@ -1472,7 +2093,8 @@ SCM map(proc, arg1, args)
{
long i;
SCM res = EOL, *pres = &res;
- SCM *ve = &args; /* Keep args from being optimized away. */
+ SCM *ve;
+ scm_protect_temp(&args); /* Keep args from being optimized away. */
if NULLP(arg1) return res;
ASSERT(NIMP(arg1), arg1, ARG2, s_map);
if NULLP(args) {
@@ -1504,8 +2126,9 @@ SCM map(proc, arg1, args)
SCM for_each(proc, arg1, args)
SCM proc, arg1, args;
{
- SCM *ve = &args; /* Keep args from being optimized away. */
+ SCM *ve;
long i;
+ scm_protect_temp(&args); /* Keep args from being optimized away. */
if NULLP(arg1) return UNSPECIFIED;
ASSERT(NIMP(arg1), arg1, ARG2, s_for_each);
if NULLP(args) {
@@ -1529,13 +2152,24 @@ SCM for_each(proc, arg1, args)
}
}
-SCM closure(code, env)
- SCM code, env;
+/* The number of required arguments up to 3 is encoded in the cdr of the
+ closure. This information is used to make sure that rest args are not
+ allocated in the environment cache. */
+SCM closure(code, argc)
+ SCM code;
+ int argc;
{
register SCM z;
+ if (argc > 3) argc = 3;
NEWCELL(z);
SETCODE(z, code);
- ENV(z) = env;
+ DEFER_INTS_EGC;
+ if (IMP(scm_env))
+ CDR(z) = argc<<1;
+ else {
+ CDR(z) = scm_env | (argc<<1);
+ EGC_ROOT(z);
+ }
return z;
}
@@ -1600,6 +2234,17 @@ static int prinmacro(exp, port, writing)
lputc('>', port);
return !0;
}
+static int prinenv(exp, port, writing)
+ SCM exp;
+ SCM port;
+ int writing;
+{
+ lputs("#<environment ", port);
+ intprint((long)exp, -16, port);
+ /* iprin1(CDR(exp), port, writing); */
+ lputc('>', port);
+ return !0;
+}
#ifdef MACRO
static int prinid(exp, port, writing)
SCM exp;
@@ -1611,7 +2256,7 @@ static int prinid(exp, port, writing)
lputs("#<identifier ", port);
iprin1(s, port, writing);
lputc(':', port);
- intprint((long)exp, 16, port);
+ intprint((long)exp, -16, port);
lputc('>', port);
return !0;
}
@@ -1664,7 +2309,7 @@ SCM definedp(x, env)
{
SCM proc = CAR(x = CDR(x));
#ifdef MACRO
- proc = ident2sym(proc);
+ proc = id2sym(proc);
#endif
return (ISYMP(proc)
|| (NIMP(proc) && IDENTP(proc)
@@ -1684,7 +2329,8 @@ static char s_ident_eqp[] = "identifier-equal?";
SCM ident_eqp(id1, id2, env)
SCM id1, id2, env;
{
- SCM s1 = id1, s2 = id2;
+ SCM s1 = id1, s2 = id2, ret;
+
# ifndef RECKLESS
if IMP(id1)
badarg1: wta(id1, (char *)ARG1, s_ident_eqp);
@@ -1697,8 +2343,21 @@ SCM ident_eqp(id1, id2, env)
ASRTGO(SYMBOLP(s1), badarg1);
ASRTGO(SYMBOLP(s2), badarg2);
if (s1 != s2) return BOOL_F;
- if (id_denote(id1, env)==id_denote(id2, env)) return BOOL_T;
- return BOOL_F;
+ DEFER_INTS_EGC;
+ ENV_PUSH;
+ scm_env = (NIMP(env) && tc16_env==CAR(env)) ? CDR(env) : env;
+ ret = (id_denote(id1)==id_denote(id2)) ? BOOL_T : BOOL_F;
+ ENV_POP;
+ return ret;
+}
+
+static char s_ident2sym[] = "identifier->symbol";
+SCM ident2sym(id)
+ SCM id;
+{
+ id = id2sym(id);
+ ASSERT(NIMP(id) && SYMBOLP(id), id, ARG1, s_ident2sym);
+ return id;
}
static char s_renamed_ident[] = "renamed-identifier";
@@ -1707,6 +2366,11 @@ SCM renamed_ident(id, env)
{
SCM z;
ASSERT(NIMP(id) && IDENTP(id), id, ARG1, s_renamed_ident);
+ if NIMP(env) {
+ ASSERT(tc16_env==CAR(env), env, ARG2, s_renamed_ident);
+ DEFER_INTS_EGC;
+ env = CDR(env);
+ }
NEWCELL(z);
if IMP(env) {
CAR(z) = tc16_ident;
@@ -1736,15 +2400,18 @@ SCM m_syn_quote(xorig, env)
SCM m_atlet_syntax(xorig, env)
SCM xorig, env;
{
- if (IMP(env) || CONSP(CAR(CAR(env))))
- return m_let(xorig, env);
- else {
- SCM mark = renamed_ident(i_mark, BOOL_F);
- return m_letstar(cons2(i_let,
- cons(cons2(mark, BOOL_F, EOL), EOL),
- acons(TOPRENAME(i_let), CDR(xorig), EOL)),
- env);
- }
+ SCM mark;
+ DEFER_INTS_EGC;
+ if (tc16_env==CAR(env))
+ env = CDR(env);
+ if NULLP(env) return m_let(xorig, env);
+ mark = CAR(CAR(env));
+ if (NIMP(mark) && CONSP(mark)) return m_let(xorig, env);
+ mark = renamed_ident(i_mark, BOOL_F);
+ return m_letstar(cons2(i_let,
+ cons(cons2(mark, BOOL_F, EOL), EOL),
+ acons(TOPRENAME(i_let), CDR(xorig), EOL)),
+ env);
}
static char s_the_macro[] = "the-macro";
@@ -1754,14 +2421,46 @@ SCM m_the_macro(xorig, env)
SCM x = CDR(xorig);
ASSYNT(1==ilength(x), xorig, s_expression, s_the_macro);
if (NIMP(CAR(x)) && IDENTP(CAR(x)))
- x = *lookupcar(x, env);
+ x = *lookupcar(x, LOOKUP_UNDEFP);
else
- x = evalcar(x, env);
+ x = evalcar(x);
ASSYNT(NIMP(x) && MACROP(x), xorig, ARG1, s_the_macro);
return cons2(IM_QUOTE, x, EOL);
}
#endif
+static char s_env2tree[] = "environment->tree";
+SCM env2tree(env)
+ SCM env;
+{
+ SCM ans, a, *lloc;
+ if NULLP(env) return env;
+ ASSERT(NIMP(env) && tc16_env==CAR(env), env, ARG1, s_env2tree);
+ DEFER_INTS_EGC;
+ if IMP(CDR(env)) return env;
+ ENV_PUSH;
+ scm_env = CDR(env);
+ ans = a = cons(UNSPECIFIED, UNSPECIFIED);
+ while (!0) {
+ scm_env_tmp = CAR(scm_env);
+ lloc = &CAR(a);
+ while (NIMP(scm_env_tmp) && CONSP(scm_env_tmp)) {
+ *lloc = cons(CAR(scm_env_tmp), CDR(scm_env_tmp));
+ lloc = &CDR(*lloc);
+ DEFER_INTS_EGC;
+ scm_env_tmp = CDR(scm_env_tmp);
+ }
+ scm_env = CDR(scm_env);
+ if IMP(scm_env) {
+ CDR(a) = scm_env;
+ break;
+ }
+ a = (CDR(a) = cons(UNSPECIFIED, UNSPECIFIED));
+ }
+ ENV_POP;
+ ALLOW_INTS_EGC;
+ return ans;
+}
static iproc subr1s[] = {
{"@copy-tree", copytree},
@@ -1771,9 +2470,11 @@ static iproc subr1s[] = {
{"procedure->syntax", makacro},
{"procedure->macro", makmacro},
{"procedure->memoizing-macro", makmmacro},
- {"apply:nconc-to-last", nconc2last},
+ {"apply:nconc-to-last", nconc2copy},
+ {s_env2tree, env2tree},
#ifdef MACRO
{s_identp, identp},
+ {s_ident2sym, ident2sym},
#endif
{0, 0}};
@@ -1785,6 +2486,7 @@ static iproc lsubr2s[] = {
static smobfuns promsmob = {markcdr, free0, prinprom};
static smobfuns macrosmob = {markcdr, free0, prinmacro};
+static smobfuns envsmob = {markcdr, free0, prinenv};
#ifdef MACRO
static smobfuns idsmob = {markcdr, free0, prinid};
#endif
@@ -1805,14 +2507,31 @@ SCM make_synt(name, macroizer, fcn)
CDR(symcell) = macroizer(z);
return CAR(symcell);
}
-
+SCM make_specfun(name, typ)
+ char *name;
+ int typ;
+{
+ SCM symcell = sysintern(name, UNDEFINED);
+ register SCM z;
+ NEWCELL(z);
+ CAR(z) = (long)typ;
+ CDR(z) = CAR(symcell);
+ CDR(symcell) = z;
+ return z;
+}
void init_eval()
{
tc16_promise = newsmob(&promsmob);
tc16_macro = newsmob(&macrosmob);
+ tc16_env = newsmob(&envsmob);
init_iprocs(subr1s, tc7_subr_1);
init_iprocs(lsubr2s, tc7_lsubr_2);
- i_apply = make_subr(s_apply, tc7_lsubr_2, apply);
+#ifdef SCM_PROFILE
+ make_subr("scm:profile", tc7_subr_1o, scm_profile);
+#endif
+ make_specfun(s_apply, tc16_apply);
+ make_specfun(s_call_cc, tc16_call_cc);
+
i_dot = CAR(sysintern(".", UNDEFINED));
i_arrow = CAR(sysintern("=>", UNDEFINED));
i_else = CAR(sysintern("else", UNDEFINED));
@@ -1821,7 +2540,7 @@ void init_eval()
/* acros */
i_quasiquote = make_synt(s_quasiquote, makmmacro, m_quasiquote);
- make_synt(s_define, makmmacro, m_define);
+ i_define = make_synt(s_define, makmmacro, m_define);
make_synt(s_delay, makmmacro, m_delay);
make_synt("defined?", makacro, definedp);
/* end of acros */
@@ -1840,7 +2559,7 @@ void init_eval()
i_quote = make_synt(s_quote, makmmacro, m_quote);
make_synt(s_set, makmmacro, m_set);
make_synt(s_atapply, makmmacro, m_apply);
- make_synt(s_atcall_cc, makmmacro, m_cont);
+ /* make_synt(s_atcall_cc, makmmacro, m_cont); */
#ifdef MACRO
tc16_ident = newsmob(&idsmob);