From 1edcb9b62a1a520eddae8403c19d841c9b18737f Mon Sep 17 00:00:00 2001 From: Bryan Newbold Date: Mon, 20 Feb 2017 00:05:24 -0800 Subject: Import Upstream version 5b3 --- eval.c | 574 +++++++++++++++++++++++++++++++++++++++++++++++++++++------------ 1 file changed, 468 insertions(+), 106 deletions(-) (limited to 'eval.c') 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 */ 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("#', 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 } -- cgit v1.2.3