diff options
Diffstat (limited to 'eval.c')
| -rw-r--r-- | eval.c | 2632 |
1 files changed, 1632 insertions, 1000 deletions
@@ -1,4 +1,4 @@ -/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1997, 1998, 1999 Free Software Foundation, Inc. +/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1997, 1998, 1999, 2002 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 @@ -15,32 +15,32 @@ * 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. + * for additional uses of the text contained in its release of SCM. * - * The exception is that, if you link the GUILE library with other files + * The exception is that, if you link the SCM library with other files * to produce an executable, this does not by itself cause the * resulting executable to be covered by the GNU General Public License. * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. + * linking the SCM library code into it. * * This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU General Public License. * * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy + * Free Software Foundation under the name SCM. If you copy * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does + * SCM, as the General Public License permits, the exception does * not apply to the code that you add in this way. To avoid misleading * anyone as to the status of such modified files, you must delete * this exception notice from them. * - * If you write modifications of your own for GUILE, it is your choice + * If you write modifications of your own for SCM, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ /* "eval.c" eval and apply. - Authors: Aubrey Jaffer & Hugh E. Secker-Walker. */ + Authors: Radey Shouman, Aubrey Jaffer, & Hugh E. Secker-Walker. */ #include "scm.h" #include "setjump.h" @@ -48,7 +48,10 @@ #define I_SYM(x) (CAR((x)-1L)) #define I_VAL(x) (CDR((x)-1L)) #define ATOMP(x) (5==(5 & (int)CAR(x))) -#define EVALCELLCAR(x) (ATOMP(CAR(x))?evalatomcar(x):ceval_1(CAR(x))) +#define EVALCELLCAR(x) (ATOMP(CAR(x))?evalatomcar(x, 0):ceval_1(CAR(x))) +#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)) /* 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 @@ -81,63 +84,106 @@ 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 + If the CAR 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 + no provision for allowing the CDR 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);} +# 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_cons3(a, b, c, d) {scm_env_tmp=cons2((a), (b), cons((c), (d)));} +# define EXTEND_VALENV {scm_env=cons(scm_env_tmp, scm_env);} +# define ENV_V2LST(argc, argv) \ + {scm_env_tmp=scm_v2lst((argc), (argv), scm_env_tmp);} #else -# define EXTEND_ENV scm_extend_env +# define EXTEND_VALENV {scm_extend_env();} +# define ENV_V2LST scm_env_v2lst #endif +#define EXTEND_ENV cons 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, 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 scm_cp_list P((SCM x, int minlen)); +SCM scm_v2lst P((long argc, SCM *argv, SCM end)); +SCM renamed_ident P((SCM id, SCM env)); SCM eqv P((SCM x, SCM y)); SCM scm_multi_set P((SCM syms, SCM vals)); SCM eval_args P((SCM x)); +SCM m_quote P((SCM xorig, SCM env, SCM ctxt)); +SCM m_begin P((SCM xorig, SCM env, SCM ctxt)); +SCM m_if P((SCM xorig, SCM env, SCM ctxt)); +SCM m_set P((SCM xorig, SCM env, SCM ctxt)); +SCM m_and P((SCM xorig, SCM env, SCM ctxt)); +SCM m_or P((SCM xorig, SCM env, SCM ctxt)); +SCM m_cond P((SCM xorig, SCM env, SCM ctxt)); +SCM m_case P((SCM xorig, SCM env, SCM ctxt)); +SCM m_lambda P((SCM xorig, SCM env, SCM ctxt)); +SCM m_letstar P((SCM xorig, SCM env, SCM ctxt)); +SCM m_do P((SCM xorig, SCM env, SCM ctxt)); +SCM m_quasiquote P((SCM xorig, SCM env, SCM ctxt)); +SCM m_delay P((SCM xorig, SCM env, SCM ctxt)); +SCM m_define P((SCM xorig, SCM env, SCM ctxt)); +SCM m_letrec P((SCM xorig, SCM env, SCM ctxt)); +SCM m_let P((SCM xorig, SCM env, SCM ctxt)); +SCM m_apply P((SCM xorig, SCM env, SCM ctxt)); +SCM m_syn_quote P((SCM xorig, SCM env, SCM ctxt)); +SCM m_define_syntax P((SCM xorig, SCM env, SCM ctxt)); +SCM m_let_syntax P((SCM xorig, SCM env, SCM ctxt)); +SCM m_letrec_syntax P((SCM xorig, SCM env, SCM ctxt)); +SCM m_the_macro P((SCM xorig, SCM env, SCM ctxt)); void scm_dynthrow P((SCM cont, SCM val)); void scm_egc P((void)); void scm_estk_grow P((void)); void scm_estk_shrink P((void)); -int badargsp P((SCM proc, SCM args)); +int badargsp P((SCM formals, SCM args)); +static SCM *lookupcar P((SCM vloc)); +static SCM scm_lookupval P((SCM vloc, int memo)); 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 evalatomcar P((SCM x, int toplevelp)); 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, SCM defs)); -static SCM unmemocar P((SCM x)); -static SCM wrapenv P((void)); -static SCM *id_denote P((SCM var)); +static SCM m_body P((SCM xorig, SCM env, SCM ctxt)); +static SCM m_iqq P((SCM form, int depth, SCM env, SCM ctxt)); +static SCM m_parse_let P((SCM imm, SCM xorig, SCM x, SCM *vars, SCM *inits)); +static SCM m_let_null P((SCM body, SCM env, SCM ctxt)); +static SCM m_letrec1 P((SCM imm, SCM xorig, SCM env, SCM ctxt)); +static SCM m_letstar1 P((SCM imm, SCM vars, SCM inits, SCM body, + SCM env, SCM ctxt)); +static SCM macroexp1 P((SCM x, SCM env, SCM ctxt, int mode)); +/* static int checking_defines_p P((SCM ctxt)); */ +/* static SCM wrapenv P((void)); */ +static SCM scm_case_selector P((SCM x)); +static SCM acro_call P((SCM x, SCM env)); +static SCM m_binding P((SCM name, SCM value, SCM env, SCM ctxt)); +static SCM m_bindings P((SCM name, SCM value, SCM env, SCM ctxt)); +static SCM m_seq P((SCM x, SCM env, SCM ctxt)); +static SCM m_expr P((SCM x, SCM env, SCM ctxt)); +static void checked_define P((SCM name, SCM val, char *what)); +static int topdenote_eq P((SCM sym, SCM id, SCM env)); +static int constant_p P((SCM x)); 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)); +#ifdef MAC_INLINE +static int env_depth P((void)); +static void env_tail P((int depth)); +#endif 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)); +static int varcheck P((SCM vars, SCM 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)); +static void debug_env_warn P((char *fnam, int line, char *what)); +static void debug_env_save P((char *fnam, int line)); #endif /* Flush global variable state to estk. */ @@ -150,9 +196,11 @@ static void debug_env_save P((char *fnam, long line)); /* 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 (UNDEFINED==scm_estk_ptr[SCM_ESTK_FRLEN]) scm_estk_grow();\ - else scm_estk_ptr += SCM_ESTK_FRLEN;} +#define ENV_PUSH \ + {DEFER_INTS_EGC; ENV_SAVE;\ + if (UNDEFINED==scm_estk_ptr[SCM_ESTK_FRLEN]) scm_estk_grow();\ + else scm_estk_ptr += SCM_ESTK_FRLEN;\ + STATIC_ENV=scm_estk_ptr[2 - SCM_ESTK_FRLEN];} #define ENV_POP {DEFER_INTS_EGC;\ if (UNDEFINED==scm_estk_ptr[-1]) scm_estk_shrink();\ @@ -163,7 +211,7 @@ static void debug_env_save P((char *fnam, long line)); #else # ifdef CAREFUL_INTS # define EGC_ROOT(x) {if (!ints_disabled) \ - debug_env_warn(__FILE__,__LINE__,"EGC_ROOT"); \ + debug_env_warn(__FILE__, __LINE__, "EGC_ROOT"); \ scm_egc_roots[--scm_egc_root_index] = (x); \ if (0==scm_egc_root_index) scm_egc();} # else @@ -172,41 +220,47 @@ static void debug_env_save P((char *fnam, long line)); # endif #endif -#ifdef CAUTIOUS -SCM scm_trace = UNDEFINED; +#ifndef RECKLESS +SCM scm_trace = BOOL_F; +SCM scm_trace_env = EOL; #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) +#define STATIC_ENV (scm_estk_ptr[2]) #ifdef CAUTIOUS -# define TRACE(x) {scm_estk_ptr[2]=(x);} -# define TOP_TRACE(x) {scm_trace=(x);} -# define PUSH_TRACE TRACE(scm_trace) +# define TRACE(x) {scm_estk_ptr[3]=(x);} +# define TOP_TRACE(x, env) {scm_trace=(x); scm_trace_env=(env);} #else # define TRACE(x) /**/ -# define TOP_TRACE(x) /**/ -# define PUSH_TRACE /**/ +# define TOP_TRACE(x, env) /**/ +#endif +#ifndef RECKLESS +# define MACROEXP_TRACE(x, env) {scm_trace=(x); scm_trace_env=(env);} +#else +# define MACROEXP_TRACE(x, env) /**/ #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)) +#define MAC_TYPE NUMDIGS +#define MAC_PRIMITIVE 0x1L +#define MAC_MEMOIZING 0x2L +#define MAC_ACRO 0x4L +#define MAC_MACRO 0x8L +#define MAC_MMACRO 0x2L +#define MAC_IDMACRO 0x6L +/* uncomment this to experiment with inline procedures + #define MAC_INLINE 0x10L */ #ifdef MACRO long tc16_ident; /* synthetic macro identifier */ -SCM i_mark; static char s_escaped[] = "escaped synthetic identifier"; -# define M_IDENTP(x) (tc16_ident==TYP16(x)) -# define M_IDENT_LEXP(x) ((tc16_ident | (1L<<16))==CAR(x)) -# define IDENTP(x) (SYMBOLP(x) || M_IDENTP(x)) -# define IDENT_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 +# define KEYWORDP(x) (NIMP(x) && IM_KEYWORD==CAR(x)) +# define KEYWORD_MACRO CDR #else -# define IDENTP SYMBOLP -# define M_IDENTP(x) (0) +# define KEYWORDP(x) (NIMP(x) && MACROP(x)) +# define KEYWORD_MACRO(x) (x) #endif /* #define SCM_PROFILE */ @@ -285,12 +339,12 @@ int ecache_p(x) } static void debug_env_warn(fnam, line, what) char *fnam; - long line; + int line; char *what; { lputs(fnam, cur_errp); lputc(':', cur_errp); - intprint(line, 10, cur_errp); + intprint(line+0L, 10, cur_errp); lputs(": unprotected ", cur_errp); lputs(what, cur_errp); lputs(" of ecache value\n", cur_errp); @@ -298,7 +352,7 @@ static void debug_env_warn(fnam, line, what) SCM *debug_env_car(x, fnam, line) SCM x; char *fnam; - long line; + int line; { SCM *ret; if (!ints_disabled && ecache_p(x)) @@ -311,7 +365,7 @@ SCM *debug_env_car(x, fnam, line) SCM *debug_env_cdr(x, fnam, line) SCM x; char *fnam; - long line; + int line; { SCM *ret; if (!ints_disabled && ecache_p(x)) @@ -323,7 +377,7 @@ SCM *debug_env_cdr(x, fnam, line) } static void debug_env_save(fnam, line) char *fnam; - long line; + int line; { if (NIMP(scm_env) && (!scm_cell_p(scm_env))) debug_env_warn(fnam, line, "ENV_SAVE (env)"); @@ -339,18 +393,22 @@ SCM *ilookup(iloc) SCM iloc; { register int ir = IFRAME(iloc); - register SCM er; + register SCM er, *eloc; #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; + /* shortcut the two most common cases. */ + if (iloc==MAKILOC(0, 0)) return &CAR(CAR(er)); + if (iloc==MAKILOC(0, 1)) return &CAR(CDR(CAR(er))); 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)); + eloc = &CAR(er); + for (ir = IDIST(iloc); 0 != ir; --ir) + eloc = &CDR(*eloc); + if ICDRP(iloc) return eloc; + return &CAR(*eloc); } SCM *farlookup(farloc) SCM farloc; @@ -361,163 +419,214 @@ SCM *farlookup(farloc) DEFER_INTS_EGC; er = scm_env; for (ir = INUM(CAR(x)); 0 != ir; --ir) er = CDR(er); + if (0==(ir = INUM(CDR(x)))) { + if (IM_FARLOC_CDR==CAR(farloc)) return &CAR(er); + return &CAR(CAR(er)); + } er = CAR(er); - for (ir = INUM(CDR(x)); 0 != ir; --ir) er = CDR(er); + for(--ir;0 != ir;--ir) er = CDR(er); if (IM_FARLOC_CDR==CAR(farloc)) return &CDR(er); return &CAR(CDR(er)); } -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_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; +char s_badenv[] = "damaged environment"; +static char s_lookup[] = "scm_env_lookup", + s_badkey[] = "Use of keyword as variable", + s_unbnd[] = "unbound variable: ", + s_wtap[] = "Wrong type to apply: ", + s_placement[] = "bad placement"; + +/* + Returns: + a symbol if VAR is not found in STENV, + an ILOC if VAR is bound in STENV, + a list (IM_FARLOC iframe idist) if VAR is bound very deeply in STENV, + a pair (IM_KEYWORD . <macro>) if VAR is a syntax keyword bound in STENV. +*/ +SCM scm_env_lookup(var, stenv) + SCM var, stenv; { - SCM env; + SCM frame, env = stenv; long icdr = 0L; - register SCM *al, fl, var = CAR(vloc); - register unsigned int idist, iframe = 0; + unsigned int idist, iframe = 0; #ifdef MACRO - SCM mark = IDENT_MARK(var); + SCM mark = IDENT_ENV(var); + if (NIMP(mark)) mark = CAR(mark); #endif - DEFER_INTS_EGC; - env = scm_env; - if (NIMP(env) && ENVP(env)) - env = CDR(env); - for(; NIMP(env); env = CDR(env)) { + for (; NIMP(env); env = CDR(env)) { idist = 0; - al = &CAR(env); - fl = CAR(*al); + frame = CAR(env); #ifdef MACRO - if (fl==mark) { + if (frame==mark) { var = IDENT_PARENT(var); - mark = IDENT_MARK(var); + mark = IDENT_ENV(var); + if (NIMP(mark)) mark = CAR(mark); } #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; + if (IMP(frame)) { + if (NULLP(frame)) iframe++; + else if (INUMP(frame)) { #ifndef RECKLESS - fl = CDR(*al); + if (!(NIMP(env) && CONSP(env))) { + badenv: wta(stenv, s_badenv, s_lookup); + } +#endif + env = CDR(env); + } + else { + ASRTGO(SCM_LINUMP(frame), badenv); + } + continue; + } +#ifdef MACRO + if (NIMP(frame) && CONSP(frame) && SCM_ENV_SYNTAX==CAR(frame)) { + /* syntax binding */ + SCM s = assq(var, CDR(frame)); + if (NIMP(s)) return cons(IM_KEYWORD, CDR(s)); + continue; + } #endif + for (; NIMP(frame); frame = CDR(frame)) { + if (NCONSP(frame)) { + if (var==frame) { + icdr = ICDR; 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(fl)) {env = EOL; goto errout;} -# ifdef MACRO - if ((check & LOOKUP_MACROP) - && 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 */ + break; + } + if (CAR(frame)==var) { local_out: +#ifndef TEST_FARLOC + var = MAKILOC(iframe, idist) + icdr; + if (iframe==IFRAME(var) && idist==IDIST(var)) + return var; + else #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 - return icdr ? &CDR(*al) : &CAR(*al); + return cons2(icdr ? IM_FARLOC_CDR : IM_FARLOC_CAR, + MAKINUM(iframe), MAKINUM(idist)); } + ASRTGO(CONSP(frame), badenv); idist++; } iframe++; } + ASRTGO(NULLP(env), badenv); #ifdef MACRO - while M_IDENTP(var) { - ASRTGO(IMP(IDENT_MARK(var)), errout); - var = IDENT_PARENT(var); + while (M_IDENTP(var)) { + if (IMP(IDENT_ENV(var))) + var = IDENT_PARENT(var); + else break; } #endif - var = sym2vcell(var); - gloc_out: -#ifndef RECKLESS - if (NNULLP(env) || ((check & LOOKUP_UNDEFP) && UNBNDP(CDR(var)))) { - var = CAR(var); - errout: - everr(vloc, wrapenv(), var, -# ifdef MACRO - M_IDENTP(var) ? s_escaped : -# endif - (NULLP(env) ? s_unbnd : "damaged environment"), ""); + return var; +} + +/* Throws error for macro keywords and undefined variables, always memoizes. */ +static SCM *lookupcar(vloc) + SCM vloc; +{ + SCM *pv, val, var = CAR(vloc), env = STATIC_ENV; + SCM addr = scm_env_lookup(var, env); + if (IMP(addr) || ISYMP(CAR(addr))) { /* local ref */ + DEFER_INTS_EGC; + pv = IMP(addr) ? ilookup(addr) : farlookup(addr); } -# ifdef MACRO - if ((check & LOOKUP_MACROP) && NIMP(CDR(var)) && MACROP(CDR(var))) { - var = CAR(var); - badkey: everr(vloc, wrapenv(), var, s_badkey, ""); +#ifdef MACRO +# ifndef RECKLESS + else if (NIMP(addr) && IM_KEYWORD==CAR(addr)) { /* local macro binding */ + badkey: wta(var, s_badkey, ""); } # endif #endif - if (check) CAR(vloc) = var + 1; - return &CDR(var); + else { /* global ref */ +#ifdef MACRO + ASSERT(SYMBOLP(addr), var, s_escaped, ""); +#endif + val = sym2vcell(addr); + addr = val + tc3_cons_gloc; + pv = &CDR(val); +#ifdef MACRO + ASRTGO(!KEYWORDP(*pv), badkey); +#endif + } + ASSERT(!UNBNDP(*pv) && undefineds != *pv, var, s_unbnd, ""); + CAR(vloc) = addr; + return pv; } -static SCM unmemocar(form) - SCM form; +/* Throws error for undefined variables, memoizes if memo is non-zero. + For local macros, conses new result. */ +static SCM scm_lookupval(vloc, memo) + SCM vloc; + int memo; { - SCM env; - 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)); - else if ILOCP(CAR(form)) { - for(ir = IFRAME(CAR(form)); ir != 0; --ir) env = CDR(env); - env = CAR(CAR(env)); - for(ir = IDIST(CAR(form));ir != 0;--ir) env = CDR(env); - CAR(form) = ICDRP(CAR(form)) ? env : CAR(env); + SCM val, env = STATIC_ENV, var = CAR(vloc); + SCM addr = scm_env_lookup(var, env); + if (IMP(addr)) { /* local ref */ + DEFER_INTS_EGC; + val = *ilookup(addr); } - return form; +#ifdef MACRO + else if (NIMP(addr) && IM_KEYWORD==CAR(addr)) /* local macro binding */ + val = addr; +#endif + else if (ISYMP(CAR(addr))) { /* local ref (farloc) */ + DEFER_INTS_EGC; + val = *farlookup(addr); + } + else { /* global ref */ +#ifdef MACRO + ASSERT(SYMBOLP(addr), var, s_escaped, ""); +#endif + addr = sym2vcell(addr); + val = CDR(addr); + addr += tc3_cons_gloc; + } + ASSERT(!UNBNDP(val) && val != undefineds, var, s_unbnd, ""); + if (memo && !KEYWORDP(val)) /* Don't memoize forms to be macroexpanded. */ + CAR(vloc) = addr; + return val; } /* CAR(x) is known to be a cell but not a cons */ -static SCM evalatomcar(x) +static SCM evalatomcar(x, toplevelp) SCM x; + int toplevelp; { - SCM r; + SCM ret; switch TYP7(CAR(x)) { default: - everr(x, wrapenv(), CAR(x), "Cannot evaluate: ", ""); - case tcs_symbols: + everr(x, STATIC_ENV, CAR(x), "Cannot evaluate: ", "", 0); lookup: - return *lookupcar(x, LOOKUP_UNDEFP|LOOKUP_MACROP); + case tcs_symbols: + ret = scm_lookupval(x, !0); + if (KEYWORDP(ret)) { + SCM argv[3]; + SCM mac = KEYWORD_MACRO(ret); + argv[0] = CAR(x); + argv[1] = STATIC_ENV; + argv[2] = EOL; + switch (MAC_TYPE(mac) & ~MAC_PRIMITIVE) { + default: +#ifdef MACRO + if (!toplevelp) + everr(x, argv[1], argv[0], s_badkey, "", 0); +#endif + return ret; + case MAC_IDMACRO: + ret = scm_cvapply(CDR(mac), 3L, argv); + CAR(x) = ret; + return evalcar(x); + } + } + return ret; case tc7_vector: #ifndef RECKLESS - if (2 <= verbose) scm_warn("unquoted ", s_vector); + if (2 <= verbose) scm_warn("unquoted ", s_vector, CAR(x)); #endif - r = cons2(IM_QUOTE, CAR(x), EOL); - CAR(x) = r; - return CAR(CDR(r)); + ret = cons2(IM_QUOTE, CAR(x), EOL); + CAR(x) = ret; + return CAR(CDR(ret)); case tc7_smob: #ifdef MACRO if M_IDENTP(CAR(x)) goto lookup; @@ -537,7 +646,7 @@ SCM scm_multi_set(syms, vals) ASSERT(NIMP(vals) && CONSP(vals), vals, WNA, s_set); switch (7 & (int)(CAR(syms))) { case 0: - loc = lookupcar(syms, LOOKUP_UNDEFP|LOOKUP_MACROP); + loc = lookupcar(syms); break; case 1: loc = &(I_VAL(CAR(syms))); @@ -556,6 +665,97 @@ SCM scm_multi_set(syms, vals) return res; } +static SCM scm_case_selector(x) + SCM x; +{ + SCM key, keys, *kv, *av; + SCM actions, offset; + long i, n; + int op = ISYMVAL(CAR(x)); + x = CDR(x); + key = EVALCAR(x); + x = CDR(x); + switch (op) { + default: wta(MAKINUM(op), "internal error", s_case); + case 0: /* linear search */ + keys = CAR(x); + kv = VELTS(keys); + av = VELTS(CAR(CDR(x))); + n = LENGTH(keys); + for (i = n - 1; i > 0; i--) + if (key == kv[i]) return av[i]; +#ifndef INUMS_ONLY + /* Bignum and flonum keys are pessimized. */ + if (NIMP(key) && NUMP(key)) + for (i = n - 1; i > 0; i--) + if (NFALSEP(eqv(kv[i], key))) return av[i]; +#endif + return av[0]; + case 1: /* integer jump table */ + offset = CAR(x); + if (INUMP(key)) + i = INUM(key) - INUM(offset) + 1; + else + i = 0; + jump: + actions = CAR(CDR(x)); + if (i >= 1 && i < LENGTH(actions)) + return VELTS(actions)[i]; + else + return VELTS(actions)[0]; + case 2: /* character jump table */ + offset = CAR(x); + if (ICHRP(key)) + i = ICHR(key) - ICHR(offset) + 1; + else + i = 0; + goto jump; + } +} + +static SCM acro_call(x, env) + SCM x, env; +{ + SCM proc, argv[3]; + x = CDR(x); + proc = scm_lookupval(x, 0); + ASRTGO(KEYWORDP(proc), errout); + proc = KEYWORD_MACRO(proc); + argv[0] = x; + argv[1] = env; + argv[2] = EOL; + switch (MAC_TYPE(proc) & ~MAC_PRIMITIVE) { + default: + errout: wta(proc, CHARS(CAR(x)), "macro expected"); + case MAC_MACRO: + x = scm_cvapply(CDR(proc), 3L, argv); + if (ilength(x) <= 0) + x = cons2(IM_BEGIN, x, EOL); + return x; + case MAC_ACRO: + x = scm_cvapply(CDR(proc), 3L, argv); + return cons2(IM_QUOTE, x, EOL); + } +} + +static SCM toplevel_define(xorig, env) + SCM xorig, env; +{ + SCM x = CDR(xorig); + SCM name = CAR(x); + ASSERT(scm_nullenv_p(env), xorig, s_placement, s_define); + ENV_PUSH; + x = cons(m_binding(name, CAR(CDR(x)), env, EOL), EOL); + x = evalcar(x); + ENV_POP; + checked_define(name, x, s_define); +#ifdef SICP + return name; +#else + return UNSPECIFIED; +#endif +} + SCM eval_args(l) SCM l; { @@ -582,7 +782,7 @@ static void ecache_evalx(x) argv[i++] = EVALCAR(x); x = CDR(x); } - scm_env_v2lst(i, argv); + ENV_V2LST((long)i, argv); } /* result is 1 if right number of arguments, 0 otherwise, @@ -598,12 +798,12 @@ static int ecache_eval_args(proc, arg1, arg2, arg3, x) ecache_evalx(x); else scm_env_tmp = EOL; - scm_env_v2lst(3, argv); + ENV_V2LST(3L, argv); #ifndef RECKLESS - proc = CAR(CODE(proc)); + proc = SCM_ENV_FORMALS(CAR(CODE(proc))); + proc = CDR(proc); proc = CDR(proc); proc = CDR(proc); - proc = CDR(proc); for (; NIMP(proc); proc=CDR(proc)) { if IMP(x) return 0; x = CDR(x); @@ -634,9 +834,23 @@ static SCM asubr_apply(proc, arg1, arg2, arg3, args) arg3 = CAR(args); args = CDR(args); } + default: return UNDEFINED; } } +static char s_values[] = "values"; +static char s_call_wv[] = "call-with-values"; +SCM scm_values(arg1, arg2, rest, what) + SCM arg1, arg2, rest; + char *what; +{ + DEFER_INTS_EGC; + ASSERT(IM_VALUES_TOKEN==scm_env_tmp, UNDEFINED, "one value expected", what); + if (! UNBNDP(arg2)) + scm_env_cons(arg2, rest); + return arg1; +} + /* the following rewrite expressions and * some memoized forms have different syntax */ @@ -648,17 +862,35 @@ 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); +static char s_expr[] = "bad expression"; +#define ASSYNT(_cond, _arg, _pos, _subr)\ + if(!(_cond))scm_experr(_arg, (char *)_pos, _subr); + +/* These symbols are needed by the reader, in repl.c */ +SCM i_dot, i_quote, i_quasiquote, i_unquote, i_uq_splicing; +static SCM i_lambda, i_define, i_let, i_begin, i_arrow, i_else; /* , i_atbind */ +/* These symbols are passed in the context argument to macro expanders. */ +static SCM i_bind, i_anon, i_side_effect, i_test, i_procedure, + i_argument, i_check_defines; -SCM i_dot, i_quote, i_quasiquote, i_lambda, i_define, - i_let, i_arrow, i_else, i_unquote, i_uq_splicing; +static SCM f_begin, f_define; #define ASRTSYNTAX(cond_, msg_) if(!(cond_))wta(xorig, (msg_), what); #ifdef MACRO -# define TOPDENOTE_EQ(sym, x, env) ((sym)==id2sym(x) && TOPLEVELP(x,env)) -# define TOPLEVELP(x,env) (0==id_denote(x)) +# define TOPLEVELP(x, env) (topdenote_eq(UNDEFINED, (x), (env))) +# define TOPDENOTE_EQ topdenote_eq # define TOPRENAME(v) (renamed_ident(v, BOOL_F)) +static int topdenote_eq(sym, id, env) + SCM sym, id, env; +{ + if (UNBNDP(sym)) { + sym = scm_env_lookup(id, env); + return NIMP(sym) && SYMBOLP(sym); + } + return sym==id2sym(id) && sym==scm_env_lookup(id, env); +} + static SCM id2sym(id) SCM id; { @@ -668,36 +900,11 @@ static SCM id2sym(id) return id; } -static SCM *id_denote(var) - SCM var; -{ - register SCM *al, fl; - 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)) { - if (fl==mark) { - var = IDENT_PARENT(var); - mark = IDENT_MARK(var); - } - if NCONSP(fl) - if (fl==var) return &CDR(*al); - else break; - al = &CDR(*al); - if (CAR(fl)==var) return &CAR(*al); - } - } -# ifndef RECKLESS - while M_IDENTP(var) { - ASSERT(IMP(IDENT_MARK(var)), var, s_escaped, ""); - var = IDENT_PARENT(var); - } -# endif - return (SCM *)0; -} +#else /* def MACRO */ +# define TOPDENOTE_EQ(sym, x, env) ((sym)==(x)) +# define TOPLEVELP(x, env) (!0) +# define TOPRENAME(v) (v) +#endif static void unpaint(p) SCM *p; @@ -705,7 +912,12 @@ static void unpaint(p) SCM x; while NIMP((x = *p)) { if CONSP(x) { - if NIMP(CAR(x)) unpaint(&CAR(x)); + if (NIMP(CAR(x))) + unpaint(&CAR(x)); + else if (SCM_LINUMP(CAR(x))) { + *p = CDR(x); + continue; + } p = &CDR(*p); } else if VECTORP(x) { @@ -715,93 +927,111 @@ static void unpaint(p) p = VELTS(x); } else { +#ifdef MACRO while M_IDENTP(x) *p = x = IDENT_PARENT(x); +#endif return; } } } -#else /* def MACRO */ -# define TOPDENOTE_EQ(sym, x, env) ((sym)==(x)) -# define TOPLEVELP(x,env) (!0) -# define TOPRENAME(v) (v) -#endif -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 m_quote(xorig, env, ctxt) + SCM xorig, env, ctxt; { SCM x = copytree(CDR(xorig)); ASSYNT(ilength(CDR(xorig))==1, xorig, s_expression, s_quote); -#ifdef MACRO DEFER_INTS; unpaint(&CAR(x)); ALLOW_INTS; -#endif return cons(IM_QUOTE, x); } -SCM m_begin(xorig, env) - SCM xorig, env; +SCM m_begin(xorig, env, ctxt) + SCM xorig, env, ctxt; { - ASSYNT(ilength(CDR(xorig)) >= 1, xorig, s_expression, s_begin); + int len = ilength(CDR(xorig)); + if (0==len) return cons2(IM_BEGIN, UNSPECIFIED, EOL); + if (1==len) return CAR(CDR(xorig)); + ASSYNT(len >= 1, xorig, s_expression, s_begin); return cons(IM_BEGIN, CDR(xorig)); } -SCM m_if(xorig, env) - SCM xorig, env; +static int constant_p(x) + SCM x; { - int len = ilength(CDR(xorig)); + return IMP(x) ? !0 : (CONSP(x) ? 0 : !IDENTP(x)); +} + +SCM m_if(xorig, env, ctxt) + SCM xorig, env, ctxt; +{ + SCM test, x = CDR(xorig); + int len = ilength(x); ASSYNT(len >= 2 && len <= 3, xorig, s_expression, s_if); - return cons(IM_IF, CDR(xorig)); + test = CAR(x); + x = CDR(x); + if (FALSEP(test)) + return 3==len ? CAR(CDR(x)) : UNSPECIFIED; + if (constant_p(test)) + return CAR(x); + return cons2(IM_IF, m_expr(test, env, i_test), + cons(m_expr(CAR(x), env, ctxt), + NULLP(CDR(x)) ? EOL : + cons(m_expr(CAR(CDR(x)), env, ctxt), EOL))); } -SCM m_set(xorig, env) - SCM xorig, env; +SCM m_set(xorig, env, ctxt) + SCM xorig, env, ctxt; { - SCM x = CDR(xorig); + SCM var, x = CDR(xorig); ASSYNT(2==ilength(x), xorig, s_expression, s_set); - varcheck(xorig, - (NIMP(CAR(x)) && IDENTP(CAR(x))) ? CAR(x) : + varcheck((NIMP(CAR(x)) && IDENTP(CAR(x))) ? CAR(x) : (ilength(CAR(x)) > 0) ? CAR(x) : UNDEFINED, - s_set, s_variable); - return cons(IM_SET, x); + IM_SET, s_variable); + var = CAR(x); + x = CDR(x); + return cons(IM_SET, cons2(var, m_expr(CAR(x), env, ctxt), EOL)); } -SCM m_and(xorig, env) - SCM xorig, env; +SCM m_and(xorig, env, ctxt) + SCM xorig, env, ctxt; { - int len = ilength(CDR(xorig)); + SCM x = CDR(xorig); + int len = ilength(x); ASSYNT(len >= 0, xorig, s_test, s_and); + tail: switch (len) { - default: return cons(IM_AND, CDR(xorig)); - case 1: return CAR(CDR(xorig)); + default: + if (FALSEP(CAR(x))) return BOOL_F; + if (constant_p(CAR(x))) { + x = CDR(x); + len--; + goto tail; + } + return cons(IM_AND, x); + case 1: return CAR(x); case 0: return BOOL_T; } } -SCM m_or(xorig, env) - SCM xorig, env; +SCM m_or(xorig, env, ctxt) + SCM xorig, env, ctxt; { - int len = ilength(CDR(xorig)); + SCM x = CDR(xorig); + int len = ilength(x); ASSYNT(len >= 0, xorig, s_test, s_or); + tail: switch (len) { - default: return cons(IM_OR, CDR(xorig)); - case 1: return CAR(CDR(xorig)); + default: + if (FALSEP(CAR(x))) { + x = CDR(x); + len--; + goto tail; + } + if (constant_p(CAR(x))) + return CAR(x); + return cons(IM_OR, x); + case 1: return CAR(x); case 0: return BOOL_F; } } @@ -809,84 +1039,114 @@ SCM m_or(xorig, env) #ifdef INUMS_ONLY # define memv memq #endif -SCM m_case(xorig, env) - SCM xorig, env; +static SCM *loc_atcase_aux = 0; +static int in_atcase_aux = 0; +SCM m_case(xorig, env, ctxt) + SCM xorig, env, ctxt; { - SCM clause, cdrx = copy_list(CDR(xorig), 2), x = cdrx; -#ifndef RECKLESS - SCM s, keys = EOL; -#endif - ASSYNT(!UNBNDP(cdrx), xorig, s_clauses, s_case); + SCM clause, x = CDR(xorig), key_expr = CAR(x); + SCM s, keys = EOL, action, actions = EOL, else_action = list_unspecified; + int opt = !scm_nullenv_p(env); + ASSYNT(ilength(x) >= 2, xorig, s_clauses, s_case); while(NIMP(x = CDR(x))) { clause = CAR(x); - ASSYNT(ilength(clause) >= 2, xorig, s_clauses, s_case); - if TOPDENOTE_EQ(i_else, CAR(clause), env) { + s = scm_check_linum(clause, 0L); + ASSYNT(ilength(clause) >= 2, clause /* xorig */, s_clauses, s_case); + clause = s; + 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_action = m_seq(CDR(clause), env, ctxt); } else { + s = scm_check_linum(CAR(clause), 0L); #ifdef MACRO - SCM c = copy_list(CAR(clause), 0); - ASSYNT(!UNBNDP(c), xorig, s_clauses, s_case); - clause = cons(c, CDR(clause)); + s = scm_cp_list(s, 0); + ASSYNT(!UNBNDP(s), CAR(clause) /* xorig */, s_clauses, s_case); DEFER_INTS; - unpaint(&CAR(clause)); + unpaint(&s); 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 + ASSYNT(ilength(s) >= 0, CAR(clause) /* xorig */, s_clauses, s_case); +#endif + action = m_seq(CDR(clause), env, ctxt); + for (; NIMP(s); s = CDR(s)) { + ASSYNT(FALSEP(memv(CAR(s), keys)), xorig, "duplicate key value", s_case); + if (NIMP(CAR(s)) && NUMP(CAR(s))) opt = 0; + keys = cons(CAR(s), keys); + actions = cons(action, actions); + } + } + } + key_expr = m_expr(key_expr, env, i_test); + if (opt && NIMP(*loc_atcase_aux) && !in_atcase_aux) { + SCM argv[3]; + argv[0] = keys; + argv[1] = actions; + argv[2] = else_action; + in_atcase_aux = !0; + x = scm_cvapply(*loc_atcase_aux, 3L, argv); + in_atcase_aux = 0; /* disabled after one error. C'est la vie. */ + if (NIMP(x) && CONSP(x)) { + s = CAR(x); + if (INUMP(s) && INUM(s) >= 0 && INUM(s) <= 2) + return cons2(MAKISYMVAL(IM_CASE, INUM(s)), key_expr, CDR(x)); } } - return cons(IM_CASE, cdrx); + keys = cons(UNSPECIFIED, keys); + actions = cons(else_action, actions); + return cons2(IM_CASE, key_expr, + cons2(vector(keys), vector(actions), EOL)); } -SCM m_cond(xorig, env) - SCM xorig, env; +SCM m_cond(xorig, env, ctxt) + SCM xorig, env, ctxt; { - SCM arg1, cdrx = copy_list(CDR(xorig), 1), x = cdrx; + SCM s, clause, cdrx = scm_cp_list(CDR(xorig), 1), x = cdrx; int len = ilength(x); ASSYNT(!UNBNDP(cdrx), xorig, s_clauses, s_cond); while(NIMP(x)) { - arg1 = CAR(x); - len = ilength(arg1); - ASSYNT(len >= 1, xorig, s_clauses, s_cond); - if TOPDENOTE_EQ(i_else, CAR(arg1), env) { + clause = scm_check_linum(CAR(x), 0L); + len = ilength(clause); + ASSYNT(len >= 1, CAR(x), s_clauses, s_cond); + if (TOPDENOTE_EQ(i_else, CAR(clause), env)) { ASSYNT(NULLP(CDR(x)) && len >= 2, xorig, s_bad_else_clause, s_cond); - CAR(x) = cons(BOOL_T, CDR(arg1)); + clause = cons(BOOL_T, m_seq(CDR(clause), env, ctxt)); } 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)); + s = CDR(clause); + if (len >= 2 && TOPDENOTE_EQ(i_arrow, CAR(s), env)) { + ASSYNT(3==len && NIMP(CAR(CDR(s))), clause, "bad recipient", s_cond); + clause = cons2(CAR(clause), IM_ARROW, CDR(s)); } + else + clause = cons(CAR(clause), m_seq(s, env, ctxt)); } + CAR(x) = clause; x = CDR(x); } return cons(IM_COND, cdrx); } -static int varcheck(xorig, vars, op, what) - SCM xorig, vars; - char *op, *what; +static int varcheck(vars, op, what) + SCM vars, op; + char *what; { SCM v1, vs; + char *opstr = ISYMCHARS(op) + 2; int argc = 0; + vars = scm_check_linum(vars, 0L); for (; NIMP(vars) && CONSP(vars); vars = CDR(vars)) { argc++; #ifndef RECKLESS v1 = CAR(vars); if (IMP(v1) || !IDENTP(v1)) - badvar: wta(xorig, what, op); + badvar: scm_experr(v1, what, opstr); for (vs = CDR(vars); NIMP(vs) && CONSP(vs); vs = CDR(vs)) { - if (v1==CAR(vs)) - nonuniq: wta(xorig, "non-unique bindings", op); + if (v1==CAR(vs)) { + nonuniq: + what = "non-unique bindings"; + goto badvar; + } } if (v1==vs) goto nonuniq; #endif @@ -896,35 +1156,122 @@ static int varcheck(xorig, vars, op, what) ASRTGO(NIMP(vars) && IDENTP(vars), badvar); return argc > 2 ? 2 : argc; } -SCM m_lambda(xorig, env) - SCM xorig, env; + +SCM m_lambda(xorig, env, ctxt) + SCM xorig, env, ctxt; { - SCM x = CDR(xorig); + SCM x = CDR(xorig), formals; +#ifdef CAUTIOUS + SCM name, linum; +#endif int argc; - ASSERT(ilength(x) > 1, xorig, s_formals, s_lambda); - argc = varcheck(xorig, CAR(x), s_lambda, s_formals); + ASSERT(ilength(x) > 1, x, s_body, s_lambda); + formals = CAR(x); + argc = varcheck(formals, IM_LAMBDA, s_formals); + formals = scm_check_linum(formals, 0L); if (argc > 3) argc = 3; - return cons2(MAKISYMVAL(IM_LAMBDA, argc), CAR(x), - m_body(IM_LAMBDA, CDR(x), s_lambda)); + x = CDR(x); + if (NIMP(CDR(x)) && NIMP(CAR(x)) && STRINGP(CAR(x))) { + env = scm_env_addprop(SCM_ENV_DOC, CAR(x), env); + x = CDR(x); + } +#ifdef CAUTIOUS + if (NIMP(ctxt) && i_bind==CAR(ctxt)) { + ctxt = CDR(ctxt); + name = CAR(ctxt); + } + else + name = i_anon; + if (NIMP(scm_trace) && xorig==scm_check_linum(scm_trace, &linum)) + if (!UNBNDP(linum)) env = EXTEND_ENV(linum, env); + env = scm_env_addprop(SCM_ENV_PROCNAME, name, env); +#endif + env = EXTEND_ENV(formals, env); + return cons2(MAKISYMVAL(IM_LAMBDA, argc), env, m_body(x, env, EOL)); +} + +#ifdef MAC_INLINE +static int env_depth() +{ + register int depth = 0; + register SCM env; + DEFER_INTS_EGC; + env = scm_env; + while(NIMP(env)) { + env = CDR(env); + depth++; + } + return depth; } -SCM m_letstar(xorig, env) +static void env_tail(depth) + int depth; +{ + register SCM env; + DEFER_INTS_EGC; + env = scm_env; + while(depth--) env = CDR(env); + scm_env = env; +} +/* FIXME update for split-env */ +SCM m_inline_lambda(xorig, env) SCM xorig, env; { - SCM x = CDR(xorig), arg1, proc, vars = EOL, *varloc = &vars; - int len = ilength(x); - ASSYNT(len >= 2, xorig, s_body, s_letstar); - proc = CAR(x); - ASSYNT(ilength(proc) >= 0, xorig, s_bindings, s_letstar); - while NIMP(proc) { - arg1 = CAR(proc); - ASSYNT(2==ilength(arg1), xorig, s_bindings, s_letstar); - ASSYNT(NIMP(CAR(arg1)) && IDENTP(CAR(arg1)), xorig, s_variable, s_letstar); - *varloc = cons2(CAR(arg1), CAR(CDR(arg1)), EOL); - varloc = &CDR(CDR(*varloc)); - proc = CDR(proc); + SCM x = CDR(xorig); + SCM typ = (SCM)(tc16_macro | (MAC_INLINE << 16)); + int depth = env_depth(); + ASSERT(ilength(x) > 1, xorig, s_formals, s_lambda); + ASSERT(ilength(CAR(x)) >= 0, xorig, s_formals, s_lambda); + varcheck(CAR(x), IM_LAMBDA, s_formals); + x = cons2(typ, MAKINUM((long)depth), + cons(CAR(x), m_body(CDR(x), env))); + return cons2(IM_QUOTE, x, EOL); +} +#endif + +static char s_nullenv_p[] = "scm_nullenv_p"; +int scm_nullenv_p(env) + SCM env; +{ + SCM fr, e; + if (IMP(env)) return !0; + for (e = env; NIMP(e); e = CDR(e)) { + ASSERT(CONSP(e), e, s_badenv, s_nullenv_p); + fr = CAR(e); + if (IMP(fr)) { + if (NULLP(fr)) return 0; + if (INUMP(fr)) { /* These frames are for meta-data, not bindings. */ + e = CDR(e); + ASSERT(NIMP(e), env, s_badenv, s_nullenv_p); + } + } else return 0; } - x = cons(vars, CDR(x)); - return cons2(IM_LETSTAR, CAR(x), m_body(IM_LETSTAR, CDR(x), s_letstar)); + return !0; +} +static SCM m_letstar1(imm, vars, inits, body, env, ctxt) + SCM imm, vars, inits, body, env, ctxt; +{ + SCM init, bdgs = cons(env, EOL); /* initial env is for debug printing. */ + SCM *loc = &CDR(bdgs); + while (NIMP(vars)) { + init = m_binding(CAR(vars), CAR(inits), env, ctxt); + env = EXTEND_ENV(CAR(vars), env); + *loc = cons2(init, env, EOL); + loc = &CDR(CDR(*loc)); + vars = CDR(vars); + inits = CDR(inits); + } + return cons2(IM_LETSTAR, bdgs, m_body(body, env, ctxt)); +} + +SCM m_letstar(xorig, env, ctxt) + SCM xorig, env, ctxt; +{ + SCM vars, inits; + SCM body = m_parse_let(EOL, xorig, CDR(xorig), &vars, &inits); + /* IM_LETSTAR must bind at least one variable. */ + if (IMP(vars)) + return m_let_null(body, env, ctxt); + return m_letstar1(IM_LETSTAR, vars, inits, body, env, ctxt); } /* DO gets the most radically altered syntax @@ -940,33 +1287,40 @@ SCM m_letstar(xorig, env) (<body>) <stepn> ... <step2> <step1>) ;; missing steps replaced by var */ -SCM m_do(xorig, env) - SCM xorig, env; +SCM m_do(xorig, env, ctxt) + SCM xorig, env, ctxt; { - SCM x = CDR(xorig), arg1, proc; + SCM x = CDR(xorig), bdg, bdgs, test, body; SCM vars = IM_DO, inits = EOL, steps = EOL; int len = ilength(x); ASSYNT(len >= 2, xorig, s_test, s_do); - proc = CAR(x); - ASSYNT(ilength(proc) >= 0, xorig, s_bindings, s_do); - while NIMP(proc) { - arg1 = CAR(proc); - len = ilength(arg1); - ASSYNT(2==len || 3==len, xorig, s_bindings, s_do); - /* vars reversed here, inits and steps reversed at evaluation */ - vars = cons(CAR(arg1), vars); /* variable */ - arg1 = CDR(arg1); - inits = cons(CAR(arg1), inits); - arg1 = CDR(arg1); - steps = cons(IMP(arg1)?CAR(vars):CAR(arg1), steps); - proc = CDR(proc); + bdgs = scm_check_linum(CAR(x), 0L); + ASSYNT(ilength(bdgs) >= 0, CAR(x), s_bindings, s_do); + while NIMP(bdgs) { + bdg = scm_check_linum(CAR(bdgs), 0L); + len = ilength(bdg); + ASSYNT(2==len || 3==len, CAR(bdgs), s_bindings, s_do); + vars = cons(CAR(bdg), vars); /* variable */ + bdg = CDR(bdg); + inits = cons(CAR(bdg), inits); + bdg = CDR(bdg); + steps = cons(IMP(bdg) ? CAR(vars) : CAR(bdg), steps); + bdgs = CDR(bdgs); } + if (IMP(vars)) vars = EOL; + inits = m_bindings(vars, inits, env, ctxt); + env = EXTEND_ENV(vars, env); + steps = m_bindings(vars, steps, env, ctxt); x = CDR(x); - ASSYNT(ilength(CAR(x)) >= 1, xorig, s_test, s_do); + test = scm_check_linum(CAR(x), 0L); + ASSYNT(ilength(test) >= 1, CAR(x), s_test, s_do); + test = m_seq(test, env, ctxt); + if (IMP(CDR(test))) test = cons(CAR(test), list_unspecified); 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); + varcheck(vars, IM_DO, s_variable); + body = scm_check_linum(CDR(x), 0L); + x = cons2(test, m_seq(body, env, i_side_effect), steps); + x = cons2(env, inits, x); return cons(IM_DO, x); } @@ -1000,8 +1354,8 @@ static SCM iqq(form) return cons(iqq(CAR(form)), iqq(CDR(form))); } -static SCM m_iqq(form, depth, env) - SCM form, env; +static SCM m_iqq(form, depth, env, ctxt) + SCM form, env, ctxt; int depth; { SCM tmp; @@ -1012,7 +1366,7 @@ static SCM m_iqq(form, depth, env) SCM *data = VELTS(form); tmp = EOL; for(;--i >= 0;) tmp = cons(data[i], tmp); - tmp = m_iqq(tmp, depth, env); + tmp = m_iqq(tmp, depth, env, ctxt); for(i = 0; i < LENGTH(form); i++) { data[i] = CAR(tmp); tmp = CDR(tmp); @@ -1025,7 +1379,8 @@ static SCM m_iqq(form, depth, env) #endif return form; } - tmp = CAR(form); + form = scm_check_linum(form, 0L); /* needed? */ + tmp = scm_check_linum(CAR(form), 0L); if NIMP(tmp) { if IDENTP(tmp) { #ifdef MACRO @@ -1033,49 +1388,46 @@ static SCM m_iqq(form, depth, env) #endif if (i_quasiquote==tmp && TOPLEVELP(CAR(form), env)) { depth++; - if (0==depth) CAR(form) = IM_QUASIQUOTE; + if (0==depth) tmp = IM_QUASIQUOTE; goto label; } - if (i_unquote==tmp && TOPLEVELP(CAR(form), env)) { + else if (i_unquote==tmp && TOPLEVELP(CAR(form), env)) { --depth; - if (0==depth) CAR(form) = IM_UNQUOTE; + if (0==depth) tmp = IM_UNQUOTE; label: - tmp = CDR(form); - ASSERT(NIMP(tmp) && ECONSP(tmp) && NULLP(CDR(tmp)), - tmp, ARG1, s_quasiquote); - if (0!=depth) CAR(tmp) = m_iqq(CAR(tmp), depth, env); - return form; + form = CDR(form); + ASSERT(NIMP(form) && ECONSP(form) && NULLP(CDR(form)), + form, ARG1, s_quasiquote); + if (0!=depth) + form = cons(m_iqq(CAR(form), depth, env, ctxt), EOL); + return cons(tmp, form); } } else { - if TOPDENOTE_EQ(i_uq_splicing, CAR(tmp), env) { - if (0==--edepth) { - CAR(tmp) = IM_UQ_SPLICING; - CDR(form) = m_iqq(CDR(form), depth, env); - return form; - } + if (TOPDENOTE_EQ(i_uq_splicing, CAR(tmp), env)) { + if (0==--edepth) + return cons(cons(IM_UQ_SPLICING, CDR(tmp)), + m_iqq(CDR(form), depth, env, ctxt)); } - CAR(form) = m_iqq(tmp, edepth, env); + tmp = m_iqq(tmp, edepth, env, ctxt); } } - CAR(form) = tmp; - CDR(form) = m_iqq(CDR(form), depth, env); - return form; + return cons(tmp, m_iqq(CDR(form), depth, env, ctxt)); } -SCM m_quasiquote(xorig, env) - SCM xorig, env; +SCM m_quasiquote(xorig, env, ctxt) + SCM xorig, env, ctxt; { SCM x = CDR(xorig); ASSYNT(ilength(x)==1, xorig, s_expression, s_quasiquote); - x = m_iqq(copytree(x), 1, env); + x = m_iqq(x, 1, env, ctxt); return cons(IM_QUASIQUOTE, x); } -SCM m_delay(xorig, env) - SCM xorig, env; +SCM m_delay(xorig, env, ctxt) + SCM xorig, env, ctxt; { ASSYNT(ilength(xorig)==2, xorig, s_expression, s_delay); - return cons2(IM_DELAY, EOL, CDR(xorig)); + return cons2(IM_DELAY, EXTEND_ENV(EOL, env), CDR(xorig)); } static int built_inp(name, x) @@ -1092,229 +1444,450 @@ static int built_inp(name, x) return 0; } -SCM m_define(x, env) - SCM x, env; +static void checked_define(name, val, what) + SCM name, val; + char *what; { - SCM proc, arg1 = x; x = CDR(x); - /* ASSYNT(NULLP(env), x, "bad placement", s_define);*/ - ASSYNT(ilength(x) >= 2, arg1, s_expression, s_define); - proc = CAR(x); x = CDR(x); - while (NIMP(proc) && CONSP(proc)) { /* nested define syntax */ - x = cons(cons2(TOPRENAME(i_lambda), CDR(proc), x), EOL); - proc = CAR(proc); - } - ASSYNT(NIMP(proc) && IDENTP(proc), arg1, s_variable, s_define); - ASSYNT(1==ilength(x), arg1, s_expression, s_define); - if (NIMP(env) && ENVP(env)) { - DEFER_INTS_EGC; - env = CDR(env); - } - if NULLP(env) { - x = evalcar(x); + SCM old, vcell; #ifdef MACRO - while M_IDENTP(proc) { - ASSYNT(IMP(IDENT_MARK(proc)), proc, s_escaped, s_define); - proc = IDENT_PARENT(proc); - } + while (M_IDENTP(name)) { + ASSERT(IMP(IDENT_ENV(name)), name, s_escaped, what); + name = IDENT_PARENT(name); + } #endif - arg1 = sym2vcell(proc); + vcell = sym2vcell(name); + old = CDR(vcell); #ifndef RECKLESS - if (2 <= verbose && - built_inp(proc, CDR(arg1)) - && (CDR(arg1) != x)) - scm_warn("redefining built-in ", CHARS(proc)); - else -#endif - if (5 <= verbose && UNDEFINED != CDR(arg1)) - scm_warn("redefining ", CHARS(proc)); - CDR(arg1) = x; -#ifdef SICP - return m_quote(cons2(i_quote, CAR(arg1), EOL), EOL); -#else - return UNSPECIFIED; -#endif + if ('@'==CHARS(name)[0] && UNDEFINED != old) + scm_warn("redefining internal name ", "", name); + if (KEYWORDP(old)) { + if (1 <= verbose && built_inp(name, KEYWORD_MACRO(old))) + scm_warn("redefining built-in syntax ", "", name); + else if (3 <= verbose) + scm_warn("redefining syntax ", "", name); + } + else if (2 <= verbose && built_inp(name, old) && (old != val)) + scm_warn("redefining built-in ", "", name); + else if (5 <= verbose && UNDEFINED != old) + scm_warn("redefining ", "", name); +#endif + CDR(vcell) = val; +} + +SCM m_define(xorig, env, ctxt) + SCM xorig, env, ctxt; +{ + SCM name, linum, x = CDR(xorig); + ASSYNT(ilength(x) >= 2, xorig, s_expression, s_define); + name = CAR(x); x = CDR(x); + while (NIMP(name) && CONSP(name)) { /* nested define syntax */ + name = scm_check_linum(name, &linum); + x = scm_add_linum(linum, cons2(TOPRENAME(i_lambda), CDR(name), x)); + x = cons(x, EOL); + name = CAR(name); } - return cons2(IM_DEFINE, proc, x); + ASSYNT(NIMP(name) && IDENTP(name), xorig, s_variable, s_define); + ASSYNT(1==ilength(x), xorig, s_expression, s_define); + return cons2(IM_DEFINE, name, x); } /* end of acros */ -static SCM m_letrec1(op, imm, xorig, env) - SCM op, imm, xorig, env; +/* returns body, x should be cdr of a LET, LET*, or LETREC form. + vars and inits are returned in the original order. */ +static SCM m_parse_let(imm, xorig, x, vars, inits) + SCM imm, xorig, x, *vars, *inits; { - SCM cdrx = CDR(xorig); /* locally mutable version of form */ + SCM clause, bdgs, *varloc = vars, *initloc = inits; + int len = ilength(x); +#ifdef MACRO + char *what = CHARS(ident2sym(CAR(xorig))); +#else char *what = CHARS(CAR(xorig)); - SCM x = cdrx, proc, arg1; /* structure traversers */ - SCM vars = imm, inits = EOL; - /* ASRTSYNTAX(ilength(x) >= 2, s_body); */ - proc = CAR(x); - ASRTSYNTAX(ilength(proc) >= 1, s_bindings); - do { - arg1 = CAR(proc); - ASRTSYNTAX(2==ilength(arg1), s_bindings); - vars = cons(CAR(arg1), vars); - 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))); +#endif + *varloc = imm; + *initloc = EOL; + ASSYNT(len >= 2, UNDEFINED, s_body, what); + bdgs = scm_check_linum(CAR(x), 0L); + ASSYNT(ilength(bdgs) >= 0, bdgs, s_bindings, what); + while NIMP(bdgs) { + clause = scm_check_linum(CAR(bdgs), 0L); + ASSYNT(2==ilength(clause), clause, s_bindings, what); + ASSYNT(NIMP(CAR(clause)) && IDENTP(CAR(clause)), CAR(clause), + s_variable, what); + *varloc = cons(CAR(clause), imm); + varloc = &CDR(*varloc); + *initloc = cons(CAR(CDR(clause)), EOL); + initloc = &CDR(*initloc); + bdgs = CDR(bdgs); + } + x = CDR(x); + ASSYNT(ilength(x)>0, scm_wrapcode(x, EOL) /* xorig */, s_body, what); + if (IMP(*vars)) *vars = EOL; + return x; } -SCM m_letrec(xorig, env) - SCM xorig, env; +static SCM m_let_null(body, env, ctxt) + SCM body, env, ctxt; { - 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 x; + if (scm_nullenv_p(env)) { + env = EXTEND_ENV(EOL, env); + return cons2(IM_LET, env, cons(EOL, m_body(body, env, ctxt))); + } + x = m_body(body, env, ctxt); + return NULLP(CDR(x)) ? CAR(x) : cons(IM_BEGIN, x); } -SCM m_let(xorig, env) - SCM xorig, env; +static SCM m_letrec1(imm, xorig, env, ctxt) + SCM imm, xorig, env, ctxt; +{ + SCM vars, inits, op = MAKSPCSYM2(IM_LETREC, imm); + SCM body = m_parse_let(imm, xorig, CDR(xorig), &vars, &inits); + if (IMP(vars)) return m_let_null(body, env, ctxt); + varcheck(vars, imm, s_variable); + env = EXTEND_ENV(vars, env); + inits = m_bindings(vars, inits, env, ctxt); + return cons2(op, env, cons(inits, m_body(body, env, ctxt))); +} + +SCM m_letrec(xorig, env, ctxt) + SCM xorig, env, ctxt; { - SCM cdrx = CDR(xorig); /* locally mutable version of form */ - SCM x = cdrx, proc, arg1, name; /* structure traversers */ - SCM vars = IM_LET, inits = EOL, *varloc = &vars, *initloc = &inits; + return m_letrec1(IM_LETREC, xorig, env, ctxt); +} +SCM m_let(xorig, env, ctxt) + SCM xorig, env, ctxt; +{ + SCM proc, body, vars, inits, x = CDR(xorig); ASSYNT(ilength(x) >= 2, xorig, s_body, s_let); proc = CAR(x); - 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(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 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); - ASSYNT(ilength(x) >= 2, xorig, s_body, s_let); - proc = CAR(x); /* bindings list */ - ASSYNT(ilength(proc) >= 0, xorig, s_bindings, s_let); - while NIMP(proc) { /* vars and inits both in order */ - arg1 = CAR(proc); - ASSYNT(2==ilength(arg1), xorig, s_bindings, s_let); - ASSYNT(NIMP(CAR(arg1)) && IDENTP(CAR(arg1)), xorig, s_variable, s_let); - *varloc = cons(CAR(arg1), IM_LET); - varloc = &CDR(*varloc); - *initloc = cons(CAR(CDR(arg1)), EOL); - initloc = &CDR(*initloc); - proc = CDR(proc); + if (NIMP(proc) && IDENTP(proc)) { /* named let, build equiv letrec */ + x = CDR(x); + body = m_parse_let(IM_LET, xorig, x, &vars, &inits); + x = cons2(TOPRENAME(i_lambda), vars, body); + x = cons2(i_let, cons(cons2(proc, x, EOL), EOL), cons(proc, EOL)); + return cons(m_letrec1(IM_LET, x, env, ctxt), inits); } - proc = cons2(TOPRENAME(i_lambda), vars, m_body(IM_LET, CDR(x), s_let)); - proc = cons2(i_let, cons(cons2(name, proc, EOL), EOL), cons(name, EOL)); - return cons(m_letrec1(IM_LETREC, IM_LET, proc, env), inits); + /* vanilla let */ + body = m_parse_let(IM_LET, xorig, x, &vars, &inits); + varcheck(vars, IM_LET, s_variable); + if (IMP(vars)) + return m_let_null(body, env, ctxt); + if (IMP(CDR(vars))) /* single binding, let* is faster */ + return m_letstar1(IM_LET, vars, inits, body, env, ctxt); + inits = m_bindings(vars, inits, env, ctxt); + env = EXTEND_ENV(vars, env); + return cons2(IM_LET, env, cons(inits, m_body(body, env, ctxt))); } #define s_atapply (ISYMCHARS(IM_APPLY)+1) -SCM m_apply(xorig, env) - SCM xorig, env; +SCM m_apply(xorig, env, ctxt) + SCM xorig, env, ctxt; { ASSYNT(ilength(CDR(xorig))==2, xorig, s_expression, s_atapply); return cons(IM_APPLY, CDR(xorig)); } -static SCM m_expand_body(xorig) - SCM xorig; +static SCM m_body(xorig, env, ctxt) + SCM xorig, env, ctxt; { - SCM form, x = CDR(xorig), defs = EOL; + SCM form, denv = env, x = xorig, defs = EOL; char *what = ISYMCHARS(CAR(xorig)) + 2; + ASRTSYNTAX(ilength(xorig) >= 1, s_expression); while NIMP(x) { - form = CAR(x); + form = scm_check_linum(CAR(x), 0L); if (IMP(form) || NCONSP(form)) break; if IMP(CAR(form)) break; if (! IDENTP(CAR(form))) break; - form = macroexp1(form, defs); + form = macroexp1(CAR(x), denv, i_check_defines, 1); if (IM_DEFINE==CAR(form)) { defs = cons(CDR(form), defs); x = CDR(x); } + else if (IM_BEGIN==CAR(form)) { + form = CDR(form); + x = CDR(x); + if (IMP(x)) + x = form; + else if (UNSPECIFIED==CAR(form) && IMP(CDR(form))) + ; + else + x = append(cons2(form, x, EOL)); + } else if NIMP(defs) { break; } - else if (IM_BEGIN==CAR(form)) { - x = append(cons2(CDR(form), CDR(x), EOL)); - } else { + /* Doesn't work when m_body recursively called + x = cons(form, m_seq(CDR(x), env, ctxt)); */ 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; +#ifdef CAUTIOUS + ASSYNT(ilength(x) > 0, x, s_body, what); +#else + ASSYNT(ilength(x) > 0, CDR(xorig), s_body, what); +#endif + if (IMP(defs)) return x; + return cons(m_letrec1(IM_DEFINE, cons2(i_define, defs, x), env, ctxt), EOL); } -static SCM macroexp1(x, defs) - SCM x, defs; +static SCM m_binding(name, value, env, ctxt) + SCM name, value, env, ctxt; { - SCM res = UNDEFINED, proc = CAR(x); - int argc; - ASRTGO(IDENTP(proc), badfun); + if (IMP(value) || NCONSP(value)) return value; + ctxt = cons2(i_bind, name, EOL); + return macroexp1(value, env, ctxt, 2); +} +static SCM m_bindings(names, values, env, ctxt) + SCM names, values, env, ctxt; +{ + SCM x; + for (x = values; NIMP(x); x = CDR(x)) { + CAR(x) = m_binding(CAR(names), CAR(x), env, ctxt); + names = CDR(names); + } + return values; +} +static SCM m_seq(x, env, ctxt) + SCM x, env, ctxt; +{ + SCM form, ret = EOL, *loc = &ret; + for (; NIMP(x); x = CDR(x)) { + form = CAR(x); + if (NIMP(form) && CONSP(form)) { + form = macroexp1(form, env, IMP(CDR(x)) ? ctxt : i_side_effect, 2); + if (NIMP(form) && IM_BEGIN==CAR(form)) { + x = append(cons2(form, CDR(x), EOL)); + continue; + } + } + *loc = cons(form, EOL); + loc = &CDR(*loc); + } + return ret; +} +static SCM m_expr(x, env, ctxt) + SCM x, env, ctxt; +{ + if (NIMP(x) && CONSP(x)) { + x = macroexp1(x, env, ctxt, 2); + if (NIMP(x) && IM_BEGIN==CAR(x)) + x = cons(IM_BEGIN, m_seq(CDR(x), env, ctxt)); + } + return x; +} + +SCM scm_check_linum(x, linum) + SCM x, *linum; +{ + SCM lin = UNDEFINED; + if (NIMP(x) && CONSP(x) && SCM_LINUMP(CAR(x))) { + lin = CAR(x); + x = CDR(x); + } + if (linum) *linum = lin; + return x; +} +SCM scm_add_linum(linum, x) + SCM x, linum; +{ + if (UNBNDP(linum)) return x; + if (NIMP(x) && CONSP(x) && SCM_LINUMP(CAR(x))) return x; + return cons(linum, x); +} + +/* + mode values: + 0 expand non-primitive macros only + 1 check for defines, expand non-primitive macros and DEFINE and BEGIN + 2 expand all macros + 3 executing: all macros must be expanded, all values must be defined and + will be memoized, the form may be destructively altered. + +*/ +static SCM macroexp1(xorig, env, ctxt, mode) + SCM xorig, env, ctxt; + int mode; +{ + SCM x = xorig, linum, proc = UNDEFINED, res = UNDEFINED; +#ifndef RECKLESS + SCM trace = scm_trace, trace_env = scm_trace_env; + long argc; + char *what = s_wtap; + MACROEXP_TRACE(xorig, env); +#endif + x = scm_check_linum(xorig, &linum); + if (IMP(x) || NCONSP(x)) { /* Happens for unquoted vectors. */ + if (NIMP(x)) + x = evalatomcar(cons(x, EOL), 0); + x = cons2(IM_QUOTE, x, EOL); + goto retx; + } + else if (IDENTP(x)) { /* Happens for @macroexpand1 */ + proc = x; + x = cons(proc, EOL); + } + else + proc = CAR(x); + ASRTGO(NIMP(proc), errout); + if (CONSP(proc)) { + if (mode < 3) { + x = xorig; + goto retx; + } + if (NIMP(CAR(proc))) + proc = macroexp1(cons(CAR(proc), CDR(proc)), env, i_procedure, mode); + if ((127L & IM_LAMBDA)==(127L & CAR(proc))) { + SCM nenv = CAR(CDR(proc)); + SCM formals = SCM_ENV_FORMALS(nenv); +#ifndef RECKLESS + if (badargsp(formals, CDR(x))) { + what = (char *)WNA; + proc = CAR(x); + goto errout; + } +#endif + res = CDR(x); + if (ilength(formals) >= 0) { + x = cons2(IM_LET, nenv, cons(res, CDR(CDR(proc)))); + goto retx; + } + } + x = cons2(IM_FUNCALL, proc, CDR(x)); + goto retx; + } + ASRTGO(IDENTP(proc), errout); macro_tail: - res = CAR(x); - proc = *lookupcar(x, IMP(defs) ? LOOKUP_UNDEFP : 0); - if (NIMP(proc) && MACROP(proc)) { - CAR(x) = res; - res = cons2(x, wrapenv(), EOL); - switch ((int)(CAR(proc)>>16) & 0x7f) { - 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; + res = proc; /* For nicer error message. */ + if (mode >= 3) { + x = cons(CAR(x), CDR(x)); + proc = scm_lookupval(x, !0); + } + else { + proc = scm_env_lookup(proc, env); + if (IMP(proc)) { /* local binding */ + x = scm_add_linum(linum, x); + goto retx; + } + if (CONSP(proc)) /* local syntax binding. */ + proc = CDR(proc); + else if (SYMBOLP(proc)) /* global variable */ + proc = CDR(sym2vcell(proc)); + } + if (KEYWORDP(proc)) { + SCM argv[3]; + long argc = 2; + proc = KEYWORD_MACRO(proc); + argv[0] = x; + argv[1] = env; + argv[2] = ctxt; + switch (MAC_TYPE(proc)) { + case MAC_MACRO: case MAC_MACRO | MAC_PRIMITIVE: + case MAC_ACRO: case MAC_ACRO | MAC_PRIMITIVE: + /* This means non-memoizing macros can't expand into internal defines. + That's ok with me. */ + if (mode > 1) + x = cons2(IM_ACRO_CALL, CAR(x), CDR(x)); + goto retx; + case MAC_MMACRO | MAC_PRIMITIVE: + case MAC_IDMACRO | MAC_PRIMITIVE: + if (0==mode || + (1==mode && f_define != CDR(proc) && f_begin != CDR(proc))) { + x = scm_add_linum(linum, x); + goto retx; } - /* else fall through */ - case 1: case 5: /* macro */ - res = apply(CDR(proc), res, EOL); - x = NIMP(res) ? res : cons2(IM_BEGIN, res, EOL); + argv[2] = ctxt; + argc = 3; + /* fall through */ + case MAC_MMACRO: + case MAC_IDMACRO: + argv[0] = x; + argv[1] = env; + x = scm_cvapply(CDR(proc), argc, argv); + if (ilength(x) <= 0) + x = cons2((0==mode ? TOPRENAME(i_begin): IM_BEGIN), x, EOL); break; - case 0: case 4: /* acro */ - res = IMP(defs) ? apply(CDR(proc), res, EOL) : UNSPECIFIED; - return cons2(IM_QUOTE, res, EOL); +#ifdef MAC_INLINE /* FIXME this is broken */ + case MAC_INLINE: + { + int depth = env_depth(); + res = CDR(proc); + depth -= INUM(CAR(res)); + res = CDR(res); + x = cons2(MAKISYMVAL(IM_LET, depth), + CAR(res), cons(CDR(x), CDR(res))); + break; + } +#endif + } + MACROEXP_TRACE(xorig, env); + x = scm_check_linum(x, 0L); + if (NIMP(CAR(x)) && IDENTP(CAR(x))) { + proc = CAR(x); + goto macro_tail; } - if (NIMP(CAR(x)) && IDENTP(CAR(x))) goto macro_tail; #ifndef RECKLESS - if (UNBNDP(defs) && IM_DEFINE==CAR(x)) - everr(x, wrapenv(), i_define, "Bad placement", ""); + if (IM_DEFINE==CAR(x) && (mode != 1) && !scm_nullenv_p(env)) { + what = s_placement; + proc = res = i_define; + errout: + if (!UNBNDP(res)) + CAR(x) = res; /* FIXME may not be right for @macroexpand1 */ + if (UNBNDP(proc) && NIMP(x) && CONSP(x)) + proc = CAR(x); + scm_experr(proc, what, ""); + } #endif - return x; } + else { /* not a macro expression, car is identifier */ + if (0 == mode) + x = BOOL_F; + else if (mode <=2 ) + x = scm_add_linum(linum, x); #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), - ""); + else if (mode >= 3) { + argc = ilength(CDR(x)); + if (! scm_arity_check(proc, argc, (char *)0)) { + if (argc < 0) { + what = s_expr; + proc = x; + } + else + what = FALSEP(procedurep(proc)) ? s_wtap : (char *)WNA; + goto errout; + } + for (proc = CDR(x); NIMP(proc); proc = CDR(proc)) { + res = CAR(proc); + if (NIMP(res)) { + if (IDENTP(res)) + scm_lookupval(proc, !0); + else if (CONSP(res)) + macroexp1(res, env, i_argument, mode); + } + } } +#endif } -#endif /* ndef RECKLESS */ + retx: + if (mode >= 3 && x != xorig) { + DEFER_INTS; + CAR(xorig) = CAR(x); + CDR(xorig) = CDR(x); + x = xorig; + ALLOW_INTS; + } + MACROEXP_TRACE(trace, trace_env); /* restore */ return x; } #ifndef RECKLESS -int badargsp(proc, args) - SCM proc, args; +int badargsp(formals, args) + SCM formals, args; { - SCM formals = CAR(CODE(proc)); while NIMP(formals) { if NCONSP(formals) return 0; if IMP(args) return 1; @@ -1323,24 +1896,23 @@ int badargsp(proc, args) } return NNULLP(args) ? 1 : 0; } -/* If what is null, signals error instead of returning false. */ +/* If what is non-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; + if (IMP(p) || argc < 0) goto badproc; cclo_tail: switch TYP7(p) { default: badproc: - if (what) wta(proc, (char *)ARG1, what); + if (what) wta(proc, s_wtap, what); + return 0; + wrongnumargs: + if (what) wta(proc, (char *)WNA, 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: @@ -1355,9 +1927,12 @@ int scm_arity_check(proc, argc, what) 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; + default: wta(proc, "internal error", "scm_arity_check"); + case tc16_apply: ASRTGO(2<=argc, wrongnumargs); return !0; case tc16_call_cc: - case tc16_eval: ASRTGO(1==argc, wrongnumargs) return !0; + case tc16_eval: ASRTGO(1==argc, wrongnumargs); /* fall through */ + case tc16_values: return !0; + case tc16_call_wv: ASRTGO(2==argc, wrongnumargs); return !0; # ifdef CCLO case tc16_cclo: p = CCLO_SUBR(p); @@ -1367,50 +1942,82 @@ int scm_arity_check(proc, argc, what) } case tcs_closures: { - SCM formals = CAR(CODE(p)); + SCM formals = SCM_ENV_FORMALS(CAR(CODE(p))); while (argc--) { - if IMP(formals) goto wrongnumargs; + ASRTGO(NIMP(formals), wrongnumargs); if (CONSP(formals)) formals = CDR(formals); else return !0; } ASRTGO(IMP(formals) || NCONSP(formals), wrongnumargs); + return !0; } } } #endif -char s_map[] = "map", s_for_each[] = "for-each", s_eval[] = "eval"; +char s_map[] = "map", s_for_each[] = "for-each", s_eval[] = "@eval"; char s_call_cc[] = "call-with-current-continuation"; /* s_apply[] = "apply"; */ -static SCM wrapenv() +/* static int checking_defines_p(ctxt) SCM ctxt; */ +/* {return (NIMP(ctxt) && i_check_defines==CAR(ctxt));} */ +/* static SCM wrapenv() */ +/* {register SCM z; */ +/* DEFER_INTS_EGC; if NULLP(scm_env) return EOL; */ +/* 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); return z;} */ + +SCM scm_current_env() { - 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); - return z; + if (NFALSEP(scm_estk)) + return STATIC_ENV; + return EOL; } -SCM ceval(x, env) - SCM x, env; +SCM ceval(x, static_env, env) + SCM x, static_env, env; { ENV_PUSH; #ifdef CAUTIOUS - scm_trace = UNSPECIFIED; + scm_trace = BOOL_F; #endif TRACE(x); + STATIC_ENV = static_env; scm_env = env; x = ceval_1(x); ENV_POP; ALLOW_INTS_EGC; return x; } +SCM scm_eval_values(x, env, valenv) + SCM x, env, valenv; +{ + SCM res; + ENV_PUSH; +#ifdef CAUTIOUS + scm_trace = BOOL_F; +#endif + TRACE(x); + STATIC_ENV = env; + scm_env = valenv; + scm_env_tmp = IM_VALUES_TOKEN; + if (NIMP(x)) x = ceval_1(x); + DEFER_INTS_EGC; + if (IM_VALUES_TOKEN==scm_env_tmp) { + if (UNBNDP(x)) + res = EOL; + else + res = cons(x, EOL); + } + else + res = cons2(x, CAR(scm_env_tmp), CDR(scm_env_tmp)); + ENV_POP; + ALLOW_INTS_EGC; + return res; +} static SCM ceval_1(x) SCM x; @@ -1433,7 +2040,7 @@ static SCM ceval_1(x) switch TYP7(x) { case tcs_symbols: /* only happens when called at top level */ - x = *lookupcar(cons(x, UNDEFINED), LOOKUP_UNDEFP); + x = evalatomcar(cons(x, UNDEFINED), !0); goto retx; case (127 & IM_AND): x = CDR(x); @@ -1448,14 +2055,7 @@ static SCM ceval_1(x) begin: t.arg1 = x; while(NNULLP(t.arg1 = CDR(t.arg1))) { - if IMP(CAR(x)) { - if ISYMP(CAR(x)) { - x = m_expand_body(x); - goto begin; - } - } - else - ceval_1(CAR(x)); + if (NIMP(CAR(x))) ceval_1(CAR(x)); x = t.arg1; } carloop: /* eval car of last form in list */ @@ -1464,7 +2064,7 @@ static SCM ceval_1(x) x = IMP(x) ? EVALIMP(x) : I_VAL(x); } else if ATOMP(CAR(x)) - x = evalatomcar(x); + x = evalatomcar(x, 0); else { x = CAR(x); goto loop; /* tail recurse */ @@ -1475,32 +2075,8 @@ static SCM ceval_1(x) return x; case (127 & IM_CASE): - x = CDR(x); - t.arg1 = EVALCAR(x); -#ifndef INUMS_ONLY - arg2 = (SCM)(IMP(t.arg1) || !NUMP(t.arg1)); -#endif - while(NIMP(x = CDR(x))) { - proc = CAR(x); - if (IM_ELSE==CAR(proc)) { - x = CDR(proc); - goto begin; - } - proc = CAR(proc); - while NIMP(proc) { - if ( -#ifndef INUMS_ONLY - arg2 ? NFALSEP(eqv(CAR(proc), t.arg1)) : -#endif - (CAR(proc)==t.arg1)) { - x = CDR(CAR(x)); - goto begin; - } - proc = CDR(proc); - } - } - x = UNSPECIFIED; - goto retx; + x = scm_case_selector(x); + goto begin; case (127 & IM_COND): while(NIMP(x = CDR(x))) { proc = CAR(x); @@ -1525,7 +2101,8 @@ static SCM ceval_1(x) TRACE(x); x = CDR(x); ecache_evalx(CAR(CDR(x))); /* inits */ - EXTEND_ENV(CAR(x)); + STATIC_ENV = CAR(x); + EXTEND_VALENV; x = CDR(CDR(x)); while (proc = CAR(x), FALSEP(EVALCAR(proc))) { for(proc = CAR(CDR(x));NIMP(proc);proc = CDR(proc)) { @@ -1533,9 +2110,8 @@ static SCM ceval_1(x) SIDEVAL_1(t.arg1); } ecache_evalx(CDR(CDR(x))); /* steps */ - t.arg1 = CAR(CAR(scm_env)); scm_env = CDR(scm_env); - EXTEND_ENV(t.arg1); + EXTEND_VALENV; } x = CDR(proc); if NULLP(x) {x = UNSPECIFIED; goto retx;} @@ -1548,38 +2124,49 @@ static SCM ceval_1(x) case (127 & IM_LET): ENV_MAY_PUSH(envpp); TRACE(x); +#ifdef MAC_INLINE + t.arg1 = CAR(x); +#endif x = CDR(x); ecache_evalx(CAR(CDR(x))); - EXTEND_ENV(CAR(x)); +#ifdef MAC_INLINE + if (t.arg1 != IM_LET) /* inline call */ + env_tail(ISYMVAL(t.arg1)); +#endif + STATIC_ENV = CAR(x); + EXTEND_VALENV; x = CDR(x); goto cdrxbegin; case (127 & IM_LETREC): ENV_MAY_PUSH(envpp); TRACE(x); x = CDR(x); + STATIC_ENV = CAR(x); scm_env_tmp = undefineds; - EXTEND_ENV(CAR(x)); + EXTEND_VALENV; x = CDR(x); ecache_evalx(CAR(x)); - EGC_ROOT(CAR(scm_env)); - CDR(CAR(scm_env)) = scm_env_tmp; + EGC_ROOT(scm_env); + 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) { - scm_env_tmp = EOL; - EXTEND_ENV(EOL); - goto cdrxbegin; - } + proc = CDR(CAR(x)); + /* No longer happens. + if IMP(proc) { + scm_env_tmp = EOL; + EXTEND_VALENV; + goto cdrxbegin; + } + */ do { - t.arg1 = CAR(proc); - proc = CDR(proc); scm_env_tmp = EVALCAR(proc); - EXTEND_ENV(t.arg1); + proc = CDR(proc); + STATIC_ENV = CAR(proc); + EXTEND_VALENV; } while NIMP(proc = CDR(proc)); goto cdrxbegin; case (127 & IM_OR): @@ -1609,7 +2196,7 @@ static SCM ceval_1(x) x = scm_multi_set(proc, arg2); goto retx; } - else *lookupcar(x, LOOKUP_UNDEFP|LOOKUP_MACROP) = arg2; + else *lookupcar(x) = arg2; break; case 1: I_VAL(proc) = arg2; @@ -1624,9 +2211,10 @@ static SCM ceval_1(x) x = UNSPECIFIED; #endif goto retx; - case (127 & IM_DEFINE): /* only for internal defines */ - goto badfun; - /* new syntactic forms go here. */ + case (127 & IM_FUNCALL): + x = CDR(x); + proc = ceval_1(CAR(x)); + break; case (127 & MAKISYM(0)): proc = CAR(x); ASRTGO(ISYMP(proc), badfun); @@ -1662,6 +2250,25 @@ static SCM ceval_1(x) case (ISYMNUM(IM_FARLOC_CDR)): x = *farlookup(x); goto retx; + case (ISYMNUM(IM_EVAL_FOR_APPLY)): + /* only happens when called from C-level apply or cvapply */ + envpp = 1; + proc = CAR(scm_env_tmp); + scm_env_tmp = CDR(scm_env_tmp); + goto clo_unchecked; + case (ISYMNUM(IM_LET_SYNTAX)): + x = CDR(x); + STATIC_ENV = CAR(x); + goto cdrxbegin; + case (ISYMNUM(IM_ACRO_CALL)): + x = acro_call(x, STATIC_ENV); + goto loop; + case (ISYMNUM(IM_LINUM)): + goto expand; + case (ISYMNUM(IM_DEFINE)): + x = toplevel_define(x, STATIC_ENV); + goto retx; + /* new syntactic forms go here. */ default: goto badfun; } @@ -1669,9 +2276,11 @@ static SCM ceval_1(x) proc = x; badfun: #ifdef CAUTIOUS - scm_trace = UNDEFINED; + scm_trace = BOOL_F; + everr(xorig, STATIC_ENV, proc, s_wtap, "", 0); +#else + everr(x, STATIC_ENV, proc, s_wtap, "", 0); #endif - everr(x, wrapenv(), proc, s_wtap, ""); case tc7_vector: case tcs_uves: case tc7_smob: @@ -1683,29 +2292,30 @@ static SCM ceval_1(x) proc = I_VAL(CAR(x)); break; case tcs_cons_nimcar: - if ATOMP(CAR(x)) { - TOP_TRACE(x); + expand: + TOP_TRACE(x, STATIC_ENV); #ifdef MEMOIZE_LOCALS - x = macroexp1(x, UNDEFINED); - goto loop; + x = macroexp1(x, STATIC_ENV, EOL, 3); + goto loop; #else - proc = *lookupcar(x, 0); - if (NIMP(proc) && MACROP(proc)) { - x = macroexp1(x, UNDEFINED); + if ATOMP(CAR(x)) { + proc = scm_lookupval(x, 0); + if (KEYWORDP(proc)) { + x = macroexp1(x, STATIC_ENV, EOL, 3); goto loop; } -#endif } else proc = ceval_1(CAR(x)); +#endif + } /* 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[0] = scm_env; /* For error reporting at wrongnumargs. */ if NULLP(CDR(x)) { evap0: + TOP_TRACE(xorig, STATIC_ENV); ENV_MAY_POP(envpp, CLOSUREP(proc)); - TOP_TRACE(xorig); ALLOW_INTS_EGC; switch TYP7(proc) { /* no arguments given */ case tc7_subr_0: @@ -1728,8 +2338,8 @@ static SCM ceval_1(x) #ifdef CAUTIOUS if (0!=ARGC(proc)) { clo_checked: + t.arg1 = SCM_ENV_FORMALS(CAR(CODE(proc))); DEFER_INTS_EGC; - t.arg1 = CAR(CODE(proc)); arg2 = scm_env_tmp; while NIMP(t.arg1) { if NCONSP(t.arg1) goto clo_unchecked; @@ -1745,17 +2355,22 @@ static SCM ceval_1(x) clo_unchecked: x = CODE(proc); scm_env = ENV(proc); - EXTEND_ENV(CAR(x)); + STATIC_ENV = CAR(x); + EXTEND_VALENV; TRACE(CDR(x)); goto cdrxbegin; case tc7_specfun: + switch TYP16(proc) { + /* default: break; */ #ifdef CCLO - if (tc16_cclo==TYP16(proc)) { + case tc16_cclo: t.arg1 = proc; proc = CCLO_SUBR(proc); goto evap1; - } #endif + case tc16_values: + return scm_values(UNDEFINED, UNDEFINED, EOL, s_values); + } case tc7_contin: case tc7_subr_1: case tc7_subr_2: @@ -1764,28 +2379,33 @@ static SCM ceval_1(x) 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[0]; } - TOP_TRACE(UNDEFINED); - everr(x, wrapenv(), proc, (char *)WNA, ""); +#ifdef CAUTIOUS + if (xorig==scm_trace) STATIC_ENV = scm_trace_env; + TOP_TRACE(BOOL_F, BOOL_F); + everr(xorig, STATIC_ENV, proc, (char *)WNA, "", 0); +#else + everr(x, STATIC_ENV, proc, (char *)WNA, "", 0); +#endif default: goto badfun; } } x = CDR(x); #ifdef CAUTIOUS - if (IMP(x)) goto wrongnumargs; + if (IMP(x)) + goto wrongnumargs; #endif t.arg1 = EVALCAR(x); x = CDR(x); if NULLP(x) { + TOP_TRACE(xorig, STATIC_ENV); 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: @@ -1795,39 +2415,39 @@ evap1: return SUBRF(proc)(t.arg1); case tc7_cxr: #ifdef FLOATS - if SUBRF(proc) { - if INUMP(t.arg1) - return makdbl(DSUBRF(proc)((double) INUM(t.arg1)), 0.0); - ASRTGO(NIMP(t.arg1), floerr); - if REALP(t.arg1) - return makdbl(DSUBRF(proc)(REALPART(t.arg1)), 0.0); + if SUBRF(proc) { + if INUMP(t.arg1) + return makdbl(DSUBRF(proc)((double) INUM(t.arg1)), 0.0); + ASRTGO(NIMP(t.arg1), floerr); + if REALP(t.arg1) + return makdbl(DSUBRF(proc)(REALPART(t.arg1)), 0.0); # ifdef BIGDIG - if BIGP(t.arg1) - return makdbl(DSUBRF(proc)(big2dbl(t.arg1)), 0.0); + if BIGP(t.arg1) + return makdbl(DSUBRF(proc)(big2dbl(t.arg1)), 0.0); # endif - floerr: - wta(t.arg1, (char *)ARG1, SNAME(proc)); - } + floerr: + wta(t.arg1, (char *)ARG1, SNAME(proc)); + } #endif - { - int op = CXR_OP(proc); + { + int op = CXR_OP(proc); #ifndef RECKLESS - x = t.arg1; + x = t.arg1; #endif - while (op) { - ASSERT(NIMP(t.arg1) && CONSP(t.arg1), - x, ARG1, SNAME(proc)); - t.arg1 = (1 & op ? CAR(t.arg1) : CDR(t.arg1)); - op >>= 2; + while (op) { + ASSERT(NIMP(t.arg1) && CONSP(t.arg1), + x, ARG1, SNAME(proc)); + t.arg1 = (1 & op ? CAR(t.arg1) : CDR(t.arg1)); + op >>= 2; + } + return t.arg1; } - return t.arg1; - } - case tc7_rpsubr: - return BOOL_T; - case tc7_asubr: - return SUBRF(proc)(t.arg1, UNDEFINED); - case tc7_lsubr: - return SUBRF(proc)(cons(t.arg1, EOL)); + case tc7_rpsubr: + return BOOL_T; + case tc7_asubr: + return SUBRF(proc)(t.arg1, UNDEFINED); + case tc7_lsubr: + return SUBRF(proc)(cons(t.arg1, EOL)); case tcs_closures: ENV_MAY_PUSH(envpp); #ifdef SCM_PROFILE @@ -1850,7 +2470,8 @@ evap1: DEFER_INTS_EGC; t.arg1 = scm_make_cont(); EGC_ROOT(t.arg1); - if ((x = setjump(CONT(t.arg1)->jmpbuf))) { + x = setjump(CONT(t.arg1)->jmpbuf); + if (x) { #ifdef SHORT_INT x = (SCM)thrown_value; #endif @@ -1863,17 +2484,22 @@ evap1: goto evap1; case tc16_eval: ENV_MAY_PUSH(envpp); - TRACE(x); + TRACE(t.arg1); + STATIC_ENV = eval_env; scm_env = EOL; - x = cons(copytree(t.arg1), EOL); - goto begin; + x = t.arg1; + if (IMP(x)) goto retx; + goto loop; #ifdef CCLO case tc16_cclo: - arg2 = t.arg1; - t.arg1 = proc; - proc = CCLO_SUBR(proc); - goto evap2; -#endif + arg2 = UNDEFINED; + goto cclon; + /* arg2 = t.arg1; + t.arg1 = proc; + proc = CCLO_SUBR(proc); + goto evap2; */ +#endif + case tc16_values: return t.arg1; } case tc7_subr_2: case tc7_subr_0: @@ -1891,9 +2517,9 @@ evap1: arg2 = EVALCAR(x); x = CDR(x); if NULLP(x) { /* have two arguments */ + TOP_TRACE(xorig, STATIC_ENV); evap2: ENV_MAY_POP(envpp, CLOSUREP(proc)); - TOP_TRACE(xorig); ALLOW_INTS_EGC; switch TYP7(proc) { case tc7_subr_2: @@ -1910,6 +2536,7 @@ evap1: switch TYP16(proc) { case tc16_apply: proc = t.arg1; + ASRTGO(NIMP(proc), badfun); if NULLP(arg2) goto evap0; if (IMP(arg2) || NCONSP(arg2)) { x = arg2; @@ -1926,7 +2553,7 @@ evap1: if NULLP(x) goto evap2; ASRTGO(NIMP(x) && CONSP(x), badlst); arg3 = x; - x = copy_list(CDR(x), 0); + x = scm_cp_list(CDR(x), 0); #ifndef RECKLESS if UNBNDP(x) {x = arg3; goto badlst;} #endif @@ -1934,14 +2561,32 @@ evap1: goto evap3; #ifdef CCLO case tc16_cclo: cclon: - return apply(CCLO_SUBR(proc), - cons2(proc, t.arg1, cons(arg2, x)), EOL); - /* arg3 = arg2; + arg3 = arg2; arg2 = t.arg1; t.arg1 = proc; proc = CCLO_SUBR(proc); - goto evap3; */ + if (UNBNDP(arg3)) goto evap2; + goto evap3; + /* return apply(CCLO_SUBR(proc), + cons2(proc, t.arg1, cons(arg2, x)), EOL); */ #endif + case tc16_values: + return scm_values(t.arg1, arg2, EOL, s_values); + case tc16_call_wv: + ENV_MAY_PUSH(envpp); + scm_env_tmp = IM_VALUES_TOKEN; /* Magic value recognized by VALUES */ + t.arg1 = apply(t.arg1, EOL, EOL); + proc = arg2; + DEFER_INTS_EGC; + if (IM_VALUES_TOKEN==scm_env_tmp) { + scm_env_tmp = EOL; + if (UNBNDP(t.arg1)) goto evap0; + goto evap1; + } + arg2 = CAR(scm_env_tmp); + x = CDR(scm_env_tmp); + goto apply4; /* Jumping to apply code results in extra list copy + for >=3 args, but we want to minimize bloat. */ } case tc7_subr_0: case tc7_cxr: @@ -1976,6 +2621,7 @@ evap1: x = CDR(x); if NIMP(x) { if (CLOSUREP(proc) && 3==ARGC(proc)) { + ALLOW_INTS_EGC; ENV_MAY_PUSH(envpp); if (ecache_eval_args(proc, t.arg1, arg2, arg3, x)) goto clo_unchecked; @@ -1983,9 +2629,9 @@ evap1: } x = eval_args(x); } + TOP_TRACE(xorig, STATIC_ENV); evap3: ENV_MAY_POP(envpp, CLOSUREP(proc)); - TOP_TRACE(xorig); ALLOW_INTS_EGC; switch TYP7(proc) { case tc7_subr_3: @@ -2006,8 +2652,7 @@ evap1: #endif switch ARGC(proc) { case 3: - scm_env_cons2(arg2, arg3, x); - scm_env_cons_tmp(t.arg1); + scm_env_cons3(t.arg1, arg2, arg3, x); goto clo_checked; case 2: scm_env_cons2(t.arg1, arg2, cons(arg3, x)); @@ -2023,6 +2668,7 @@ evap1: switch TYP16(proc) { case tc16_apply: proc = t.arg1; + ASRTGO(NIMP(proc), badfun); t.arg1 = arg2; if IMP(x) { x = arg3; @@ -2041,6 +2687,8 @@ evap1: x = cons(arg3, x); goto cclon; #endif + case tc16_values: + return scm_values(t.arg1, arg2, cons(arg3, x), s_values); } case tc7_subr_2: case tc7_subr_1o: @@ -2074,16 +2722,14 @@ static char s_proc_doc[] = "procedure-documentation"; SCM l_proc_doc(proc) SCM proc; { - SCM code; + SCM env; ASSERT(BOOL_T==procedurep(proc) && NIMP(proc) && TYP7(proc) != tc7_contin, proc, ARG1, s_proc_doc); switch TYP7(proc) { case tcs_closures: - code = CDR(CODE(proc)); - if IMP(CDR(code)) return BOOL_F; - code = CAR(code); - if IMP(code) return BOOL_F; - if STRINGP(code) return code; + env = CAR(CODE(proc)); + env = scm_env_getprop(SCM_ENV_DOC, CAR(CODE(proc))); + return IMP(env) ? BOOL_F : CAR(env); default: return BOOL_F; /* @@ -2117,7 +2763,7 @@ SCM nconc2copy(lst) } /* Shallow copy. If LST is not a proper list of length at least MINLEN, returns UNDEFINED */ -SCM copy_list(lst, minlen) +SCM scm_cp_list(lst, minlen) SCM lst; int minlen; { @@ -2132,15 +2778,14 @@ SCM copy_list(lst, minlen) return res; return UNDEFINED; } -SCM scm_v2lst(n, v) +SCM scm_v2lst(n, v, end) long n; - SCM *v; + SCM *v, end; { - SCM res = EOL; + SCM res = end; 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; { @@ -2192,7 +2837,7 @@ SCM apply(proc, arg1, args) return makdbl(DSUBRF(proc)(big2dbl(arg1)), 0.0); # endif floerr: - wta(arg1, (char *)ARG1, CHARS(SNAME(proc))); + wta(arg1, (char *)ARG1, SNAME(proc)); } #endif { @@ -2234,29 +2879,16 @@ SCM apply(proc, arg1, args) args = CDR(args); } return BOOL_T; - case tcs_closures: + case tcs_closures: { arg1 = (UNBNDP(arg1) ? EOL : cons(arg1, args)); #ifndef RECKLESS - if (badargsp(proc, arg1)) goto wrongnumargs; + if (badargsp(SCM_ENV_FORMALS(CAR(CODE(proc))), arg1)) goto wrongnumargs; #endif ENV_PUSH; - PUSH_TRACE; - scm_env_tmp = arg1; - 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; - } - arg1 = EVALCAR(proc); - proc = CDR(proc); - } - ENV_POP; - ALLOW_INTS_EGC; + scm_env_cons(proc, arg1); + arg1 = ceval_1(f_evapply); return arg1; + } case tc7_contin: ASRTGO(NULLP(args), wrongnumargs); scm_dynthrow(proc, arg1); @@ -2272,8 +2904,8 @@ SCM apply(proc, arg1, args) } } -/* This function does not check that proc is a procedure, nor the - number of arguments, call scm_arity_check to do that. */ +/* This function does not check that proc is a procedure, nor that + it accepts n arguments. Call scm_arity_check to do that. */ SCM scm_cvapply(proc, n, argv) SCM proc, *argv; long n; @@ -2290,7 +2922,6 @@ SCM scm_cvapply(proc, n, argv) 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); @@ -2310,7 +2941,7 @@ SCM scm_cvapply(proc, n, argv) return makdbl(DSUBRF(proc)(big2dbl(argv[0])), 0.0); # endif floerr: - wta(argv[0], (char *)ARG1, CHARS(SNAME(proc))); + wta(argv[0], (char *)ARG1, SNAME(proc)); } #endif { @@ -2327,12 +2958,12 @@ SCM scm_cvapply(proc, n, argv) 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)); + return SUBRF(proc)(0==n ? EOL : scm_v2lst(n, argv, EOL)); case tc7_lsubr_2: return SUBRF(proc)(argv[0], argv[1], - 2==n ? EOL : scm_v2lst(n-2, &argv[2])); + 2==n ? EOL : scm_v2lst(n-2, &argv[2], EOL)); case tc7_asubr: - if (1 >= n) return SUBRF(proc)(0==n ? argv[0] : UNDEFINED, UNDEFINED); + 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]); @@ -2342,34 +2973,23 @@ SCM scm_cvapply(proc, n, argv) 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: + case tcs_closures: { + SCM p = proc; ENV_PUSH; - PUSH_TRACE; i = ARGC(proc); if (3==i) { scm_env_tmp = EOL; - scm_env_v2lst((int)n, argv); + ENV_V2LST(n, argv); } else { - scm_env_tmp = (i < n) ? scm_v2lst(n-i, &argv[i]) : EOL; + scm_env_tmp = (i < n) ? scm_v2lst(n-i, &argv[i], EOL) : 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_V2LST(i, argv); } - ENV_POP; - ALLOW_INTS_EGC; + ENV_V2LST(1L, &p); + res = ceval_1(f_evapply); return res; + } case tc7_contin: scm_dynthrow(proc, argv[0]); case tc7_specfun: @@ -2382,7 +3002,7 @@ SCM scm_cvapply(proc, n, argv) #endif goto tail; } - res = cons(proc, 0==n ? EOL : scm_v2lst(n, argv)); + res = cons(proc, 0==n ? EOL : scm_v2lst(n, argv, EOL)); #ifdef CCLO proc = (TYP16(proc)==tc16_cclo ? CCLO_SUBR(proc) : f_apply_closure); #else @@ -2401,10 +3021,6 @@ SCM map(proc, arg1, args) 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 scm_arity_check(proc, n, s_map); #endif @@ -2424,21 +3040,20 @@ SCM map(proc, arg1, args) ave = &(ve[n]); } ve[0] = arg1; - ASSERT(NIMP(ve[0]) && CONSP(ve[0]), arg1, ARG2, s_map); + ASSERT(NIMP(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); + ASSERT(NIMP(ve[i]), ve[i], 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 + /* We could check for lists the same length here. */ return res; } + ASSERT(CONSP(ve[i]), ve[i], 0==i ? ARG2 : ARGn, s_map); ave[i] = CAR(ve[i]); ve[i] = CDR(ve[i]); } @@ -2454,10 +3069,6 @@ SCM for_each(proc, arg1, args) 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 @@ -2477,21 +3088,19 @@ SCM for_each(proc, arg1, args) ave = &(ve[n]); } ve[0] = arg1; - ASSERT(NIMP(ve[0]) && CONSP(ve[0]), arg1, ARG2, s_for_each); + ASSERT(NIMP(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); + ASSERT(NIMP(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; } + ASSERT(CONSP(ve[i]), ve[i], 0==i ? ARG2 : ARGn, s_for_each); ave[i] = CAR(ve[i]); ve[i] = CDR(ve[i]); } @@ -2535,129 +3144,85 @@ static int prinprom(exp, port, writing) SCM port; int writing; { - lputs("#<promise ", port); + lputs("#<promise", port); + if ((2L<<16) & CAR(exp)) lputc('*', port); + lputc(' ', port); iprin1(CDR(exp), port, writing); lputc('>', port); return !0; } +static SCM makro(code, flags, what) + SCM code; + long flags; + char *what; +{ + register SCM z; + ASSERT(scm_arity_check(code, (MAC_PRIMITIVE & flags ? 3L : 2L), + (char *)0), code, ARG1, what); + NEWCELL(z); + CDR(z) = code; + CAR(z) = tc16_macro | (flags << 16); + return z; +} 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; + return makro(code, MAC_ACRO, s_makacro); } 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; + return makro(code, MAC_MACRO, s_makmacro); } 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; + return makro(code, MAC_MMACRO, s_makmmacro); +} +static char s_makidmacro[] = "procedure->identifier-macro"; +SCM makidmacro(code) + SCM code; +{ + return makro(code, MAC_IDMACRO, s_makidmacro); } #ifdef MACRO -/* Functions for (eventual) smart expansion */ +/* Functions for smart expansion */ + +/* @MACROEXPAND1 returns: + #F if its argument is not a macro invocation, + the argument if the argument is a primitive syntax invocation, + the result of expansion if the argument is a macro invocation + (BEGIN #F) will be returned instead of #F if #F is the result. + */ 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); + SCM name; + if (IMP(x)) return BOOL_F; + if (CONSP(x)) { + name = CAR(x); + if (IMP(name) || !IDENTP(name)) return BOOL_F; /* probably an error */ } - 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); - } + else if (IDENTP(x)) { + name = x; } - 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; + else + return BOOL_F; + return macroexp1(x, env, BOOL_F, 0); } + 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); + SCM venv = cons(undefineds, undefineds); + CDR(venv) = venv; + return EVAL(x, env, venv); } #endif /* MACRO */ @@ -2666,11 +3231,19 @@ static int prinmacro(exp, port, writing) SCM port; int writing; { - 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); + lputs("#<", port); + if (MAC_TYPE(exp) & MAC_PRIMITIVE) lputs("primitive-", port); + switch (MAC_TYPE(exp) & ~MAC_PRIMITIVE) { + default: + lputs("macro", port); break; + case MAC_ACRO: + lputs("syntax", port); break; +#ifdef MAC_INLINE + case MAC_INLINE: + lputs("inline function", port); break; +#endif + } + if (MAC_TYPE(exp) & MAC_MEMOIZING) lputc('!', port); lputc(' ', port); iprin1(CDR(exp), port, writing); lputc('>', port); @@ -2694,8 +3267,8 @@ static int prinid(exp, port, writing) int writing; { SCM s = IDENT_PARENT(exp); - while (!IDENTP(s)) s = IDENT_PARENT(s); - lputs("#<identifier ", port); + while (M_IDENTP(s)) s = IDENT_PARENT(s); + lputs("#<id ", port); iprin1(s, port, writing); lputc(':', port); intprint((long)exp, -16, port); @@ -2707,17 +3280,41 @@ char s_force[] = "force"; SCM force(x) SCM x; { - ASSERT(NIMP(x) && (TYP16(x)==tc16_promise), x, ARG1, s_force); - if (!((1L<<16) & CAR(x))) { - SCM ans = scm_cvapply(CDR(x), 0L, (SCM *)0); - if (!((1L<<16) & CAR(x))) { - DEFER_INTS; - CDR(x) = ans; - CAR(x) |= (1L<<16); - ALLOW_INTS; + tail: + ASRTGO(NIMP(x) && (TYP16(x)==tc16_promise), badx); + switch (CAR(x)>>16) { + default: + badx: wta(x, (char *)ARG1, s_force); + case 0: + { + SCM ans; + int mv = (IM_VALUES_TOKEN==scm_env_tmp); + ans = scm_cvapply(CDR(x), 0L, (SCM *)0); + if (mv) { + DEFER_INTS_EGC; + if (IM_VALUES_TOKEN==scm_env_tmp) { + if (!UNBNDP(ans)) mv = 0; + } + else { + ans = cons2(ans, CAR(scm_env_tmp), CDR(scm_env_tmp)); + scm_env_tmp = IM_VALUES_TOKEN; + } + ALLOW_INTS_EGC; + } + if (!((1L<<16) & CAR(x))) { + DEFER_INTS; + CDR(x) = ans; + CAR(x) |= mv ? (3L<<16) : (1L<<16); + ALLOW_INTS; + } + goto tail; } + case 1: return CDR(x); + case 3: + x = CDR(x); + if (UNBNDP(x)) return scm_values(UNDEFINED, UNDEFINED, EOL, s_force); + return scm_values(CAR(x), CAR(CDR(x)), CDR(CDR(x)), s_force); } - return CDR(x); } SCM copytree(obj) @@ -2743,7 +3340,7 @@ SCM eval(obj) SCM obj; { obj = copytree(obj); - return EVAL(obj, (SCM)EOL); + return EVAL(obj, EOL, EOL); } SCM definedp(x, env) @@ -2771,7 +3368,7 @@ static char s_ident_eqp[] = "identifier-equal?"; SCM ident_eqp(id1, id2, env) SCM id1, id2, env; { - SCM s1 = id1, s2 = id2, ret; + SCM s1 = id1, s2 = id2; # ifndef RECKLESS if IMP(id1) badarg1: wta(id1, (char *)ARG1, s_ident_eqp); @@ -2784,16 +3381,12 @@ SCM ident_eqp(id1, id2, env) ASRTGO(SYMBOLP(s1), badarg1); ASRTGO(SYMBOLP(s2), badarg2); if (s1 != s2) return BOOL_F; - ENV_PUSH; - 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; + s1 = scm_env_lookup(id1, env); + s2 = scm_env_lookup(id2, env); + if (s1==s2) return BOOL_T; + if (NIMP(s1) && ISYMP(CAR(s1))) /* FARLOC case */ + return equal(s1, s2); + return BOOL_F; } static char s_ident2sym[] = "identifier->symbol"; @@ -2811,13 +3404,22 @@ SCM renamed_ident(id, env) { SCM z; ASSERT(NIMP(id) && IDENTP(id), id, ARG1, s_renamed_ident); - if NIMP(env) { - ASSERT(ENVP(env), env, ARG2, s_renamed_ident); - DEFER_INTS_EGC; - env = CDR(env); - } NEWCELL(z); - if IMP(env) { + while (NIMP(env)) { + if (INUMP(CAR(env))) { + ASSERT(NIMP(CDR(env)), env, s_badenv, s_renamed_ident); + env = CDR(CDR(env)); + } + else if (SCM_LINUMP(CAR(env))) { + env = CDR(env); + } + else { + ASSERT(NULLP(env) || (NIMP(env) && CONSP(env)), + env, s_badenv, s_renamed_ident); + break; + } + } + if (scm_nullenv_p(env)) { CAR(z) = tc16_ident; CDR(z) = id; return z; @@ -2825,7 +3427,7 @@ SCM renamed_ident(id, env) else { SCM y; CAR(z) = id; - CDR(z) = CAR(CAR(env)); + CDR(z) = env; NEWCELL(y); CAR(y) = tc16_ident | 1L<<16; CDR(y) = z; @@ -2834,117 +3436,119 @@ SCM renamed_ident(id, env) } static char s_syn_quote[] = "syntax-quote"; -SCM m_syn_quote(xorig, env) - SCM xorig, env; +SCM m_syn_quote(xorig, env, ctxt) + SCM xorig, env, ctxt; { ASSYNT(ilength(CDR(xorig))==1, xorig, s_expression, s_syn_quote); return cons(IM_QUOTE, CDR(xorig)); } -/* Ensure that the environment for LET-SYNTAX can be uniquely identified. */ -SCM m_atlet_syntax(xorig, env) - SCM xorig, env; -{ - SCM mark; - DEFER_INTS_EGC; - if (NIMP(env) && ENVP(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_defsyntax[] = "defsyntax"; +SCM m_defsyntax(xorig, env, ctxt) + SCM xorig, env, ctxt; +{ + SCM x = CDR(xorig), name, val; + ASSYNT(ilength(x)==2, xorig, s_expression, s_defsyntax); + ASSYNT(scm_nullenv_p(env), xorig, s_placement, s_defsyntax); + name = CAR(x); + ASSYNT(NIMP(name) && IDENTP(name), name, s_variable, s_defsyntax); + val = evalcar(CDR(x)); + ASSYNT(NIMP(val) && MACROP(val), CAR(CDR(x)), s_expr, s_defsyntax); + checked_define(name, cons(IM_KEYWORD, val), s_defsyntax); + return UNSPECIFIED; +} + +SCM m_let_syntax(xorig, env, ctxt) + SCM xorig, env, ctxt; +{ + SCM proc, vars, inits, fr; + SCM body = m_parse_let(EOL, xorig, CDR(xorig), &vars, &inits); + /* if (IMP(vars)) return m_let_null(body, env, ctxt); */ + /* Add a unique frame for an environment mark. */ + env = EXTEND_ENV(cons(SCM_ENV_SYNTAX, EOL), env); + for (fr = EOL; NIMP(inits); inits = CDR(inits)) { + proc = scm_eval_syntax(CAR(inits), env); + ASSYNT(NIMP(proc) && MACROP(proc), CAR(inits), s_expr, s_let_syntax); + fr = acons(CAR(vars), proc, fr); + vars = CDR(vars); + } + fr = cons(SCM_ENV_SYNTAX, fr); + env = EXTEND_ENV(fr, env); + return cons2(IM_LET_SYNTAX, env, m_body(body, env, ctxt)); +} +static char s_letrec_syntax[] = "letrec-syntax"; +SCM m_letrec_syntax(xorig, env, ctxt) + SCM xorig, env, ctxt; +{ + SCM proc, vars, vals, inits, fr; + SCM body = m_parse_let(EOL, xorig, CDR(xorig), &vars, &inits); + /* if (IMP(vars)) return m_let_null(body, env, ctxt); */ + for (fr = EOL; NIMP(vars); vars = CDR(vars)) + fr = acons(CAR(vars), UNDEFINED, fr); + fr = cons(SCM_ENV_SYNTAX, fr); + env = EXTEND_ENV(fr, env); + for (vals = EOL; NIMP(inits); inits = CDR(inits)) { + proc = scm_eval_syntax(CAR(inits), env); + ASSYNT(NIMP(proc) && MACROP(proc), CAR(inits), s_expr, s_letrec_syntax); + vals = cons(proc, vals); + } + for (fr = CDR(fr); NIMP(fr); fr = CDR(fr)) { + CDR(CAR(fr)) = CAR(vals); + vals = CDR(vals); + } + return cons2(IM_LET_SYNTAX, env, m_body(body, env, ctxt)); } static char s_the_macro[] = "the-macro"; -SCM m_the_macro(xorig, env) - SCM xorig, env; +SCM m_the_macro(xorig, env, ctxt) + SCM xorig, env, ctxt; { - SCM x = CDR(xorig); + SCM addr, x = CDR(xorig); ASSYNT(1==ilength(x), xorig, s_expression, s_the_macro); - if (NIMP(CAR(x)) && IDENTP(CAR(x))) - x = *lookupcar(x, LOOKUP_UNDEFP); - else - x = evalcar(x); - ASSYNT(NIMP(x) && MACROP(x), xorig, ARG1, s_the_macro); - return cons2(IM_QUOTE, x, EOL); + x = CAR(x); + ASSYNT(NIMP(x) && IDENTP(x), x, s_expression, s_the_macro); + addr = scm_env_lookup(x, env); + /* Require global ref for now. */ + ASSYNT(NIMP(addr) && SYMBOLP(addr), x, s_expression, s_the_macro); + x = CDR(sym2vcell(addr)); + ASSYNT(KEYWORDP(x), xorig, ARG1, s_the_macro); + return KEYWORD_MACRO(x); } #endif -static char s_env2tree[] = "environment->tree"; -SCM env2tree(env) - SCM env; -{ - SCM ans, a, *lloc; - if NULLP(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; - 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; - CDR(env) = ans; /* Memoize migrated environment. */ - CAR(env) |= (1L << 16); - return ans; -} - static iproc subr1s[] = { {"@copy-tree", copytree}, /* {s_eval, eval}, now a (tail recursive) specfun */ {s_force, force}, {s_proc_doc, l_proc_doc}, - {"procedure->syntax", makacro}, - {"procedure->macro", makmacro}, - {"procedure->memoizing-macro", makmmacro}, + {s_makacro, makacro}, + {s_makmacro, makmacro}, + {s_makmmacro, makmmacro}, + {s_makidmacro, makidmacro}, {"apply:nconc-to-last", nconc2copy}, - {s_env2tree, env2tree}, + /* {s_env2tree, env2tree}, */ #ifdef MACRO {s_identp, identp}, {s_ident2sym, ident2sym}, #endif {0, 0}}; -static iproc lsubr2s[] = { -/* {s_apply, apply}, now explicity initted */ - {s_map, map}, - {s_for_each, for_each}, +static iproc subr2s[] = { #ifdef MACRO {s_macroexpand1, scm_macroexpand1}, - {s_env_ref, scm_env_ref}, {s_eval_syntax, scm_eval_syntax}, #endif {0, 0}}; +static iproc lsubr2s[] = { +/* {s_apply, apply}, now explicity initted */ + {s_map, map}, + {s_for_each, for_each}, + {0, 0}}; + static iproc subr3s[] = { #ifdef MACRO {s_ident_eqp, ident_eqp}, - {s_extended_env, scm_extended_env}, #endif {0, 0}}; @@ -2955,25 +3559,28 @@ static smobfuns envsmob = {markcdr, free0, prinenv}; static smobfuns idsmob = {markcdr, free0, prinid}; #endif -SCM make_synt(name, macroizer, fcn) +SCM make_synt(name, flags, fcn) const char *name; - SCM (*macroizer)(); + long flags; SCM (*fcn)(); { SCM symcell = sysintern(name, UNDEFINED); - SCM z = macroizer(scm_maksubr(name, tc7_subr_2, fcn)); - CAR(z) |= (4L << 16); /* Flags result as primitive macro. */ + SCM z = makro(scm_maksubr(name, tc7_subr_3, fcn), + flags | MAC_PRIMITIVE, "make_synt"); +#ifdef MACRO + z = cons(IM_KEYWORD, z); +#endif CDR(symcell) = z; return CAR(symcell); } -SCM make_specfun(name, typ) +SCM make_specfun(name, typ, flags) char *name; - int typ; + int typ, flags; { SCM symcell = sysintern(name, UNDEFINED); register SCM z; NEWCELL(z); - CAR(z) = (long)typ; + CAR(z) = (long)typ | ((long)flags)<<16; CDR(z) = CAR(symcell); CDR(symcell) = z; return z; @@ -2984,56 +3591,81 @@ void init_eval() tc16_macro = newsmob(¯osmob); tc16_env = newsmob(&envsmob); init_iprocs(subr1s, tc7_subr_1); + init_iprocs(subr2s, tc7_subr_2); 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); + make_specfun(s_apply, tc16_apply, 0); + make_specfun(s_call_cc, tc16_call_cc, 0); + make_specfun(s_eval, tc16_eval, 0); + make_specfun(s_values, tc16_values, 0); + make_specfun(s_call_wv, tc16_call_wv, 0); + add_feature(s_values); i_dot = CAR(sysintern(".", UNDEFINED)); i_arrow = CAR(sysintern("=>", UNDEFINED)); i_else = CAR(sysintern("else", UNDEFINED)); i_unquote = CAR(sysintern("unquote", UNDEFINED)); i_uq_splicing = CAR(sysintern("unquote-splicing", UNDEFINED)); + i_quasiquote = make_synt(s_quasiquote, MAC_MMACRO, m_quasiquote); + i_define = make_synt(s_define, MAC_MMACRO, m_define); + make_synt(s_delay, MAC_MMACRO, m_delay); + + i_bind = CAR(sysintern("bind", UNDEFINED)); + i_anon = CAR(sysintern("<anon>", UNDEFINED)); + i_side_effect = CAR(sysintern("side-effect", UNDEFINED)); + i_test = CAR(sysintern("test", UNDEFINED)); + i_procedure = CAR(sysintern("procedure", UNDEFINED)); + i_argument = CAR(sysintern("argument", UNDEFINED)); + i_check_defines = CAR(sysintern("check-defines", UNDEFINED)); + loc_atcase_aux = &CDR(sysintern("@case-aux", UNDEFINED)); /* acros */ - i_quasiquote = make_synt(s_quasiquote, makmmacro, m_quasiquote); - i_define = make_synt(s_define, makmmacro, m_define); - make_synt(s_delay, makmmacro, m_delay); - make_synt("defined?", makacro, definedp); + make_synt("defined?", MAC_ACRO, definedp); /* end of acros */ - make_synt(s_and, makmmacro, m_and); - make_synt(s_begin, makmmacro, m_begin); - make_synt(s_case, makmmacro, m_case); - make_synt(s_cond, makmmacro, m_cond); - make_synt(s_do, makmmacro, m_do); - make_synt(s_if, makmmacro, m_if); - i_lambda = make_synt(s_lambda, makmmacro, m_lambda); - i_let = make_synt(s_let, makmmacro, m_let); - make_synt(s_letrec, makmmacro, m_letrec); - make_synt(s_letstar, makmmacro, m_letstar); - make_synt(s_or, makmmacro, m_or); - 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); */ - - f_apply_closure = - CDR(sysintern(" apply-closure", - scm_evstr("(let ((ap apply)) (lambda (p . a) (ap p a)))"))); - + make_synt(s_and, MAC_MMACRO, m_and); + i_begin = make_synt(s_begin, MAC_MMACRO, m_begin); + make_synt(s_case, MAC_MMACRO, m_case); + make_synt(s_cond, MAC_MMACRO, m_cond); + make_synt(s_do, MAC_MMACRO, m_do); + make_synt(s_if, MAC_MMACRO, m_if); + i_lambda = make_synt(s_lambda, MAC_MMACRO, m_lambda); + i_let = make_synt(s_let, MAC_MMACRO, m_let); + make_synt(s_letrec, MAC_MMACRO, m_letrec); + make_synt(s_letstar, MAC_MMACRO, m_letstar); + make_synt(s_or, MAC_MMACRO, m_or); + i_quote = make_synt(s_quote, MAC_MMACRO, m_quote); + make_synt(s_set, MAC_MMACRO, m_set); + make_synt(s_atapply, MAC_MMACRO, m_apply); + /* make_synt(s_atcall_cc, MAC_MMACRO, m_cont); */ +#ifdef MAC_INLINE + make_synt("@inline-lambda", MAC_MMACRO, m_inline_lambda); +#endif #ifdef MACRO tc16_ident = newsmob(&idsmob); make_subr(s_renamed_ident, tc7_subr_2, renamed_ident); - make_synt(s_syn_quote, makmmacro, m_syn_quote); - make_synt("@let-syntax", makmmacro, m_atlet_syntax); - /* This doesn't do anything special, but might in the future. */ - make_synt("@letrec-syntax", makmmacro, m_letrec); - make_synt(s_the_macro, makmmacro, m_the_macro); - i_mark = CAR(sysintern("let-syntax-mark", UNDEFINED)); + make_synt(s_syn_quote, MAC_MMACRO, m_syn_quote); + make_synt(s_defsyntax, MAC_MMACRO, m_defsyntax); + make_synt(s_let_syntax, MAC_MMACRO, m_let_syntax); + make_synt(s_letrec_syntax, MAC_MMACRO, m_letrec_syntax); + + make_synt(s_the_macro, MAC_ACRO, m_the_macro); +#endif + + f_begin = CDR(CDR(KEYWORD_MACRO(sym2vcell(i_begin)))); + f_define = CDR(CDR(KEYWORD_MACRO(sym2vcell(i_define)))); + + list_unspecified = cons(UNSPECIFIED, EOL); + f_evapply = cons(IM_EVAL_FOR_APPLY, EOL); +#ifdef SCM_ENV_FILENAME + eval_env = scm_env_addprop(SCM_ENV_FILENAME, + CAR(sysintern("eval", UNDEFINED)), + EOL); +#else + eval_env = EOL; #endif + f_apply_closure = scm_evstr("(let ((ap apply)) (lambda (p . a) (ap p a)))"); } |