diff options
Diffstat (limited to 'eval.c')
| -rw-r--r-- | eval.c | 1356 |
1 files changed, 910 insertions, 446 deletions
@@ -1,18 +1,18 @@ -/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1997 Free Software Foundation, Inc. - * +/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1997, 1998, 1999 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 * the Free Software Foundation; either version 2, or (at your option) * any later version. - * + * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. - * + * * You should have received a copy of the GNU General Public License * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA. * * As a special exception, the Free Software Foundation gives permission * for additional uses of the text contained in its release of GUILE. @@ -36,7 +36,7 @@ * * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. + * If you do not wish that, delete this exception notice. */ /* "eval.c" eval and apply. @@ -69,7 +69,7 @@ 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. + 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 @@ -100,24 +100,30 @@ 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 copy_list P((SCM x, int minlen)); +SCM scm_v2lst P((long argc, SCM *argv)); SCM rename_ident P((SCM id, SCM env)); +SCM *lookupcar P((SCM vloc, int check)); SCM eqv P((SCM x, SCM y)); -void scm_dynthrow P((CONTINUATION *cont, SCM val)); +SCM scm_multi_set P((SCM syms, SCM vals)); +SCM eval_args P((SCM x)); +void scm_dynthrow P((SCM cont, SCM val)); void scm_egc P((void)); -void scm_estk_grow P((sizet inc)); +void scm_estk_grow P((void)); void scm_estk_shrink P((void)); int badargsp P((SCM proc, SCM args)); +static SCM asubr_apply P((SCM proc, SCM arg1, SCM arg2, SCM arg3, 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_expand_body P((SCM xorig)); 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 macroexp1 P((SCM x, SCM defs)); static SCM unmemocar P((SCM x)); static SCM wrapenv P((void)); static SCM *id_denote P((SCM var)); @@ -125,24 +131,31 @@ 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)); +static void ecache_evalx P((SCM x)); +static int ecache_eval_args P((SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM x)); +static int varcheck P((SCM xorig, SCM vars, char *op, char *what)); #ifdef CAREFUL_INTS static void debug_env_warn P((char *fnam, long line, char *what)); +static void debug_env_save P((char *fnam, long line)); #endif /* Flush global variable state to estk. */ -#define ENV_SAVE {scm_estk_ptr[0]=scm_env; scm_estk_ptr[1]=scm_env_tmp;} +#ifdef CAREFUL_INTS +# define ENV_SAVE debug_env_save(__FILE__, __LINE__) +#else +# define ENV_SAVE {scm_estk_ptr[0]=scm_env; scm_estk_ptr[1]=scm_env_tmp;} +#endif /* 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);\ + if (UNDEFINED==scm_estk_ptr[SCM_ESTK_FRLEN]) scm_estk_grow();\ else scm_estk_ptr += SCM_ESTK_FRLEN;} #define ENV_POP {DEFER_INTS_EGC;\ - if (INUM0==scm_estk_ptr[-SCM_ESTK_FRLEN]) scm_estk_shrink();\ + if (UNDEFINED==scm_estk_ptr[-1]) scm_estk_shrink();\ else scm_estk_ptr -= SCM_ESTK_FRLEN; ENV_RESTORE;} #ifdef NO_ENV_CACHE @@ -159,13 +172,20 @@ static void debug_env_warn P((char *fnam, long line, char *what)); # endif #endif +#ifdef CAUTIOUS +SCM scm_trace = UNDEFINED; +#endif #define ENV_MAY_POP(p, guard) if (p>0 && !(guard)) {ENV_POP; p=-1;} #define ENV_MAY_PUSH(p) if (p<=0) {ENV_PUSH; p=1;} #define SIDEVAL_1(x) if NIMP(x) ceval_1(x) #ifdef CAUTIOUS -# define TRACE(x) scm_estk_ptr[2]=(x) +# define TRACE(x) {scm_estk_ptr[2]=(x);} +# define TOP_TRACE(x) {scm_trace=(x);} +# define PUSH_TRACE TRACE(scm_trace) #else # define TRACE(x) /**/ +# define TOP_TRACE(x) /**/ +# define PUSH_TRACE /**/ #endif #define EVALIMP(x) (ILOCP(x)?*ilookup(x):x) @@ -181,7 +201,6 @@ 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 @@ -239,7 +258,7 @@ SCM scm_profile(resetp) /* Inhibit warnings for ARGC, is not changed by egc. */ # undef ARGC # define ARGC(x) ((6L & (((cell *)(SCM2PTR(x)))->cdr))>>1) -#include <signal.h> +# include <signal.h> SCM test_ints(x) SCM x; { @@ -302,6 +321,18 @@ SCM *debug_env_cdr(x, fnam, line) debug_env_warn(fnam, line, "CAR"); return ret; } +static void debug_env_save(fnam, line) + char *fnam; + long line; +{ + if (NIMP(scm_env) && (!scm_cell_p(scm_env))) + debug_env_warn(fnam, line, "ENV_SAVE (env)"); + if (NIMP(scm_env_tmp) && (!scm_cell_p(scm_env_tmp))) + debug_env_warn(fnam, line, "ENV_SAVE (tmp)"); + scm_estk_ptr[0]=scm_env; + scm_estk_ptr[1]=scm_env_tmp; +} + #endif /* CAREFUL_INTS */ SCM *ilookup(iloc) @@ -338,14 +369,17 @@ SCM *farlookup(farloc) 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 +/* check is logical OR of LOOKUP_MEMOIZE, LOOKUP_UNDEFP, and LOOKUP_MACROP, + if check is zero then memoization will not be done. */ +#define LOOKUP_MEMOIZE 1 +#define LOOKUP_UNDEFP 2 +#define LOOKUP_MACROP 4 SCM *lookupcar(vloc, check) SCM vloc; int check; { SCM env; + long icdr = 0L; register SCM *al, fl, var = CAR(vloc); register unsigned int idist, iframe = 0; #ifdef MACRO @@ -353,52 +387,65 @@ SCM *lookupcar(vloc, check) #endif DEFER_INTS_EGC; env = scm_env; + if (NIMP(env) && ENVP(env)) + env = CDR(env); for(; NIMP(env); env = CDR(env)) { idist = 0; al = &CAR(env); - for(fl = CAR(*al);NIMP(fl);fl = CDR(fl)) { + fl = CAR(*al); #ifdef MACRO - if (fl==mark) { - var = IDENT_PARENT(var); - mark = IDENT_MARK(var); - } + if (fl==mark) { + var = IDENT_PARENT(var); + mark = IDENT_MARK(var); + } #endif +/* constant environment section -- not used as yet. + if (BOOL_T==fl) { + fl = assq(var, CDR(fl)); + if FALSEP(fl) break; + var = fl; + goto gloc_out; + } +*/ + for(;NIMP(fl);fl = CDR(fl)) { if NCONSP(fl) if (fl==var) { + icdr = ICDR; #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 + fl = CDR(*al); #endif -#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); + goto local_out; } else break; al = &CDR(*al); if (CAR(fl)==var) { #ifndef RECKLESS /* letrec inits to UNDEFINED */ + fl = CAR(*al); + local_out: if ((check & LOOKUP_UNDEFP) - && UNBNDP(CAR(*al))) {env = EOL; goto errout;} + && UNBNDP(fl)) {env = EOL; goto errout;} # ifdef MACRO if ((check & LOOKUP_MACROP) - && NIMP(CAR(*al)) && MACROP(CAR(*al))) goto badkey; + && NIMP(fl) && MACROP(fl)) goto badkey; # endif + if ((check) && NIMP(scm_env) && ENVP(scm_env)) + everr(vloc, scm_env, var, + "run-time reference", ""); +#else /* ndef RECKLESS */ + local_out: +#endif +#ifdef MEMOIZE_LOCALS + if (check) { +# ifndef TEST_FARLOC + if (iframe < 4096 && idist < (1L<<(LONG_BIT-20))) + CAR(vloc) = MAKILOC(iframe, idist) + icdr; + else +# endif + CAR(vloc) = cons2(icdr ? IM_FARLOC_CDR : IM_FARLOC_CAR, + MAKINUM(iframe), MAKINUM(idist)); + } #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); + return icdr ? &CDR(*al) : &CAR(*al); } idist++; } @@ -411,11 +458,12 @@ SCM *lookupcar(vloc, check) } #endif var = sym2vcell(var); + gloc_out: #ifndef RECKLESS if (NNULLP(env) || ((check & LOOKUP_UNDEFP) && UNBNDP(CDR(var)))) { var = CAR(var); errout: - everr(vloc, wrapenv() /*scm_env*/, var, + everr(vloc, wrapenv(), var, # ifdef MACRO M_IDENTP(var) ? s_escaped : # endif @@ -424,11 +472,11 @@ SCM *lookupcar(vloc, check) # ifdef MACRO if ((check & LOOKUP_MACROP) && NIMP(CDR(var)) && MACROP(CDR(var))) { var = CAR(var); - badkey: everr(vloc, wrapenv()/*scm_env*/, var, s_badkey, ""); + badkey: everr(vloc, wrapenv(), var, s_badkey, ""); } # endif #endif - CAR(vloc) = var + 1; + if (check) CAR(vloc) = var + 1; return &CDR(var); } @@ -439,6 +487,7 @@ static SCM unmemocar(form) register int ir; DEFER_INTS_EGC; env = scm_env; + if (NIMP(env) && ENVP(env)) env = CDR(env); if IMP(form) return form; if (1==TYP3(form)) CAR(form) = I_SYM(CAR(form)); @@ -458,13 +507,13 @@ static SCM evalatomcar(x) SCM r; switch TYP7(CAR(x)) { default: - everr(x, wrapenv() /*scm_env*/, CAR(x), "Cannot evaluate: ", ""); + everr(x, wrapenv(), CAR(x), "Cannot evaluate: ", ""); case tcs_symbols: lookup: return *lookupcar(x, LOOKUP_UNDEFP|LOOKUP_MACROP); case tc7_vector: #ifndef RECKLESS - if (2 <= verbose) warn("unquoted ", s_vector); + if (2 <= verbose) scm_warn("unquoted ", s_vector); #endif r = cons2(IM_QUOTE, CAR(x), EOL); CAR(x) = r; @@ -474,13 +523,39 @@ static SCM evalatomcar(x) 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: + case tcs_uves: return CAR(x); } } +SCM scm_multi_set(syms, vals) + SCM syms, vals; +{ + SCM res = EOL, *pres = &res; + SCM *loc; + do { + ASSERT(NIMP(vals) && CONSP(vals), vals, WNA, s_set); + switch (7 & (int)(CAR(syms))) { + case 0: + loc = lookupcar(syms, LOOKUP_UNDEFP|LOOKUP_MACROP); + break; + case 1: + loc = &(I_VAL(CAR(syms))); + break; + case 4: + loc = ilookup(CAR(syms)); + break; + } + *pres = cons(*loc, EOL); + pres = &CDR(*pres); + *loc = CAR(vals); + syms = CDR(syms); + vals = CDR(vals); + } while (NIMP(syms)); + ASSERT(NULLP(vals) && NULLP(syms), vals, WNA, s_set); + return res; +} + SCM eval_args(l) SCM l; { @@ -493,6 +568,75 @@ SCM eval_args(l) return res; } +static void ecache_evalx(x) + SCM x; +{ + SCM argv[10]; + int i = 0, imax = sizeof(argv)/sizeof(SCM); + scm_env_tmp = EOL; + while NIMP(x) { + if (imax==i) { + ecache_evalx(x); + break; + } + argv[i++] = EVALCAR(x); + x = CDR(x); + } + scm_env_v2lst(i, argv); +} + +/* result is 1 if right number of arguments, 0 otherwise, + environment frame is put in scm_env_tmp */ +static int ecache_eval_args(proc, arg1, arg2, arg3, x) + SCM proc, arg1, arg2, arg3, x; +{ + SCM argv[3]; + argv[0] = arg1; + argv[1] = arg2; + argv[2] = arg3; + if (NIMP(x)) + ecache_evalx(x); + else + scm_env_tmp = EOL; + scm_env_v2lst(3, argv); +#ifndef RECKLESS + proc = CAR(CODE(proc)); + proc = CDR(proc); + proc = CDR(proc); + proc = CDR(proc); + for (; NIMP(proc); proc=CDR(proc)) { + if IMP(x) return 0; + x = CDR(x); + } + if NIMP(x) return 0; +#endif + return 1; +} + +static SCM asubr_apply(proc, arg1, arg2, arg3, args) + SCM proc, arg1, arg2, arg3, args; +{ + switch TYP7(proc) { + case tc7_asubr: + arg1 = SUBRF(proc)(arg1, arg2); + arg1 = SUBRF(proc)(arg1, arg3); + while NIMP(args) { + arg1 = SUBRF(proc)(arg1, CAR(args)); + args = CDR(args); + } + return arg1; + case tc7_rpsubr: + if FALSEP(SUBRF(proc)(arg1, arg2)) return BOOL_F; + while (!0) { + if FALSEP(SUBRF(proc)(arg2, arg3)) return BOOL_F; + if IMP(args) return BOOL_T; + arg2 = arg3; + arg3 = CAR(args); + args = CDR(args); + } + } +} + /* the following rewrite expressions and * some memoized forms have different syntax */ @@ -531,6 +675,7 @@ static SCM *id_denote(var) SCM env, mark = IDENT_MARK(var); DEFER_INTS_EGC; env = scm_env; + if (NIMP(env) && ENVP(env)) env = CDR(env); for(;NIMP(env); env = CDR(env)) { al = &CAR(env); for(fl = CAR(*al);NIMP(fl);fl = CDR(fl)) { @@ -545,6 +690,12 @@ static SCM *id_denote(var) if (CAR(fl)==var) return &CAR(*al); } } +# ifndef RECKLESS + while M_IDENTP(var) { + ASSERT(IMP(IDENT_MARK(var)), var, s_escaped, ""); + var = IDENT_PARENT(var); + } +# endif return (SCM *)0; } @@ -556,7 +707,7 @@ static void unpaint(p) if CONSP(x) { if NIMP(CAR(x)) unpaint(&CAR(x)); p = &CDR(*p); - } + } else if VECTORP(x) { sizet i = LENGTH(x); if (0==i) return; @@ -575,18 +726,11 @@ static void unpaint(p) # define TOPRENAME(v) (v) #endif -static void bodycheck(xorig, bodyloc, what) - SCM xorig, *bodyloc; - char *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); + 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. */ @@ -631,8 +775,10 @@ SCM m_set(xorig, env) { SCM x = CDR(xorig); ASSYNT(2==ilength(x), xorig, s_expression, s_set); - ASSYNT(NIMP(CAR(x)) && IDENTP(CAR(x)), - xorig, s_variable, s_set); + varcheck(xorig, + (NIMP(CAR(x)) && IDENTP(CAR(x))) ? CAR(x) : + (ilength(CAR(x)) > 0) ? CAR(x) : UNDEFINED, + s_set, s_variable); return cons(IM_SET, x); } @@ -641,8 +787,11 @@ SCM m_and(xorig, env) { int len = ilength(CDR(xorig)); ASSYNT(len >= 0, xorig, s_test, s_and); - if (len >= 1) return cons(IM_AND, CDR(xorig)); - else return BOOL_T; + switch (len) { + default: return cons(IM_AND, CDR(xorig)); + case 1: return CAR(CDR(xorig)); + case 0: return BOOL_T; + } } SCM m_or(xorig, env) @@ -650,8 +799,11 @@ SCM m_or(xorig, env) { int len = ilength(CDR(xorig)); ASSYNT(len >= 0, xorig, s_test, s_or); - if (len >= 1) return cons(IM_OR, CDR(xorig)); - else return BOOL_F; + switch (len) { + default: return cons(IM_OR, CDR(xorig)); + case 1: return CAR(CDR(xorig)); + case 0: return BOOL_F; + } } #ifdef INUMS_ONLY @@ -660,11 +812,11 @@ SCM m_or(xorig, env) SCM m_case(xorig, env) SCM xorig, env; { - SCM clause, cdrx = copy_list(CDR(xorig)), x = cdrx; + SCM clause, cdrx = copy_list(CDR(xorig), 2), x = cdrx; #ifndef RECKLESS SCM s, keys = EOL; #endif - ASSYNT(ilength(x) >= 2, xorig, s_clauses, s_case); + ASSYNT(!UNBNDP(cdrx), xorig, s_clauses, s_case); while(NIMP(x = CDR(x))) { clause = CAR(x); ASSYNT(ilength(clause) >= 2, xorig, s_clauses, s_case); @@ -673,19 +825,22 @@ SCM m_case(xorig, env) CAR(x) = cons(IM_ELSE, CDR(clause)); } else { - ASSYNT(ilength(CAR(clause)) >= 0, xorig, s_clauses, s_case); #ifdef MACRO - clause = cons(copy_list(CAR(clause)), CDR(clause)); + SCM c = copy_list(CAR(clause), 0); + ASSYNT(!UNBNDP(c), xorig, s_clauses, s_case); + clause = cons(c, CDR(clause)); DEFER_INTS; unpaint(&CAR(clause)); ALLOW_INTS; CAR(x) = clause; +#else + ASSYNT(ilength(CAR(clause)) >= 0, xorig, s_clauses, s_case); #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 +#endif } } return cons(IM_CASE, cdrx); @@ -694,9 +849,9 @@ SCM m_case(xorig, env) SCM m_cond(xorig, env) SCM xorig, env; { - SCM arg1, cdrx = copy_list(CDR(xorig)), x = cdrx; + SCM arg1, cdrx = copy_list(CDR(xorig), 1), x = cdrx; int len = ilength(x); - ASSYNT(len >= 1, xorig, s_clauses, s_cond); + ASSYNT(!UNBNDP(cdrx), xorig, s_clauses, s_cond); while(NIMP(x)) { arg1 = CAR(x); len = ilength(arg1); @@ -717,30 +872,39 @@ SCM m_cond(xorig, env) return cons(IM_COND, cdrx); } -SCM m_lambda(xorig, env) - SCM xorig, env; +static int varcheck(xorig, vars, op, what) + SCM xorig, vars; + char *op, *what; { - 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; - while NIMP(proc) { - if NCONSP(proc) - if (!IDENTP(proc)) goto badforms; - else goto memlambda; - if (!(NIMP(CAR(proc)) && IDENTP(CAR(proc)))) goto badforms; - proc = CDR(proc); + SCM v1, vs; + int argc = 0; + for (; NIMP(vars) && CONSP(vars); vars = CDR(vars)) { argc++; +#ifndef RECKLESS + v1 = CAR(vars); + if (IMP(v1) || !IDENTP(v1)) + badvar: wta(xorig, what, op); + for (vs = CDR(vars); NIMP(vs) && CONSP(vs); vs = CDR(vs)) { + if (v1==CAR(vs)) + nonuniq: wta(xorig, "non-unique bindings", op); + } + if (v1==vs) goto nonuniq; +#endif } - if (NNULLP(proc) && (IM_LET != proc)) /* IM_LET inserted by named let. */ - badforms: wta(xorig, s_formals, s_lambda); - memlambda: - return cons2(ISYMSETVAL(IM_LAMBDA, argc), CAR(x), + /* argc of 3 means no rest argument, 3+ required arguments */ + if (NULLP(vars) || ISYMP(vars)) return argc > 3 ? 3 : argc; + ASRTGO(NIMP(vars) && IDENTP(vars), badvar); + return argc > 2 ? 2 : argc; +} +SCM m_lambda(xorig, env) + SCM xorig, env; +{ + SCM x = CDR(xorig); + int argc; + ASSERT(ilength(x) > 1, xorig, s_formals, s_lambda); + argc = varcheck(xorig, CAR(x), s_lambda, s_formals); + if (argc > 3) argc = 3; + return cons2(MAKISYMVAL(IM_LAMBDA, argc), CAR(x), m_body(IM_LAMBDA, CDR(x), s_lambda)); } SCM m_letstar(xorig, env) @@ -771,17 +935,16 @@ SCM m_letstar(xorig, env) <body>) ;; becomes (do_mem (varn ... var2 var1) - (<init1> <init2> ... <initn>) + (<initn> ... <init2> <init1>) (<test> <return>) (<body>) - <step1> <step2> ... <stepn>) ;; missing steps replaced by var + <stepn> ... <step2> <step1>) ;; missing steps replaced by var */ SCM m_do(xorig, env) SCM xorig, env; { SCM x = CDR(xorig), arg1, proc; 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); proc = CAR(x); @@ -790,22 +953,20 @@ 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)) && 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); - *initloc = cons(CAR(arg1), EOL); /* init */ - initloc = &CDR(*initloc); + inits = cons(CAR(arg1), inits); arg1 = CDR(arg1); - *steploc = cons(IMP(arg1)?CAR(vars):CAR(arg1), EOL); /* step */ - steploc = &CDR(*steploc); + steps = cons(IMP(arg1)?CAR(vars):CAR(arg1), steps); proc = CDR(proc); } x = CDR(x); ASSYNT(ilength(CAR(x)) >= 1, xorig, s_test, s_do); + ASSYNT(ilength(CDR(x))>=0, xorig, s_expression, s_do); + varcheck(xorig, vars, s_do, s_variable); x = cons2(CAR(x), CDR(x), steps); x = cons2(vars, inits, x); - bodycheck(xorig, &CAR(CDR(CDR(x))), s_do); return cons(IM_DO, x); } @@ -832,7 +993,7 @@ static SCM iqq(form) } if NCONSP(form) return form; tmp = CAR(form); - if (IM_UNQUOTE==tmp) + if (IM_UNQUOTE==tmp) return evalcar(CDR(form)); if (NIMP(tmp) && IM_UQ_SPLICING==CAR(tmp)) return append(cons2(evalcar(CDR(tmp)), iqq(CDR(form)), EOL)); @@ -877,7 +1038,7 @@ static SCM m_iqq(form, depth, env) } if (i_unquote==tmp && TOPLEVELP(CAR(form), env)) { --depth; - if (0==depth) CAR(form) = IM_UNQUOTE; + if (0==depth) CAR(form) = IM_UNQUOTE; label: tmp = CDR(form); ASSERT(NIMP(tmp) && ECONSP(tmp) && NULLP(CDR(tmp)), @@ -917,6 +1078,20 @@ SCM m_delay(xorig, env) return cons2(IM_DELAY, EOL, CDR(xorig)); } +static int built_inp(name, x) + SCM name, x; +{ + if NIMP(x) { + tail: + switch TYP7(x) { + case tcs_subrs: return CHARS(name)==SNAME(x); + case tc7_smob: if MACROP(x) {x = CDR(x); goto tail;} + /* else fall through */ + } + } + return 0; +} + SCM m_define(x, env) SCM x, env; { @@ -930,7 +1105,7 @@ 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)) { + if (NIMP(env) && ENVP(env)) { DEFER_INTS_EGC; env = CDR(env); } @@ -945,15 +1120,13 @@ SCM m_define(x, env) arg1 = sym2vcell(proc); #ifndef RECKLESS if (2 <= verbose && - NIMP(CDR(arg1)) && - (proc == - ((SCM) SNAME(MACROP(CDR(arg1)) ? CDR(CDR(arg1)) : CDR(arg1)))) + built_inp(proc, CDR(arg1)) && (CDR(arg1) != x)) - warn("redefining built-in ", CHARS(proc)); + scm_warn("redefining built-in ", CHARS(proc)); else #endif if (5 <= verbose && UNDEFINED != CDR(arg1)) - warn("redefining ", CHARS(proc)); + scm_warn("redefining ", CHARS(proc)); CDR(arg1) = x; #ifdef SICP return m_quote(cons2(i_quote, CAR(arg1), EOL), EOL); @@ -962,7 +1135,6 @@ SCM m_define(x, env) #endif } return cons2(IM_DEFINE, proc, x); - /* return cons2(IM_DEFINE, cons(proc,CAR(CAR(env))), x); */ } /* end of acros */ @@ -972,24 +1144,17 @@ static SCM m_letrec1(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 = imm, inits = EOL, *initloc = &inits; - + SCM vars = imm, inits = EOL; /* ASRTSYNTAX(ilength(x) >= 2, s_body); */ proc = CAR(x); -#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 */ arg1 = CAR(proc); ASRTSYNTAX(2==ilength(arg1), s_bindings); - ASRTSYNTAX(NIMP(CAR(arg1)) && IDENTP(CAR(arg1)), s_variable); vars = cons(CAR(arg1), vars); - *initloc = cons(CAR(CDR(arg1)), EOL); - initloc = &CDR(*initloc); + inits = cons(CAR(CDR(arg1)), inits); } while NIMP(proc = CDR(proc)); + varcheck(xorig, vars, what, s_variable); return cons2(op, vars, cons(inits, m_body(imm, CDR(x), what))); } @@ -1039,9 +1204,8 @@ SCM m_let(xorig, env) proc = CDR(proc); } 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); + proc = cons2(i_let, cons(cons2(name, proc, EOL), EOL), cons(name, EOL)); + return cons(m_letrec1(IM_LETREC, IM_LET, proc, env), inits); } #define s_atapply (ISYMCHARS(IM_APPLY)+1) @@ -1053,7 +1217,7 @@ SCM m_apply(xorig, env) return cons(IM_APPLY, CDR(xorig)); } -SCM m_expand_body(xorig) +static SCM m_expand_body(xorig) SCM xorig; { SCM form, x = CDR(xorig), defs = EOL; @@ -1063,7 +1227,7 @@ SCM m_expand_body(xorig) if (IMP(form) || NCONSP(form)) break; if IMP(CAR(form)) break; if (! IDENTP(CAR(form))) break; - form = macroexp1(cons(CAR(form), CDR(form)), 0); + form = macroexp1(form, defs); if (IM_DEFINE==CAR(form)) { defs = cons(CDR(form), defs); x = CDR(x); @@ -1091,109 +1255,59 @@ SCM m_expand_body(xorig) return xorig; } -static SCM macroexp1(x, check) - SCM x; - int check; +static SCM macroexp1(x, defs) + SCM x, defs; { - SCM res, proc; + SCM res = UNDEFINED, proc = CAR(x); int argc; - ASRTGO(IDENTP(CAR(x)), badfun); + ASRTGO(IDENTP(proc), badfun); macro_tail: - proc = *lookupcar(x, 0); + res = CAR(x); + proc = *lookupcar(x, IMP(defs) ? LOOKUP_UNDEFP : 0); if (NIMP(proc) && MACROP(proc)) { - unmemocar(x); - res = apply(CDR(proc), cons2(x, wrapenv(), EOL), EOL); + CAR(x) = res; + res = cons2(x, wrapenv(), 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 */ + case 2: case 6: /* mmacro */ + if (IMP(defs)) { + res = apply(CDR(proc), res, EOL); + if (ilength(res) <= 0) + res = cons2(IM_BEGIN, res, EOL); + DEFER_INTS; + CAR(x) = CAR(res); + CDR(x) = CDR(res); + ALLOW_INTS; + break; + } + /* else fall through */ + case 1: case 5: /* macro */ + res = apply(CDR(proc), res, EOL); x = NIMP(res) ? res : cons2(IM_BEGIN, res, EOL); break; - case 0: /* acro */ + case 0: case 4: /* acro */ + res = IMP(defs) ? apply(CDR(proc), res, EOL) : UNSPECIFIED; 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", ""); + if (UNBNDP(defs) && IM_DEFINE==CAR(x)) + everr(x, wrapenv(), 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 +#ifndef RECKLESS + if (IMP(defs)) { + if (! scm_arity_check(proc, ilength(CDR(x)), (char *)0)) { + badfun: + if (!UNBNDP(res)) CAR(x) = res; + everr(x, wrapenv(), UNBNDP(proc) ? CAR(x) : proc, + UNBNDP(proc) ? s_unbnd : + (FALSEP(procedurep(proc)) ? s_wtap : (char *)WNA), + ""); } - case tcs_closures: - if (badargsp(proc, CDR(x))) { - wrongnumargs: - unmemocar(x); - everr(x, wrapenv()/*scm_env*/, proc, (char *)WNA, ""); - } - return x; } #endif /* ndef RECKLESS */ + return x; } #ifndef RECKLESS @@ -1209,6 +1323,62 @@ int badargsp(proc, args) } return NNULLP(args) ? 1 : 0; } +/* If what is null, signals error instead of returning false. */ +int scm_arity_check(proc, argc, what) + SCM proc; + long argc; + char *what; +{ + SCM p = proc; + if (IMP(p)) + return 0; + cclo_tail: + switch TYP7(p) { + default: + badproc: + if (what) wta(proc, (char *)ARG1, what); + return 0; + wrongnumargs: + if (what) wta(proc, (char *)WNA, what); + return 0; + case tc7_subr_0: ASRTGO(0==argc, wrongnumargs) return !0; + case tc7_cxr: + case tc7_contin: + case tc7_subr_1: ASRTGO(1==argc, wrongnumargs) return !0; + case tc7_subr_1o: ASRTGO(0==argc || 1==argc, wrongnumargs) return !0; + case tc7_subr_2: ASRTGO(2==argc, wrongnumargs) return !0; + case tc7_subr_2o: ASRTGO( 1==argc || 2==argc, wrongnumargs) return !0; + case tc7_subr_3: ASRTGO(3==argc, wrongnumargs) return !0; + case tc7_rpsubr: + case tc7_asubr: + case tc7_lsubr: return !0; + case tc7_lsubr_2: ASRTGO(2<=argc, wrongnumargs) return !0; + case tc7_specfun: + switch TYP16(proc) { + case tc16_apply: ASRTGO(2<=argc, wrongnumargs) return !0; + case tc16_call_cc: + case tc16_eval: ASRTGO(1==argc, wrongnumargs) return !0; +# ifdef CCLO + case tc16_cclo: + p = CCLO_SUBR(p); + argc++; + goto cclo_tail; +# endif + } + case tcs_closures: + { + SCM formals = CAR(CODE(p)); + while (argc--) { + if IMP(formals) goto wrongnumargs; + if (CONSP(formals)) + formals = CDR(formals); + else + return !0; + } + ASRTGO(IMP(formals) || NCONSP(formals), wrongnumargs); + } + } +} #endif char s_map[] = "map", s_for_each[] = "for-each", s_eval[] = "eval"; @@ -1219,19 +1389,23 @@ static SCM wrapenv() register SCM z; NEWCELL(z); DEFER_INTS_EGC; + if (NIMP(scm_env) && ENVP(scm_env)) + return scm_env; CDR(z) = scm_env; CAR(z) = tc16_env; - EGC_ROOT(z); + EGC_ROOT(z); return z; } SCM ceval(x, env) SCM x, env; { - DEFER_INTS_EGC; ENV_PUSH; - scm_env = env; +#ifdef CAUTIOUS + scm_trace = UNSPECIFIED; +#endif TRACE(x); + scm_env = env; x = ceval_1(x); ENV_POP; ALLOW_INTS_EGC; @@ -1245,9 +1419,14 @@ static SCM ceval_1(x) 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. */ +#ifdef CAUTIOUS + SCM xorig; +#endif CHECK_STACK; loop: POLL; - TRACE(x); +#ifdef CAUTIOUS + xorig = x; +#endif #ifdef SCM_PROFILE eval_cases[TYP7(x)]++; #endif @@ -1283,18 +1462,17 @@ static SCM ceval_1(x) if NCELLP(CAR(x)) { x = CAR(x); x = IMP(x) ? EVALIMP(x) : I_VAL(x); - goto retx; } - - if ATOMP(CAR(x)) { + else if ATOMP(CAR(x)) x = evalatomcar(x); - retx: - ENV_MAY_POP(envpp, 0); - ALLOW_INTS_EGC; - return x; + else { + x = CAR(x); + goto loop; /* tail recurse */ } - x = CAR(x); - goto loop; /* tail recurse */ + retx: + ENV_MAY_POP(envpp, 0); + ALLOW_INTS_EGC; + return x; case (127 & IM_CASE): x = CDR(x); @@ -1321,10 +1499,8 @@ static SCM ceval_1(x) proc = CDR(proc); } } - retunspec: - ENV_MAY_POP(envpp, 0); - ALLOW_INTS_EGC; - return UNSPECIFIED; + x = UNSPECIFIED; + goto retx; case (127 & IM_COND): while(NIMP(x = CDR(x))) { proc = CAR(x); @@ -1342,16 +1518,13 @@ static SCM ceval_1(x) goto evap1; } } - goto retunspec; + x = UNSPECIFIED; + goto retx; case (127 & IM_DO): ENV_MAY_PUSH(envpp); + TRACE(x); x = CDR(x); - proc = CAR(CDR(x)); /* inits */ - scm_env_tmp = EOL; /* values */ - while NIMP(proc) { - scm_env_cons_tmp(EVALCAR(proc)); - proc = CDR(proc); - } + ecache_evalx(CAR(CDR(x))); /* inits */ EXTEND_ENV(CAR(x)); x = CDR(CDR(x)); while (proc = CAR(x), FALSEP(EVALCAR(proc))) { @@ -1359,51 +1532,42 @@ static SCM ceval_1(x) t.arg1 = CAR(proc); /* body */ SIDEVAL_1(t.arg1); } - scm_env_tmp = EOL; - for(proc = CDR(CDR(x)); NIMP(proc); proc = CDR(proc)) { - scm_env_cons_tmp(EVALCAR(proc)); /* steps */ - } - DEFER_INTS_EGC; + ecache_evalx(CDR(CDR(x))); /* steps */ t.arg1 = CAR(CAR(scm_env)); scm_env = CDR(scm_env); EXTEND_ENV(t.arg1); } x = CDR(proc); - if NULLP(x) goto retunspec; + if NULLP(x) {x = UNSPECIFIED; goto retx;} goto begin; case (127 & IM_IF): x = CDR(x); if NFALSEP(EVALCAR(x)) x = CDR(x); - else if IMP(x = CDR(CDR(x))) goto retunspec; + else if IMP(x = CDR(CDR(x))) {x = UNSPECIFIED; goto retx;} goto carloop; case (127 & IM_LET): ENV_MAY_PUSH(envpp); + TRACE(x); x = CDR(x); - proc = CAR(CDR(x)); - scm_env_tmp = EOL; - do { - scm_env_cons_tmp(EVALCAR(proc)); - } while NIMP(proc = CDR(proc)); + ecache_evalx(CAR(CDR(x))); EXTEND_ENV(CAR(x)); x = CDR(x); goto cdrxbegin; case (127 & IM_LETREC): ENV_MAY_PUSH(envpp); + TRACE(x); x = CDR(x); scm_env_tmp = undefineds; EXTEND_ENV(CAR(x)); x = CDR(x); - proc = CAR(x); - scm_env_tmp = EOL; - do { - scm_env_cons_tmp(EVALCAR(proc)); - } while NIMP(proc = CDR(proc)); + ecache_evalx(CAR(x)); 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); + TRACE(x); x = CDR(x); proc = CAR(x); if IMP(proc) { @@ -1439,10 +1603,13 @@ static SCM ceval_1(x) proc = CAR(x); switch (7 & (int)proc) { case 0: - if CONSP(proc) - *farlookup(proc) = arg2; - else - *lookupcar(x, LOOKUP_UNDEFP|LOOKUP_MACROP) = arg2; + if ECONSP(proc) + if ISYMP(CAR(proc)) *farlookup(proc) = arg2; + else { + x = scm_multi_set(proc, arg2); + goto retx; + } + else *lookupcar(x, LOOKUP_UNDEFP|LOOKUP_MACROP) = arg2; break; case 1: I_VAL(proc) = arg2; @@ -1453,26 +1620,12 @@ static SCM ceval_1(x) } #ifdef SICP x = arg2; - goto retx; +#else + x = UNSPECIFIED; #endif - goto retunspec; + goto retx; case (127 & IM_DEFINE): /* only for internal defines */ goto badfun; -#if 0 - x = CDR(x); - proc = CAR(x); - x = CDR(x); - 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); @@ -1482,13 +1635,13 @@ static SCM ceval_1(x) #endif switch ISYMNUM(proc) { case (ISYMNUM(IM_APPLY)): - proc = CDR(x); - proc = EVALCAR(proc); + x = CDR(x); + proc = evalcar(x); ASRTGO(NIMP(proc), badfun); - t.arg1 = CDR(CDR(x)); - t.arg1 = EVALCAR(t.arg1); + t.arg1 = evalcar(CDR(x)); if (CLOSUREP(proc)) { ENV_MAY_PUSH(envpp); + TRACE(x); scm_env_tmp = t.arg1; #ifndef RECKLESS goto clo_checked; @@ -1497,7 +1650,7 @@ static SCM ceval_1(x) #endif } x = apply(proc, t.arg1, EOL); - goto retx; + goto retx; case (ISYMNUM(IM_DELAY)): x = makprom(closure(CDR(x), 0)); goto retx; @@ -1515,11 +1668,12 @@ static SCM ceval_1(x) default: proc = x; badfun: - everr(x, wrapenv() /*scm_env*/, proc, s_wtap, ""); +#ifdef CAUTIOUS + scm_trace = UNDEFINED; +#endif + everr(x, wrapenv(), 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 tcs_uves: case tc7_smob: goto retx; case (127 & ILOC00): @@ -1530,18 +1684,28 @@ static SCM ceval_1(x) break; case tcs_cons_nimcar: if ATOMP(CAR(x)) { - x = macroexp1(x, !0); + TOP_TRACE(x); +#ifdef MEMOIZE_LOCALS + x = macroexp1(x, UNDEFINED); goto loop; +#else + proc = *lookupcar(x, 0); + if (NIMP(proc) && MACROP(proc)) { + x = macroexp1(x, UNDEFINED); + goto loop; + } +#endif } - proc = ceval_1(CAR(x)); + else 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. */ } ASRTGO(NIMP(proc), badfun); - *scm_estk_ptr = scm_env; /* For error reporting at wrongnumargs. */ + scm_estk_ptr[0] = scm_env; /* For error reporting at wrongnumargs. */ if NULLP(CDR(x)) { evap0: ENV_MAY_POP(envpp, CLOSUREP(proc)); + TOP_TRACE(xorig); ALLOW_INTS_EGC; switch TYP7(proc) { /* no arguments given */ case tc7_subr_0: @@ -1582,6 +1746,7 @@ static SCM ceval_1(x) x = CODE(proc); scm_env = ENV(proc); EXTEND_ENV(CAR(x)); + TRACE(CDR(x)); goto cdrxbegin; case tc7_specfun: #ifdef CCLO @@ -1603,9 +1768,10 @@ static SCM ceval_1(x) wrongnumargs: if (envpp < 0) { scm_estk_ptr += SCM_ESTK_FRLEN; - scm_env = *scm_estk_ptr; + scm_env = scm_estk_ptr[0]; } - everr(x, wrapenv()/*scm_env*/, proc, (char *)WNA, ""); + TOP_TRACE(UNDEFINED); + everr(x, wrapenv(), proc, (char *)WNA, ""); default: goto badfun; } @@ -1619,6 +1785,7 @@ static SCM ceval_1(x) if NULLP(x) { evap1: ENV_MAY_POP(envpp, CLOSUREP(proc)); + TOP_TRACE(xorig); ALLOW_INTS_EGC; switch TYP7(proc) { /* have one argument in t.arg1 */ case tc7_subr_2o: @@ -1639,16 +1806,19 @@ evap1: return makdbl(DSUBRF(proc)(big2dbl(t.arg1)), 0.0); # endif floerr: - wta(t.arg1, (char *)ARG1, CHARS(SNAME(proc))); + wta(t.arg1, (char *)ARG1, SNAME(proc)); } #endif - proc = (SCM)SNAME(proc); { - char *chrs = CHARS(proc)+LENGTH(proc)-1; - while('c' != *--chrs) { + int op = CXR_OP(proc); +#ifndef RECKLESS + x = t.arg1; +#endif + while (op) { ASSERT(NIMP(t.arg1) && CONSP(t.arg1), - t.arg1, ARG1, CHARS(proc)); - t.arg1 = ('a'==*chrs)?CAR(t.arg1):CDR(t.arg1); + x, ARG1, SNAME(proc)); + t.arg1 = (1 & op ? CAR(t.arg1) : CDR(t.arg1)); + op >>= 2; } return t.arg1; } @@ -1672,7 +1842,7 @@ evap1: goto clo_checked; } case tc7_contin: - scm_dynthrow(CONT(proc), t.arg1); + scm_dynthrow(proc, t.arg1); case tc7_specfun: switch TYP16(proc) { case tc16_call_cc: @@ -1684,10 +1854,19 @@ evap1: #ifdef SHORT_INT x = (SCM)thrown_value; #endif +#ifdef CHEAP_CONTINUATIONS + envpp = 0; +#endif goto retx; } ASRTGO(NIMP(proc), badfun); goto evap1; + case tc16_eval: + ENV_MAY_PUSH(envpp); + TRACE(x); + scm_env = EOL; + x = cons(copytree(t.arg1), EOL); + goto begin; #ifdef CCLO case tc16_cclo: arg2 = t.arg1; @@ -1714,6 +1893,7 @@ evap1: if NULLP(x) { /* have two arguments */ evap2: ENV_MAY_POP(envpp, CLOSUREP(proc)); + TOP_TRACE(xorig); ALLOW_INTS_EGC; switch TYP7(proc) { case tc7_subr_2: @@ -1745,9 +1925,12 @@ evap1: 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)); + arg3 = x; + x = copy_list(CDR(x), 0); +#ifndef RECKLESS + if UNBNDP(x) {x = arg3; goto badlst;} +#endif + arg3 = CAR(arg3); goto evap3; #ifdef CCLO case tc16_cclo: cclon: @@ -1775,15 +1958,15 @@ evap1: eval_clo_cases[2][ARGC(proc)]++; #endif switch ARGC(proc) { - case 2: + 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 0: case 3: /* Error, will be caught at clo_checked: */ - scm_env_tmp = cons2(t.arg1, arg2, EOL); + scm_env_tmp = cons2(t.arg1, arg2, EOL); goto clo_checked; } } @@ -1791,23 +1974,27 @@ evap1: { /* have 3 or more arguments */ arg3 = EVALCAR(x); x = CDR(x); - if NIMP(x) x = eval_args(x); + if NIMP(x) { + if (CLOSUREP(proc) && 3==ARGC(proc)) { + ENV_MAY_PUSH(envpp); + if (ecache_eval_args(proc, t.arg1, arg2, arg3, x)) + goto clo_unchecked; + goto umwrongnumargs; + } + x = eval_args(x); + } evap3: - ENV_MAY_POP(envpp, CLOSUREP(proc)); + ENV_MAY_POP(envpp, CLOSUREP(proc)); + TOP_TRACE(xorig); 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); + return asubr_apply(proc, t.arg1, arg2, arg3, x); + /* 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: @@ -1928,22 +2115,35 @@ SCM nconc2copy(lst) } return lst; } -/* Shallow copy */ -SCM copy_list(lst) +/* Shallow copy. If LST is not a proper list of length at least + MINLEN, returns UNDEFINED */ +SCM copy_list(lst, minlen) SCM lst; + int minlen; { SCM res, *lloc = &res; res = EOL; - for(; NIMP(lst); lst = CDR(lst)) { + for(; NIMP(lst) && CONSP(lst); lst = CDR(lst)) { *lloc = cons(CAR(lst), EOL); lloc = &CDR(*lloc); + minlen--; } + if (NULLP(lst) && minlen <= 0) + return res; + return UNDEFINED; +} +SCM scm_v2lst(n, v) + long n; + SCM *v; +{ + SCM res = EOL; + for(n--; n >= 0; n--) res = cons(v[n], res); return res; } +static SCM f_apply_closure; SCM apply(proc, arg1, args) SCM proc, arg1, args; { - apply_tail: ASRTGO(NIMP(proc), badproc); if NULLP(args) if NULLP(arg1) arg1 = UNDEFINED; @@ -1951,13 +2151,16 @@ SCM apply(proc, arg1, args) args = CDR(arg1); arg1 = CAR(arg1); } - else { - /* ASRTGO(NIMP(args) && CONSP(args), wrongnumargs); */ + else args = nconc2copy(args); - } cc_tail: ALLOW_INTS_EGC; switch TYP7(proc) { + default: + badproc: + wta(proc, (char *)ARG1, s_apply); + wrongnumargs: + wta(proc, (char *)WNA, s_apply); case tc7_subr_2o: if NULLP(args) { args = UNDEFINED; @@ -1992,13 +2195,16 @@ SCM apply(proc, arg1, args) wta(arg1, (char *)ARG1, CHARS(SNAME(proc))); } #endif - proc = (SCM)SNAME(proc); { - char *chrs = CHARS(proc)+LENGTH(proc)-1; - while('c' != *--chrs) { + int op = CXR_OP(proc); +#ifndef RECKLESS + args = arg1; +#endif + while (op) { ASSERT(NIMP(arg1) && CONSP(arg1), - arg1, ARG1, CHARS(proc)); - arg1 = ('a'==*chrs)?CAR(arg1):CDR(arg1); + args, ARG1, SNAME(proc)); + arg1 = (1 & op ? CAR(arg1) : CDR(arg1)); + op >>= 2; } return arg1; } @@ -2033,134 +2239,275 @@ SCM apply(proc, arg1, args) #ifndef RECKLESS if (badargsp(proc, arg1)) goto wrongnumargs; #endif - DEFER_INTS_EGC; ENV_PUSH; - TRACE(proc); + PUSH_TRACE; scm_env_tmp = arg1; scm_env = ENV(proc); - EXTEND_ENV(CAR(CODE(proc))); proc = CODE(proc); - arg1 = ceval_1(cons(IM_BEGIN, CDR(proc))); - /* while NNULLP(proc = CDR(proc)) arg1 = EVALCAR(proc); */ + EXTEND_ENV(CAR(proc)); + proc = CDR(proc); + while NNULLP(proc) { + if (IMP(CAR(proc)) && ISYMP(CAR(proc))) { + proc = m_expand_body(proc); + continue; + } + arg1 = EVALCAR(proc); + proc = CDR(proc); + } ENV_POP; + ALLOW_INTS_EGC; return arg1; case tc7_contin: ASRTGO(NULLP(args), wrongnumargs); - scm_dynthrow(CONT(proc), arg1); + scm_dynthrow(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; + args = UNBNDP(arg1) ? EOL : cons(arg1, args); + arg1 = proc; +#ifdef CCLO + proc = (TYP16(proc)==tc16_cclo ? CCLO_SUBR(proc) : f_apply_closure); +#else + proc = f_apply_closure; +#endif + goto cc_tail; + } +} + +/* This function does not check that proc is a procedure, nor the + number of arguments, call scm_arity_check to do that. */ +SCM scm_cvapply(proc, n, argv) + SCM proc, *argv; + long n; +{ + SCM res; + long i; + tail: + ALLOW_INTS_EGC; + switch TYP7(proc) { + default: return UNSPECIFIED; + case tc7_subr_2o: + if (1==n) return SUBRF(proc)(argv[0], UNDEFINED); + /* Fall through */ + case tc7_subr_2: + return SUBRF(proc)(argv[0], argv[1]); + case tc7_subr_0: + subr0: + return SUBRF(proc)(); + case tc7_subr_1o: + if (0==n) return SUBRF(proc)(UNDEFINED); + /* Fall through */ + case tc7_subr_1: + return SUBRF(proc)(argv[0]); + case tc7_cxr: +#ifdef FLOATS + if SUBRF(proc) { + if INUMP(argv[0]) + return makdbl(DSUBRF(proc)((double) INUM(argv[0])), 0.0); + ASRTGO(NIMP(argv[0]), floerr); + if REALP(argv[0]) + return makdbl(DSUBRF(proc)(REALPART(argv[0])), 0.0); +# ifdef BIGDIG + if BIGP(argv[0]) + return makdbl(DSUBRF(proc)(big2dbl(argv[0])), 0.0); +# endif + floerr: + wta(argv[0], (char *)ARG1, CHARS(SNAME(proc))); + } #endif - return args; + { + int op = CXR_OP(proc); + res = argv[0]; + while (op) { + ASSERT(NIMP(res) && CONSP(res), + argv[0], ARG1, SNAME(proc)); + res = (1 & op ? CAR(res) : CDR(res)); + op >>= 2; } - args = EOL; - goto cc_tail; -#ifdef CCLO - case tc16_cclo: - args = (UNBNDP(arg1) ? EOL : cons(arg1, args)); - arg1 = proc; - proc = CCLO_SUBR(proc); - goto cc_tail; + return res; + } + case tc7_subr_3: + return SUBRF(proc)(argv[0], argv[1], argv[2]); + case tc7_lsubr: + return SUBRF(proc)(0==n ? EOL : scm_v2lst(n, argv)); + case tc7_lsubr_2: + return SUBRF(proc)(argv[0], argv[1], + 2==n ? EOL : scm_v2lst(n-2, &argv[2])); + case tc7_asubr: + if (1 >= n) return SUBRF(proc)(0==n ? UNDEFINED : argv[0], UNDEFINED); + res = argv[0]; + for (i = 1; i < n; i++) + res = SUBRF(proc)(res, argv[i]); + return res; + case tc7_rpsubr: + if (1 >= n) return BOOL_T; + for (i = 0; i < n-1; i++) + if FALSEP(SUBRF(proc)(argv[i], argv[i+1])) return BOOL_F; + return BOOL_T; + case tcs_closures: + ENV_PUSH; + PUSH_TRACE; + i = ARGC(proc); + if (3==i) { + scm_env_tmp = EOL; + scm_env_v2lst((int)n, argv); + } + else { + scm_env_tmp = (i < n) ? scm_v2lst(n-i, &argv[i]) : EOL; + if (i>0) + scm_env_v2lst((int)i, argv); + } + scm_env = ENV(proc); + proc = CODE(proc); + EXTEND_ENV(CAR(proc)); + proc = CDR(proc); + while NNULLP(proc) { + if (IMP(CAR(proc)) && ISYMP(CAR(proc))) { + proc = m_expand_body(proc); + continue; + } + res = EVALCAR(proc); + proc = CDR(proc); + } + ENV_POP; + ALLOW_INTS_EGC; + return res; + case tc7_contin: + scm_dynthrow(proc, argv[0]); + case tc7_specfun: + if (tc16_apply==TYP16(proc)) { + proc = argv[0]; + argv++; + n--; +#ifndef RECKLESS + scm_arity_check(proc, n, s_apply); #endif + goto tail; } - goto badproc; - wrongnumargs: - wta(proc, (char *)WNA, s_apply); - default: - badproc: - wta(proc, (char *)ARG1, s_apply); - return arg1; + res = cons(proc, 0==n ? EOL : scm_v2lst(n, argv)); +#ifdef CCLO + proc = (TYP16(proc)==tc16_cclo ? CCLO_SUBR(proc) : f_apply_closure); +#else + proc = f_apply_closure; +#endif + return apply(proc, res, EOL); } } SCM map(proc, arg1, args) SCM proc, arg1, args; { - long i; - SCM res = EOL, *pres = &res; - 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) { - while NIMP(arg1) { - ASSERT(CONSP(arg1), arg1, ARG2, s_map); - *pres = cons(apply(proc, CAR(arg1), listofnull), EOL); - pres = &CDR(*pres); - arg1 = CDR(arg1); - } - return res; - } - args = vector(cons(arg1, args)); - ve = VELTS(args); + SCM res = EOL, *pres = &res; + SCM heap_ve, auto_ve[5], auto_ave[5]; + SCM *ve = auto_ve, *ave = auto_ave; + long i, n = ilength(args) + 1; + scm_protect_temp(&heap_ve); /* Keep heap_ve from being optimized away. */ + if NULLP(arg1) return res; +#ifdef CAUTIOUS + ENV_PUSH; + PUSH_TRACE; +#endif #ifndef RECKLESS - for(i = LENGTH(args)-1; i >= 0; i--) - ASSERT(NIMP(ve[i]) && CONSP(ve[i]), args, ARG2, s_map); -#endif - while (1) { - arg1 = EOL; - for (i = LENGTH(args)-1;i >= 0;i--) { - if IMP(ve[i]) return res; - arg1 = cons(CAR(ve[i]), arg1); - ve[i] = CDR(ve[i]); - } - *pres = cons(apply(proc, arg1, EOL), EOL); - pres = &CDR(*pres); - } + scm_arity_check(proc, n, s_map); +#endif + ASSERT(NIMP(arg1), arg1, ARG2, s_map); +#ifdef CCLO + if (tc16_cclo==TYP16(proc)) { + args = cons(arg1, args); + arg1 = cons(proc, EOL); + SETCDR(arg1, arg1); /* circular list */ + proc = CCLO_SUBR(proc); + n++; + } +#endif + if (n > 5) { + heap_ve = make_vector(MAKINUM(2*n), BOOL_F); + ve = VELTS(heap_ve); + ave = &(ve[n]); + } + ve[0] = arg1; + ASSERT(NIMP(ve[0]) && CONSP(ve[0]), arg1, ARG2, s_map); + for (i = 1; i < n; i++) { + ve[i] = CAR(args); + ASSERT(NIMP(ve[i]) && CONSP(ve[i]), args, ARGn, s_map); + args = CDR(args); + } + while (1) { + arg1 = EOL; + for (i = n-1;i >= 0;i--) { + if IMP(ve[i]) { +#ifdef CAUTIOUS + ENV_POP; +#endif + return res; + } + ave[i] = CAR(ve[i]); + ve[i] = CDR(ve[i]); + } + *pres = cons(scm_cvapply(proc, n, ave), EOL); + pres = &CDR(*pres); + } } SCM for_each(proc, arg1, args) SCM proc, arg1, args; { - 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) { - while NIMP(arg1) { - ASSERT(CONSP(arg1), arg1, ARG2, s_for_each); - apply(proc, CAR(arg1), listofnull); - arg1 = CDR(arg1); - } - return UNSPECIFIED; - } - args = vector(cons(arg1, args)); - ve = VELTS(args); - while (1) { - arg1 = EOL; - for (i = LENGTH(args)-1;i >= 0;i--) { - if IMP(ve[i]) return UNSPECIFIED; - arg1 = cons(CAR(ve[i]), arg1); - ve[i] = CDR(ve[i]); - } - apply(proc, arg1, EOL); - } + SCM heap_ve, auto_ve[5], auto_ave[5]; + SCM *ve = auto_ve, *ave = auto_ave; + long i, n = ilength(args) + 1; + scm_protect_temp(&heap_ve); /* Keep heap_ve from being optimized away. */ + if NULLP(arg1) return UNSPECIFIED; +#ifdef CAUTIOUS + ENV_PUSH; + PUSH_TRACE; +#endif +#ifndef RECKLESS + scm_arity_check(proc, n, s_map); +#endif + ASSERT(NIMP(arg1), arg1, ARG2, s_for_each); +#ifdef CCLO + if (tc16_cclo==TYP16(proc)) { + args = cons(arg1, args); + arg1 = cons(proc, EOL); + SETCDR(arg1, arg1); /* circular list */ + proc = CCLO_SUBR(proc); + n++; + } +#endif + if (n > 5) { + heap_ve = make_vector(MAKINUM(2*n), BOOL_F); + ve = VELTS(heap_ve); + ave = &(ve[n]); + } + ve[0] = arg1; + ASSERT(NIMP(ve[0]) && CONSP(ve[0]), arg1, ARG2, s_for_each); + for (i = 1; i < n; i++) { + ve[i] = CAR(args); + ASSERT(NIMP(ve[i]) && CONSP(ve[i]), args, ARGn, s_for_each); + args = CDR(args); + } + while (1) { + arg1 = EOL; + for (i = n-1;i >= 0;i--) { + if IMP(ve[i]) { +#ifdef CAUTIOUS + ENV_POP; +#endif + return UNSPECIFIED; + } + ave[i] = CAR(ve[i]); + ve[i] = CDR(ve[i]); + } + scm_cvapply(proc, n, ave); + } } /* 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 + closure. A value 3 means no rest argument, 3 or more required arguments. + 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); DEFER_INTS_EGC; @@ -2194,40 +2541,135 @@ static int prinprom(exp, port, writing) return !0; } +static char s_makacro[] = "procedure->syntax"; SCM makacro(code) SCM code; { register SCM z; + ASSERT(scm_arity_check(code, 2L, (char *)0), code, ARG1, s_makacro); NEWCELL(z); CDR(z) = code; CAR(z) = tc16_macro; return z; } +static char s_makmacro[] = "procedure->macro"; SCM makmacro(code) SCM code; { register SCM z; + ASSERT(scm_arity_check(code, 2L, (char *)0), code, ARG1, s_makmacro); NEWCELL(z); CDR(z) = code; CAR(z) = tc16_macro | (1L<<16); return z; } +static char s_makmmacro[] = "procedure->memoizing-macro"; SCM makmmacro(code) SCM code; { register SCM z; + ASSERT(scm_arity_check(code, 2L, (char *)0), code, ARG1, s_makmmacro); NEWCELL(z); CDR(z) = code; CAR(z) = tc16_macro | (2L<<16); return z; } +#ifdef MACRO +/* Functions for (eventual) smart expansion */ +static char s_macroexpand1[] = "@macroexpand1"; +SCM scm_macroexpand1(x, env) + SCM x, env; +{ + SCM res, proc; + if (IMP(x) || NCONSP(x)) return x; + res = CAR(x); + if (IMP(res) || !IDENTP(res)) return x; + ENV_PUSH; + PUSH_TRACE; + if (NULLP(env)) + scm_env = env; + else { + ASSERT(NIMP(env) && ENVP(env), env, ARG2, s_macroexpand1); + scm_env = CDR(env); + } + proc = *lookupcar(x, 0); + ENV_POP; + ALLOW_INTS_EGC; + if (NIMP(proc) && MACROP(proc)) { + SCM argv[2]; + switch ((int)(CAR(proc)>>16) & 0x7f) { + default: return x; /* Primitive macro invocation. */ + case 2: case 1: + argv[0] = x; + argv[1] = env; + res = scm_cvapply(CDR(proc), 2L, argv); + if (res==x) return cons(CAR(x), CDR(x)); + return res; + case 0: case 4: /* Acros, primitive or not. */ + argv[0] = x; + argv[1] = env; + return cons2(TOPRENAME(i_quote), + scm_cvapply(CDR(proc), 2L, argv), + EOL); + } + } + return x; +} +static char s_env_ref[] = "environment-ref"; +SCM scm_env_ref(env, ident) + SCM env, ident; +{ + SCM *p, ret; + if NULLP(env) return BOOL_F; + ASSERT(NIMP(env) && ENVP(env), env, ARG1, s_env_ref); + ASSERT(NIMP(ident) && IDENTP(ident), ident, ARG2, s_env_ref); + ENV_PUSH; + PUSH_TRACE; + scm_env = CDR(env); + p = id_denote(ident); + ret = p ? *p : BOOL_F; + ENV_POP; + ALLOW_INTS_EGC; + return ret; +} +static char s_extended_env[] = "extended-environment"; +SCM scm_extended_env(names, vals, env) + SCM names, vals, env; +{ + SCM z, nenv; +# ifndef RECKLESS + SCM v = vals; + z = names; + for (z = names; NIMP(z) && CONSP(z); z = CDR(z)) { + ASSERT(NIMP(v) && CONSP(v), vals, ARG2, s_extended_env); + v = CDR(v); + } + ASSERT(NNULLP(z) || NULLP(v), vals, ARG2, s_extended_env); +# endif + nenv = acons(names, vals, env2tree(env)); + NEWCELL(z); + CDR(z) = nenv; + CAR(z) = tc16_env | (1L << 16); + return z; +} +static char s_eval_syntax[] = "eval-syntax"; +SCM scm_eval_syntax(x, env) + SCM x, env; +{ + ASSERT(IMP(env) ? NULLP(env) : ENVP(env), env, ARG2, s_eval_syntax); + return EVAL(x, env); +} +#endif /* MACRO */ + static int prinmacro(exp, port, writing) SCM exp; SCM port; int writing; { - if (CAR(exp) & (3L<<16)) lputs("#<macro", port); - else lputs("#<syntax", port); + if (CAR(exp) & (4L<<16)) lputs("#<primitive-", port); + else lputs("#<", port); + if (CAR(exp) & (3L<<16)) lputs("macro", port); + else lputs("syntax", port); if (CAR(exp) & (2L<<16)) lputc('!', port); lputc(' ', port); iprin1(CDR(exp), port, writing); @@ -2267,7 +2709,7 @@ SCM force(x) { ASSERT(NIMP(x) && (TYP16(x)==tc16_promise), x, ARG1, s_force); if (!((1L<<16) & CAR(x))) { - SCM ans = apply(CDR(x), EOL, EOL); + SCM ans = scm_cvapply(CDR(x), 0L, (SCM *)0); if (!((1L<<16) & CAR(x))) { DEFER_INTS; CDR(x) = ans; @@ -2330,7 +2772,6 @@ SCM ident_eqp(id1, id2, env) SCM id1, id2, env; { SCM s1 = id1, s2 = id2, ret; - # ifndef RECKLESS if IMP(id1) badarg1: wta(id1, (char *)ARG1, s_ident_eqp); @@ -2343,10 +2784,14 @@ SCM ident_eqp(id1, id2, env) ASRTGO(SYMBOLP(s1), badarg1); ASRTGO(SYMBOLP(s2), badarg2); if (s1 != s2) 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; + PUSH_TRACE; + if NULLP(env) scm_env = env; + else { + ASSERT(NIMP(env) && tc16_env==TYP16(env), env, ARG3, s_ident_eqp); + scm_env = CDR(env); + } + ret = (id_denote(id1)==id_denote(id2)) ? BOOL_T : BOOL_F; ENV_POP; return ret; } @@ -2367,7 +2812,7 @@ 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); + ASSERT(ENVP(env), env, ARG2, s_renamed_ident); DEFER_INTS_EGC; env = CDR(env); } @@ -2402,7 +2847,7 @@ SCM m_atlet_syntax(xorig, env) { SCM mark; DEFER_INTS_EGC; - if (tc16_env==CAR(env)) + if (NIMP(env) && ENVP(env)) env = CDR(env); if NULLP(env) return m_let(xorig, env); mark = CAR(CAR(env)); @@ -2435,16 +2880,21 @@ SCM env2tree(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; + ASSERT(NIMP(env) && ENVP(env), env, ARG1, s_env2tree); + if ((1L << 16) & CAR(env)) return CDR(env); + if IMP(CDR(env)) return CDR(env); ENV_PUSH; + PUSH_TRACE; 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)) { + if (undefineds==*lloc) { + *lloc = BOOL_F; + break; + } *lloc = cons(CAR(scm_env_tmp), CDR(scm_env_tmp)); lloc = &CDR(*lloc); DEFER_INTS_EGC; @@ -2459,12 +2909,14 @@ SCM env2tree(env) } ENV_POP; ALLOW_INTS_EGC; + CDR(env) = ans; /* Memoize migrated environment. */ + CAR(env) |= (1L << 16); return ans; } static iproc subr1s[] = { {"@copy-tree", copytree}, - {s_eval, eval}, +/* {s_eval, eval}, now a (tail recursive) specfun */ {s_force, force}, {s_proc_doc, l_proc_doc}, {"procedure->syntax", makacro}, @@ -2482,8 +2934,20 @@ static iproc lsubr2s[] = { /* {s_apply, apply}, now explicity initted */ {s_map, map}, {s_for_each, for_each}, +#ifdef MACRO + {s_macroexpand1, scm_macroexpand1}, + {s_env_ref, scm_env_ref}, + {s_eval_syntax, scm_eval_syntax}, +#endif {0, 0}}; +static iproc subr3s[] = { +#ifdef MACRO + {s_ident_eqp, ident_eqp}, + {s_extended_env, scm_extended_env}, +#endif + {0, 0}}; + static smobfuns promsmob = {markcdr, free0, prinprom}; static smobfuns macrosmob = {markcdr, free0, prinmacro}; static smobfuns envsmob = {markcdr, free0, prinenv}; @@ -2492,19 +2956,14 @@ static smobfuns idsmob = {markcdr, free0, prinid}; #endif SCM make_synt(name, macroizer, fcn) - char *name; + const char *name; SCM (*macroizer)(); SCM (*fcn)(); { SCM symcell = sysintern(name, UNDEFINED); - long tmp = ((((CELLPTR)(CAR(symcell)))-heap_org)<<8); - register SCM z; - if ((tmp>>8) != ((CELLPTR)(CAR(symcell))-heap_org)) - tmp = 0; - NEWCELL(z); - SUBRF(z) = fcn; - CAR(z) = tmp + tc7_subr_2; - CDR(symcell) = macroizer(z); + SCM z = macroizer(scm_maksubr(name, tc7_subr_2, fcn)); + CAR(z) |= (4L << 16); /* Flags result as primitive macro. */ + CDR(symcell) = z; return CAR(symcell); } SCM make_specfun(name, typ) @@ -2526,11 +2985,13 @@ void init_eval() tc16_env = newsmob(&envsmob); init_iprocs(subr1s, tc7_subr_1); init_iprocs(lsubr2s, tc7_lsubr_2); + init_iprocs(subr3s, tc7_subr_3); #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); + make_specfun(s_eval, tc16_eval); i_dot = CAR(sysintern(".", UNDEFINED)); i_arrow = CAR(sysintern("=>", UNDEFINED)); @@ -2561,10 +3022,13 @@ void init_eval() make_synt(s_atapply, makmmacro, m_apply); /* make_synt(s_atcall_cc, makmmacro, m_cont); */ + f_apply_closure = + CDR(sysintern(" apply-closure", + scm_evstr("(let ((ap apply)) (lambda (p . a) (ap p a)))"))); + #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. */ |