summaryrefslogtreecommitdiffstats
path: root/eval.c
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:24 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:24 -0800
commit1edcb9b62a1a520eddae8403c19d841c9b18737f (patch)
treebc0a43d9b3905726a76ed6f0528b54275f23d082 /eval.c
parent5ca6e8e6a4e5c022a6fb5d28f30219c22c99eda8 (diff)
downloadscm-1edcb9b62a1a520eddae8403c19d841c9b18737f.tar.gz
scm-1edcb9b62a1a520eddae8403c19d841c9b18737f.zip
Import Upstream version 5b3upstream/5b3
Diffstat (limited to 'eval.c')
-rw-r--r--eval.c574
1 files changed, 468 insertions, 106 deletions
diff --git a/eval.c b/eval.c
index 2cf04fe..8620edc 100644
--- a/eval.c
+++ b/eval.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc.
+/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1997 Free Software Foundation, Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
@@ -47,17 +47,36 @@
#define I_SYM(x) (CAR((x)-1L))
#define I_VAL(x) (CDR((x)-1L))
-#define EVALCELLCAR(x, env) SYMBOLP(CAR(x))?*lookupcar(x, env):ceval(CAR(x), env)
-#ifdef MEMOIZE_LOCALS
-# define EVALIMP(x, env) (ILOCP(x)?*ilookup((x), env):x)
+#ifdef MACRO
+# define ATOMP(x) (5==(5 & (int)CAR(x)))
+# define EVALCELLCAR(x,env) (ATOMP(CAR(x))?evalatomcar(x,env):ceval(CAR(x),env))
#else
-# define EVALIMP(x, env) x
+# define EVALCELLCAR(x, env) SYMBOLP(CAR(x))?*lookupcar(x, env):ceval(CAR(x), env)
#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
-#ifdef MEMOIZE_LOCALS
+long tc16_macro; /* Type code for macros */
+#define MACROP(x) (tc16_macro==TYP16(x))
+
+#ifdef MACRO
+long tc16_ident; /* synthetic macro identifier */
+SCM i_mark;
+static char s_escaped[] = "escaped synthetic identifier";
+# define M_IDENTP(x) (tc16_ident==TYP16(x))
+# define M_IDENT_LEXP(x) ((tc16_ident | (1L<<16))==CAR(x))
+# define IDENTP(x) (SYMBOLP(x) || M_IDENTP(x))
+# define IDENT_LEXP (1L<<16)
+# define IDENT_PARENT(x) (M_IDENT_LEXP(x) ? CAR(CDR(x)) : CDR(x))
+# define IDENT_MARK(x) (M_IDENT_LEXP(x) ? CDR(CDR(x)) : BOOL_F)
+# define ENV_MARK BOOL_T
+#else
+# define IDENTP SYMBOLP
+#endif
+
SCM *ilookup(iloc, env)
SCM iloc, env;
{
@@ -69,56 +88,89 @@ SCM *ilookup(iloc, env)
if ICDRP(iloc) return &CDR(er);
return &CAR(CDR(er));
}
-#endif
+
+SCM *farlookup(farloc, env)
+ SCM farloc, env;
+{
+ register int ir;
+ register SCM er = env;
+ SCM x = CDR(farloc);
+ 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);
+ if (IM_FARLOC_CDR==CAR(farloc)) return &CDR(er);
+ return &CAR(CDR(er));
+}
+
SCM *lookupcar(vloc, genv)
SCM vloc, genv;
{
SCM env = genv;
register SCM *al, fl, var = CAR(vloc);
-#ifdef MEMOIZE_LOCALS
- register SCM iloc = ILOC00;
+ register unsigned int idist, iframe = 0;
+#ifdef MACRO
+ SCM mark = IDENT_MARK(var);
#endif
- for(;NIMP(env);env = CDR(env)) {
+ for(; NIMP(env); env = CDR(env)) {
+ idist = 0;
al = &CAR(env);
for(fl = CAR(*al);NIMP(fl);fl = CDR(fl)) {
+#ifdef MACRO
+ if (fl==mark) {
+ var = IDENT_PARENT(var);
+ mark = IDENT_MARK(var);
+ }
+#endif
if NCONSP(fl)
if (fl==var) {
-#ifdef MEMOIZE_LOCALS
- CAR(vloc) = iloc + ICDR;
+#ifndef TEST_FARLOC
+ if (iframe < 4096 && idist < (1L<<(LONG_BIT-20)))
+ CAR(vloc) = MAKILOC(iframe, idist) + ICDR;
+ else
#endif
+ CAR(vloc) = cons2(IM_FARLOC_CDR, MAKINUM(iframe), MAKINUM(idist));
return &CDR(*al);
}
else break;
al = &CDR(*al);
if (CAR(fl)==var) {
-#ifdef MEMOIZE_LOCALS
-# ifndef RECKLESS /* letrec inits to UNDEFINED */
+#ifndef RECKLESS /* letrec inits to UNDEFINED */
if UNBNDP(CAR(*al)) {env = EOL; goto errout;}
-# endif
- CAR(vloc) = iloc;
#endif
+#ifndef TEST_FARLOC
+ if (iframe < 4096 && idist < (1L<<(LONG_BIT-20)))
+ CAR(vloc) = MAKILOC(iframe, idist);
+ else
+#endif
+ CAR(vloc) = cons2(IM_FARLOC_CAR, MAKINUM(iframe), MAKINUM(idist));
return &CAR(*al);
}
-#ifdef MEMOIZE_LOCALS
- iloc += IDINC;
-#endif
+ idist++;
}
-#ifdef MEMOIZE_LOCALS
- iloc = (~IDSTMSK) & (iloc + IFRINC);
-#endif
+ iframe++;
+ }
+#ifdef MACRO
+ while M_IDENTP(var) {
+ ASRTGO(IMP(IDENT_MARK(var)), errout);
+ var = IDENT_PARENT(var);
}
+#endif
var = sym2vcell(var);
#ifndef RECKLESS
if (NNULLP(env) || UNBNDP(CDR(var))) {
var = CAR(var);
errout:
everr(vloc, genv, var,
- NULLP(env)?"unbound variable: ":"damaged environment", "");
+# ifdef MACRO
+ M_IDENTP(var) ? s_escaped :
+# endif
+ (NULLP(env) ? "unbound variable: " : "damaged environment"), "");
}
#endif
CAR(vloc) = var + 1;
return &CDR(var);
}
+
static SCM unmemocar(form, env)
SCM form, env;
{
@@ -126,17 +178,48 @@ static SCM unmemocar(form, env)
if IMP(form) return form;
if (1==TYP3(form))
CAR(form) = I_SYM(CAR(form));
-#ifdef MEMOIZE_LOCALS
else if ILOCP(CAR(form)) {
for(ir = IFRAME(CAR(form)); ir != 0; --ir) env = CDR(env);
env = CAR(CAR(env));
for(ir = IDIST(CAR(form));ir != 0;--ir) env = CDR(env);
CAR(form) = ICDRP(CAR(form)) ? env : CAR(env);
}
-#endif
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;
+{
+ SCM r;
+ switch TYP7(CAR(x)) {
+ default:
+ everr(x, 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;
+ case tc7_vector:
+ 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;
{
@@ -163,10 +246,65 @@ static char s_formals[] = "bad formals";
SCM i_dot, i_quote, i_quasiquote, i_lambda,
i_let, i_arrow, i_else, i_unquote, i_uq_splicing, i_apply;
-static char s_quasiquote[] = "quasiquote";
-static char s_delay[] = "delay";
#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 TOPRENAME(v) (renamed_ident(v, BOOL_F))
+
+static SCM ident2sym(id)
+ SCM id;
+{
+ if NIMP(id)
+ while M_IDENTP(id)
+ id = IDENT_PARENT(id);
+ return id;
+}
+
+static SCM *id_denote(var, env)
+ SCM var, env;
+{
+ register SCM *al, fl;
+ SCM mark = IDENT_MARK(var);
+ for(;NIMP(env); env = CDR(env)) {
+ al = &CAR(env);
+ for(fl = CAR(*al);NIMP(fl);fl = CDR(fl)) {
+ if (fl==mark) {
+ var = IDENT_PARENT(var);
+ mark = IDENT_MARK(var);
+ }
+ if NCONSP(fl)
+ if (fl==var) return &CDR(*al);
+ else break;
+ al = &CDR(*al);
+ if (CAR(fl)==var) return &CAR(*al);
+ }
+ }
+ return (SCM *)0;
+}
+
+static void unpaint(p)
+ SCM *p;
+{
+ SCM x;
+ while NIMP((x = *p)) {
+ if CONSP(x) {
+ if NIMP(CAR(x)) unpaint(&CAR(x));
+ p = &CDR(*p);
+ }
+ else {
+ while M_IDENTP(x) *p = x = IDENT_PARENT(x);
+ return;
+ }
+ }
+}
+#else /* def MACRO */
+# define TOPDENOTE_EQ(sym, x, env) ((sym)==(x))
+# define TOPLEVELP(x,env) (!0)
+# define TOPRENAME(v) (v)
+#endif
static void bodycheck(xorig, bodyloc, what)
SCM xorig, *bodyloc;
@@ -179,6 +317,11 @@ SCM m_quote(xorig, env)
SCM xorig, env;
{
ASSYNT(ilength(CDR(xorig))==1, xorig, s_expression, s_quote);
+#ifdef MACRO
+ DEFER_INTS;
+ unpaint(&CAR(CDR(xorig)));
+ ALLOW_INTS;
+#endif
return cons(IM_QUOTE, CDR(xorig));
}
@@ -202,7 +345,7 @@ SCM m_set(xorig, env)
{
SCM x = CDR(xorig);
ASSYNT(2==ilength(x), xorig, s_expression, s_set);
- ASSYNT(NIMP(CAR(x)) && SYMBOLP(CAR(x)),
+ ASSYNT(NIMP(CAR(x)) && IDENTP(CAR(x)),
xorig, s_variable, s_set);
return cons(IM_SET, x);
}
@@ -233,8 +376,16 @@ SCM m_case(xorig, env)
while(NIMP(x = CDR(x))) {
proc = CAR(x);
ASSYNT(ilength(proc) >= 2, xorig, s_clauses, s_case);
- ASSYNT(ilength(CAR(proc)) >= 0 || i_else==CAR(proc),
- xorig, s_clauses, s_case);
+ if TOPDENOTE_EQ(i_else, CAR(proc), env)
+ CAR(proc) = IM_ELSE;
+ else {
+ ASSYNT(ilength(CAR(proc)) >= 0, xorig, s_clauses, s_case);
+#ifdef MACRO
+ DEFER_INTS;
+ unpaint(&CAR(proc));
+ ALLOW_INTS;
+#endif
+ }
}
return cons(IM_CASE, CDR(xorig));
}
@@ -249,13 +400,15 @@ SCM m_cond(xorig, env)
arg1 = CAR(x);
len = ilength(arg1);
ASSYNT(len >= 1, xorig, s_clauses, s_cond);
- if (i_else==CAR(arg1)) {
+ if TOPDENOTE_EQ(i_else, CAR(arg1), env) {
ASSYNT(NULLP(CDR(x)) && len >= 2, xorig, "bad ELSE clause", s_cond);
CAR(arg1) = BOOL_T;
}
- if (len >= 2 && i_arrow==CAR(CDR(arg1)))
- ASSYNT(3==len && NIMP(CAR(CDR(CDR(arg1)))),
- xorig, "bad recipient", s_cond);
+ 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;
+ }
x = CDR(x);
}
return cons(IM_COND, CDR(xorig));
@@ -269,13 +422,13 @@ SCM m_lambda(xorig, env)
proc = CAR(x);
if NULLP(proc) goto memlambda;
if IMP(proc) goto badforms;
- if SYMBOLP(proc) goto memlambda;
+ if IDENTP(proc) goto memlambda;
if NCONSP(proc) goto badforms;
while NIMP(proc) {
if NCONSP(proc)
- if (!SYMBOLP(proc)) goto badforms;
+ if (!IDENTP(proc)) goto badforms;
else goto memlambda;
- if (!(NIMP(CAR(proc)) && SYMBOLP(CAR(proc)))) goto badforms;
+ if (!(NIMP(CAR(proc)) && IDENTP(CAR(proc)))) goto badforms;
proc = CDR(proc);
}
if NNULLP(proc)
@@ -295,7 +448,7 @@ SCM m_letstar(xorig, env)
while NIMP(proc) {
arg1 = CAR(proc);
ASSYNT(2==ilength(arg1), xorig, s_bindings, s_letstar);
- ASSYNT(NIMP(CAR(arg1)) && SYMBOLP(CAR(arg1)), xorig, s_variable, s_letstar);
+ ASSYNT(NIMP(CAR(arg1)) && IDENTP(CAR(arg1)), xorig, s_variable, s_letstar);
*varloc = cons2(CAR(arg1), CAR(CDR(arg1)), EOL);
varloc = &CDR(CDR(*varloc));
proc = CDR(proc);
@@ -332,7 +485,7 @@ SCM m_do(xorig, env)
arg1 = CAR(proc);
len = ilength(arg1);
ASSYNT(2==len || 3==len, xorig, s_bindings, s_do);
- ASSYNT(NIMP(CAR(arg1)) && SYMBOLP(CAR(arg1)), xorig, s_variable, s_do);
+ ASSYNT(NIMP(CAR(arg1)) && IDENTP(CAR(arg1)), xorig, s_variable, s_do);
/* vars reversed here, inits and steps reversed at evaluation */
vars = cons(CAR(arg1), vars); /* variable */
arg1 = CDR(arg1);
@@ -358,59 +511,109 @@ static SCM evalcar(x, env)
return EVALCAR(x, env);
}
-static SCM iqq(form, env, depth)
+/* Here are acros which return values rather than code. */
+
+static SCM iqq(form, env)
SCM form, env;
- int depth;
{
SCM tmp;
- int edepth = depth;
if IMP(form) return form;
if VECTORP(form) {
long i = LENGTH(form);
SCM *data = VELTS(form);
tmp = EOL;
for(;--i >= 0;) tmp = cons(data[i], tmp);
- return vector(iqq(tmp, env, depth));
+ return vector(iqq(tmp, env));
}
if NCONSP(form) return form;
tmp = CAR(form);
- if (i_quasiquote==tmp) {
- depth++;
- goto label;
+ if (IM_UNQUOTE==tmp)
+ return evalcar(CDR(form), env);
+ 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));
+}
+
+static SCM m_iqq(form, depth, env)
+ SCM form, env;
+ int depth;
+{
+ SCM tmp;
+ int edepth = depth;
+ if IMP(form) return form;
+ if VECTORP(form) {
+ 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);
+ tmp = CDR(tmp);
+ }
+ return form;
}
- if (i_unquote==tmp) {
- --depth;
- label:
- form = CDR(form);
- ASSERT(NIMP(form) && ECONSP(form) && NULLP(CDR(form)),
- form, ARG1, s_quasiquote);
- if (0==depth) return evalcar(form, env);
- return cons2(tmp, iqq(CAR(form), env, depth), EOL);
+ if NCONSP(form) {
+#ifdef MACRO
+ while M_IDENTP(form) form = IDENT_PARENT(form);
+#endif
+ return form;
}
- if (NIMP(tmp) && (i_uq_splicing==CAR(tmp))) {
- tmp = CDR(tmp);
- if (0==--edepth)
- return append(cons2(evalcar(tmp, env), iqq(CDR(form), env, depth), EOL));
+ tmp = CAR(form);
+ if NIMP(tmp) {
+ if IDENTP(tmp) {
+#ifdef MACRO
+ while M_IDENTP(tmp) tmp = IDENT_PARENT(tmp);
+#endif
+ if (i_quasiquote==tmp && TOPLEVELP(CAR(form), env)) {
+ depth++;
+ if (0==depth) CAR(form) = IM_QUASIQUOTE;
+ goto label;
+ }
+ if (i_unquote==tmp && TOPLEVELP(CAR(form), env)) {
+ --depth;
+ if (0==depth) CAR(form) = IM_UNQUOTE;
+ label:
+ tmp = CDR(form);
+ ASSERT(NIMP(tmp) && ECONSP(tmp) && NULLP(CDR(tmp)),
+ tmp, ARG1, s_quasiquote);
+ if (0!=depth) CAR(tmp) = m_iqq(CAR(tmp), depth, env);
+ return form;
+ }
+ }
+ else {
+ if TOPDENOTE_EQ(i_uq_splicing, CAR(tmp), env) {
+ if (0==--edepth) {
+ CAR(tmp) = IM_UQ_SPLICING;
+ CDR(form) = m_iqq(CDR(form), depth, env);
+ return form;
+ }
+ }
+ CAR(form) = m_iqq(tmp, edepth, env);
+ }
}
- return cons(iqq(CAR(form), env, edepth), iqq(CDR(form), env, depth));
+ CAR(form) = tmp;
+ CDR(form) = m_iqq(CDR(form), depth, env);
+ return form;
}
-
-/* Here are acros which return values rather than code. */
-
SCM m_quasiquote(xorig, env)
SCM xorig, env;
{
SCM x = CDR(xorig);
ASSYNT(ilength(x)==1, xorig, s_expression, s_quasiquote);
- return iqq(CAR(x), env, 1);
+ DEFER_INTS;
+ x = m_iqq(x, 1, env);
+ ALLOW_INTS;
+ return cons(IM_QUASIQUOTE, x);
}
SCM m_delay(xorig, env)
SCM xorig, env;
{
ASSYNT(ilength(xorig)==2, xorig, s_expression, s_delay);
- xorig = CDR(xorig);
- return makprom(closure(cons2(EOL, CAR(xorig), CDR(xorig)), env));
+ return cons2(IM_DELAY, EOL, CDR(xorig));
}
extern int verbose;
@@ -422,16 +625,24 @@ SCM m_define(x, env)
ASSYNT(ilength(x) >= 2, arg1, s_expression, s_define);
proc = CAR(x); x = CDR(x);
while (NIMP(proc) && CONSP(proc)) { /* nested define syntax */
- x = cons(cons2(i_lambda, CDR(proc), x), EOL);
+ x = cons(cons2(TOPRENAME(i_lambda), CDR(proc), x), EOL);
proc = CAR(proc);
}
- ASSYNT(NIMP(proc) && SYMBOLP(proc), arg1, s_variable, s_define);
+ ASSYNT(NIMP(proc) && IDENTP(proc), arg1, s_variable, s_define);
ASSYNT(1==ilength(x), arg1, s_expression, s_define);
if NULLP(env) {
- x = evalcar(x, env);
+ x = evalcar(x,env);
+#ifdef MACRO
+ while M_IDENTP(proc) {
+ ASSYNT(IMP(IDENT_MARK(proc)), proc, s_escaped, s_define);
+ proc = IDENT_PARENT(proc);
+ }
+#endif
arg1 = sym2vcell(proc);
#ifndef RECKLESS
- if (NIMP(CDR(arg1)) && ((SCM) SNAME(CDR(arg1))==proc)
+ if (NIMP(CDR(arg1)) &&
+ (proc ==
+ ((SCM) SNAME(MACROP(CDR(arg1)) ? CDR(CDR(arg1)) : CDR(arg1))))
&& (CDR(arg1) != x))
warn("redefining built-in ", CHARS(proc));
else
@@ -440,12 +651,12 @@ SCM m_define(x, env)
warn("redefining ", CHARS(proc));
CDR(arg1) = x;
#ifdef SICP
- return cons2(i_quote, CAR(arg1), EOL);
+ return m_quote(cons2(i_quote, CAR(arg1), EOL), EOL);
#else
return UNSPECIFIED;
#endif
}
- return cons2(IM_DEFINE, proc, x);
+ return cons2(IM_DEFINE, cons(proc,CAR(CAR(env))), x);
}
/* end of acros */
@@ -465,7 +676,7 @@ SCM m_letrec(xorig, env)
/* vars list reversed here, inits reversed at evaluation */
arg1 = CAR(proc);
ASRTSYNTAX(2==ilength(arg1), s_bindings);
- ASRTSYNTAX(NIMP(CAR(arg1)) && SYMBOLP(CAR(arg1)), s_variable);
+ ASRTSYNTAX(NIMP(CAR(arg1)) && IDENTP(CAR(arg1)), s_variable);
vars = cons(CAR(arg1), vars);
*initloc = cons(CAR(CDR(arg1)), EOL);
initloc = &CDR(*initloc);
@@ -491,7 +702,7 @@ SCM m_let(xorig, 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)));
- if (!SYMBOLP(proc)) wta(xorig, s_bindings, s_let); /* bad let */
+ if (!IDENTP(proc)) wta(xorig, s_bindings, s_let); /* bad let */
name = proc; /* named let, build equiv letrec */
x = CDR(x);
ASSYNT(ilength(x) >= 2, xorig, s_body, s_let);
@@ -500,7 +711,7 @@ SCM m_let(xorig, env)
while NIMP(proc) { /* vars and inits both in order */
arg1 = CAR(proc);
ASSYNT(2==ilength(arg1), xorig, s_bindings, s_let);
- ASSYNT(NIMP(CAR(arg1)) && SYMBOLP(CAR(arg1)), xorig, s_variable, s_let);
+ ASSYNT(NIMP(CAR(arg1)) && IDENTP(CAR(arg1)), xorig, s_variable, s_let);
*varloc = cons(CAR(arg1), EOL);
varloc = &CDR(*varloc);
*initloc = cons(CAR(CDR(arg1)), EOL);
@@ -509,7 +720,9 @@ SCM m_let(xorig, env)
}
return
m_letrec(cons2(i_let,
- cons(cons2(name, cons2(i_lambda, vars, CDR(x)), EOL), EOL),
+ cons(cons2(name,
+ cons2(TOPRENAME(i_lambda), vars, CDR(x)), EOL),
+ EOL),
acons(name, inits, EOL)), /* body */
env);
}
@@ -548,7 +761,6 @@ int badargsp(formals, args)
char s_map[] = "map", s_for_each[] = "for-each", s_eval[] = "eval";
SCM eqv P((SCM x, SCM y));
-long tc16_macro; /* Type code for macros */
#ifdef CAUTIOUS
static char s_bottom[] = "stacktrace bottommed out";
#endif
@@ -591,7 +803,7 @@ SCM ceval(x, env)
x = CAR(x);
return IMP(x)?EVALIMP(x, env):I_VAL(x);
}
- if SYMBOLP(CAR(x)) {
+ if IDENTP(CAR(x)) {
retval:
return *lookupcar(x, env);
}
@@ -601,19 +813,22 @@ SCM ceval(x, env)
case (127 & IM_CASE):
x = CDR(x);
t.arg1 = EVALCAR(x, env);
+#ifndef INUMS_ONLY
+ arg2 = (SCM)(IMP(t.arg1) || !NUMP(t.arg1));
+#endif
while(NIMP(x = CDR(x))) {
proc = CAR(x);
- if (i_else==CAR(proc)) {
+ if (IM_ELSE==CAR(proc)) {
x = CDR(proc);
goto begin;
}
proc = CAR(proc);
while NIMP(proc) {
- if (CAR(proc)==t.arg1
-#ifdef FLOATS
- || NFALSEP(eqv(CAR(proc), t.arg1))
+ if (
+#ifndef INUMS_ONLY
+ arg2 ? NFALSEP(eqv(CAR(proc), t.arg1)) :
#endif
- ) {
+ (CAR(proc)==t.arg1)) {
x = CDR(CAR(x));
goto begin;
}
@@ -628,7 +843,7 @@ SCM ceval(x, env)
if NFALSEP(t.arg1) {
x = CDR(proc);
if NULLP(x) return t.arg1;
- if (i_arrow != CAR(x)) goto begin;
+ if (IM_ARROW != CAR(x)) goto begin;
proc = CDR(x);
proc = EVALCAR(proc, env);
ASRTGO(NIMP(proc), badfun);
@@ -718,16 +933,26 @@ SCM ceval(x, env)
proc = CAR(x);
switch (7 & (int)proc) {
case 0:
- t.lloc = lookupcar(x, env);
+ 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
+ }
break;
case 1:
t.lloc = &I_VAL(proc);
break;
-#ifdef MEMOIZE_LOCALS
case 4:
t.lloc = ilookup(proc, env);
break;
-#endif
}
x = CDR(x);
*t.lloc = EVALCAR(x, env);
@@ -743,7 +968,7 @@ SCM ceval(x, env)
x = evalcar(x, env);
env = CAR(env);
DEFER_INTS;
- CAR(env) = cons(proc, CAR(env));
+ CAR(env) = proc;
CDR(env) = cons(x, CDR(env));
ALLOW_INTS;
return UNSPECIFIED;
@@ -770,7 +995,7 @@ SCM ceval(x, env)
goto evapply;
case (ISYMNUM(IM_CONT)):
t.arg1 = scm_make_cont();
- if (proc = setjmp(CONT(t.arg1)->jmpbuf))
+ if ((proc = setjump(CONT(t.arg1)->jmpbuf)))
#ifdef SHORT_INT
return (SCM)thrown_value;
#else
@@ -792,6 +1017,13 @@ SCM ceval(x, env)
}
#endif
goto evap1;
+ case (ISYMNUM(IM_DELAY)):
+ return makprom(closure(CDR(x), env));
+ case (ISYMNUM(IM_QUASIQUOTE)):
+ return iqq(CAR(CDR(x)), env);
+ case (ISYMNUM(IM_FARLOC_CAR)):
+ case (ISYMNUM(IM_FARLOC_CDR)):
+ return *farlookup(x, env);
default:
goto badfun;
}
@@ -804,18 +1036,22 @@ SCM ceval(x, env)
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;
-#ifdef MEMOIZE_LOCALS
case (127 & ILOC00):
proc = *ilookup(CAR(x), env);
ASRTGO(NIMP(proc), badfun);
-# ifndef RECKLESS
-# ifdef CAUTIOUS
+#ifndef RECKLESS
+# ifdef CAUTIOUS
goto checkargs;
-# endif
# endif
+#endif
break;
-#endif /* ifdef MEMOIZE_LOCALS */
case tcs_cons_gloc:
proc = I_VAL(CAR(x));
ASRTGO(NIMP(proc), badfun);
@@ -826,14 +1062,14 @@ SCM ceval(x, env)
#endif
break;
case tcs_cons_nimcar:
- if SYMBOLP(CAR(x)) {
+ if IDENTP(CAR(x)) {
proc = *lookupcar(x, env);
if IMP(proc) {unmemocar(x, env); goto badfun;}
- if (tc16_macro==TYP16(proc)) {
+ if MACROP(proc) {
unmemocar(x, env);
t.arg1 = apply(CDR(proc), x, cons(env, listofnull));
switch ((int)(CAR(proc)>>16)) {
- case 2:
+ case 2: /* mmacro */
if (ilength(t.arg1) <= 0)
t.arg1 = cons2(IM_BEGIN, t.arg1, EOL);
DEFER_INTS;
@@ -841,9 +1077,9 @@ SCM ceval(x, env)
CDR(x) = CDR(t.arg1);
ALLOW_INTS;
goto loop;
- case 1:
+ case 1: /* macro */
if NIMP(x = t.arg1) goto loop;
- case 0:
+ case 0: /* acro */
return t.arg1;
}
}
@@ -1142,7 +1378,7 @@ SCM apply(proc, arg1, args)
args = NULLP(args)?UNDEFINED:CAR(args);
return SUBRF(proc)(arg1, args);
case tc7_subr_2:
- ASRTGO(NULLP(CDR(args)), wrongnumargs);
+ ASRTGO(NIMP(args) && NULLP(CDR(args)), wrongnumargs);
args = CAR(args);
return SUBRF(proc)(arg1, args);
case tc7_subr_0:
@@ -1364,12 +1600,27 @@ static int prinmacro(exp, port, writing)
lputc('>', port);
return !0;
}
-
+#ifdef MACRO
+static int prinid(exp, port, writing)
+ SCM exp;
+ SCM port;
+ int writing;
+{
+ SCM s = IDENT_PARENT(exp);
+ while (!IDENTP(s)) s = IDENT_PARENT(s);
+ lputs("#<identifier ", port);
+ iprin1(s, port, writing);
+ lputc(':', port);
+ intprint((long)exp, 16, port);
+ lputc('>', port);
+ return !0;
+}
+#endif
char s_force[] = "force";
SCM force(x)
SCM x;
{
- ASSERT((TYP16(x)==tc16_promise), x, ARG1, s_force);
+ ASSERT(NIMP(x) && (TYP16(x)==tc16_promise), x, ARG1, s_force);
if (!((1L<<16) & CAR(x))) {
SCM ans = apply(CDR(x), EOL, EOL);
if (!((1L<<16) & CAR(x))) {
@@ -1412,14 +1663,108 @@ SCM definedp(x, env)
SCM x, env;
{
SCM proc = CAR(x = CDR(x));
+#ifdef MACRO
+ proc = ident2sym(proc);
+#endif
return (ISYMP(proc)
- || (NIMP(proc) && SYMBOLP(proc)
+ || (NIMP(proc) && IDENTP(proc)
&& !UNBNDP(CDR(sym2vcell(proc)))))?
(SCM)BOOL_T : (SCM)BOOL_F;
}
+#ifdef MACRO
+static char s_identp[] = "identifier?";
+SCM identp(obj)
+ SCM obj;
+{
+ return (NIMP(obj) && IDENTP(obj)) ? BOOL_T : BOOL_F;
+}
+
+static char s_ident_eqp[] = "identifier-equal?";
+SCM ident_eqp(id1, id2, env)
+ SCM id1, id2, env;
+{
+ SCM s1 = id1, s2 = id2;
+# ifndef RECKLESS
+ if IMP(id1)
+ badarg1: wta(id1, (char *)ARG1, s_ident_eqp);
+ if IMP(id1)
+ badarg2: wta(id2, (char *)ARG2, s_ident_eqp);
+# endif
+ if (id1==id2) return BOOL_T;
+ while M_IDENTP(s1) s1 = IDENT_PARENT(s1);
+ while M_IDENTP(s2) s2 = IDENT_PARENT(s2);
+ 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;
+}
+
+static char s_renamed_ident[] = "renamed-identifier";
+SCM renamed_ident(id, env)
+ SCM id, env;
+{
+ SCM z;
+ ASSERT(NIMP(id) && IDENTP(id), id, ARG1, s_renamed_ident);
+ NEWCELL(z);
+ if IMP(env) {
+ CAR(z) = tc16_ident;
+ CDR(z) = id;
+ return z;
+ }
+ else {
+ SCM y;
+ CAR(z) = id;
+ CDR(z) = CAR(CAR(env));
+ NEWCELL(y);
+ CAR(y) = tc16_ident | 1L<<16;
+ CDR(y) = z;
+ return y;
+ }
+}
+
+static char s_syn_quote[] = "syntax-quote";
+SCM m_syn_quote(xorig, env)
+ SCM xorig, env;
+{
+ ASSYNT(ilength(CDR(xorig))==1, xorig, s_expression, s_syn_quote);
+ return cons(IM_QUOTE, CDR(xorig));
+}
+
+/* Ensure that the environment for LET-SYNTAX can be uniquely identified. */
+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);
+ }
+}
+
+static char s_the_macro[] = "the-macro";
+SCM m_the_macro(xorig, env)
+ SCM 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);
+ else
+ x = evalcar(x, env);
+ ASSYNT(NIMP(x) && MACROP(x), xorig, ARG1, s_the_macro);
+ return cons2(IM_QUOTE, x, EOL);
+}
+#endif
+
+
static iproc subr1s[] = {
- {"copy-tree", copytree},
+ {"@copy-tree", copytree},
{s_eval, eval},
{s_force, force},
{s_proc_doc, l_proc_doc},
@@ -1427,6 +1772,9 @@ static iproc subr1s[] = {
{"procedure->macro", makmacro},
{"procedure->memoizing-macro", makmmacro},
{"apply:nconc-to-last", nconc2last},
+#ifdef MACRO
+ {s_identp, identp},
+#endif
{0, 0}};
static iproc lsubr2s[] = {
@@ -1437,6 +1785,9 @@ static iproc lsubr2s[] = {
static smobfuns promsmob = {markcdr, free0, prinprom};
static smobfuns macrosmob = {markcdr, free0, prinmacro};
+#ifdef MACRO
+static smobfuns idsmob = {markcdr, free0, prinid};
+#endif
SCM make_synt(name, macroizer, fcn)
char *name;
@@ -1469,9 +1820,10 @@ void init_eval()
i_uq_splicing = CAR(sysintern("unquote-splicing", UNDEFINED));
/* acros */
- i_quasiquote = make_synt(s_quasiquote, makacro, m_quasiquote);
+ i_quasiquote = make_synt(s_quasiquote, makmmacro, m_quasiquote);
make_synt(s_define, makmmacro, m_define);
- make_synt(s_delay, makacro, m_delay);
+ make_synt(s_delay, makmmacro, m_delay);
+ make_synt("defined?", makacro, definedp);
/* end of acros */
make_synt(s_and, makmmacro, m_and);
@@ -1490,5 +1842,15 @@ void init_eval()
make_synt(s_atapply, makmmacro, m_apply);
make_synt(s_atcall_cc, makmmacro, m_cont);
- make_synt("defined?", makacro, definedp);
+#ifdef MACRO
+ tc16_ident = newsmob(&idsmob);
+ make_subr(s_renamed_ident, tc7_subr_2, renamed_ident);
+ make_subr(s_ident_eqp, tc7_subr_3, ident_eqp);
+ make_synt(s_syn_quote, makmmacro, m_syn_quote);
+ make_synt("@let-syntax", makmmacro, m_atlet_syntax);
+ /* This doesn't do anything special, but might in the future. */
+ make_synt("@letrec-syntax", makmmacro, m_letrec);
+ make_synt(s_the_macro, makmmacro, m_the_macro);
+ i_mark = CAR(sysintern("let-syntax-mark", UNDEFINED));
+#endif
}