aboutsummaryrefslogtreecommitdiffstats
path: root/eval.c
diff options
context:
space:
mode:
Diffstat (limited to 'eval.c')
-rw-r--r--eval.c2632
1 files changed, 1632 insertions, 1000 deletions
diff --git a/eval.c b/eval.c
index fdb3683..7b0e983 100644
--- a/eval.c
+++ b/eval.c
@@ -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 ? UNDEFINED : argv[0], 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(&macrosmob);
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)))");
}