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