Import Upstream version 5d6upstream/5d6

1 files changed, 1632 insertions, 1000 deletions

diff --git a/eval.c b/eval.c
index ee4975d..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 ? argv[0] : UNDEFINED, UNDEFINED);
+    if (1 >= n) return SUBRF(proc)(0==n ? UNDEFINED: argv[0], UNDEFINED);
     res = argv[0];
     for (i = 1; i < n; i++)
       res = SUBRF(proc)(res, argv[i]);
@@ -2342,34 +2973,23 @@ SCM scm_cvapply(proc, n, argv)
     for (i = 0; i < n-1; i++)
       if FALSEP(SUBRF(proc)(argv[i], argv[i+1])) return BOOL_F;
     return BOOL_T;
-  case tcs_closures:
+  case tcs_closures: {
+    SCM p = proc;
     ENV_PUSH;
-    PUSH_TRACE;
     i = ARGC(proc);
     if (3==i) {
       scm_env_tmp = EOL;
-      scm_env_v2lst((int)n, argv);
+      ENV_V2LST(n, argv);
     }
     else {
-      scm_env_tmp = (i < n) ? scm_v2lst(n-i, &argv[i]) : EOL;
+      scm_env_tmp = (i < n) ? scm_v2lst(n-i, &argv[i], EOL) : EOL;
       if (i>0)
-	scm_env_v2lst((int)i, argv);
-    }
-    scm_env = ENV(proc);
-    proc = CODE(proc);
-    EXTEND_ENV(CAR(proc));
-    proc = CDR(proc);
-    while NNULLP(proc) {
-      if (IMP(CAR(proc)) && ISYMP(CAR(proc))) {
-        proc = m_expand_body(proc);
-        continue;
-      }
-      res = EVALCAR(proc);
-      proc = CDR(proc);
+	ENV_V2LST(i, argv);
     }
-    ENV_POP;
-    ALLOW_INTS_EGC;
+    ENV_V2LST(1L, &p);
+    res = ceval_1(f_evapply);
     return res;
+  }
   case tc7_contin:
     scm_dynthrow(proc, argv[0]);
   case tc7_specfun:
@@ -2382,7 +3002,7 @@ SCM scm_cvapply(proc, n, argv)
 #endif
       goto tail;
     }
-    res = cons(proc, 0==n ? EOL : scm_v2lst(n, argv));
+    res = cons(proc, 0==n ? EOL : scm_v2lst(n, argv, EOL));
 #ifdef CCLO
     proc = (TYP16(proc)==tc16_cclo ? CCLO_SUBR(proc) : f_apply_closure);
 #else
@@ -2401,10 +3021,6 @@ SCM map(proc, arg1, args)
   long i, n = ilength(args) + 1;
   scm_protect_temp(&heap_ve);  /* Keep heap_ve from being optimized away. */
   if NULLP(arg1) return res;
-#ifdef CAUTIOUS
-  ENV_PUSH;
-  PUSH_TRACE;
-#endif
 #ifndef RECKLESS
   scm_arity_check(proc, n, s_map);
 #endif
@@ -2424,21 +3040,20 @@ SCM map(proc, arg1, args)
     ave = &(ve[n]);
   }
   ve[0] = arg1;
-  ASSERT(NIMP(ve[0]) && CONSP(ve[0]), arg1, ARG2, s_map);
+  ASSERT(NIMP(ve[0]), arg1, ARG2, s_map);
   for (i = 1; i < n; i++) {
     ve[i] = CAR(args);
-    ASSERT(NIMP(ve[i]) && CONSP(ve[i]), args, ARGn, s_map);
+    ASSERT(NIMP(ve[i]), ve[i], ARGn, s_map);
     args = CDR(args);
   }
   while (1) {
     arg1 = EOL;
     for (i = n-1;i >= 0;i--) {
       if IMP(ve[i]) {
-#ifdef CAUTIOUS
-	ENV_POP;
-#endif
+	/* We could check for lists the same length here. */
 	return res;
       }
+      ASSERT(CONSP(ve[i]), ve[i], 0==i ? ARG2 : ARGn, s_map);
       ave[i] = CAR(ve[i]);
       ve[i] = CDR(ve[i]);
     }
@@ -2454,10 +3069,6 @@ SCM for_each(proc, arg1, args)
   long i, n = ilength(args) + 1;
   scm_protect_temp(&heap_ve);  /* Keep heap_ve from being optimized away. */
   if NULLP(arg1) return UNSPECIFIED;
-#ifdef CAUTIOUS
-  ENV_PUSH;
-  PUSH_TRACE;
-#endif
 #ifndef RECKLESS
   scm_arity_check(proc, n, s_map);
 #endif
@@ -2477,21 +3088,19 @@ SCM for_each(proc, arg1, args)
     ave = &(ve[n]);
   }
   ve[0] = arg1;
-  ASSERT(NIMP(ve[0]) && CONSP(ve[0]), arg1, ARG2, s_for_each);
+  ASSERT(NIMP(ve[0]), arg1, ARG2, s_for_each);
   for (i = 1; i < n; i++) {
     ve[i] = CAR(args);
-    ASSERT(NIMP(ve[i]) && CONSP(ve[i]), args, ARGn, s_for_each);
+    ASSERT(NIMP(ve[i]), args, ARGn, s_for_each);
     args = CDR(args);
   }
   while (1) {
     arg1 = EOL;
     for (i = n-1;i >= 0;i--) {
       if IMP(ve[i]) {
-#ifdef CAUTIOUS
-	ENV_POP;
-#endif
 	return UNSPECIFIED;
       }
+      ASSERT(CONSP(ve[i]), ve[i], 0==i ? ARG2 : ARGn, s_for_each);
       ave[i] = CAR(ve[i]);
       ve[i] = CDR(ve[i]);
     }
@@ -2535,129 +3144,85 @@ static int prinprom(exp, port, writing)
      SCM port;
      int writing;
 {
-  lputs("#<promise ", port);
+  lputs("#<promise", port);
+  if ((2L<<16) & CAR(exp)) lputc('*', port);
+  lputc(' ', port);
   iprin1(CDR(exp), port, writing);
   lputc('>', port);
   return !0;
 }
 
+static SCM makro(code, flags, what)
+     SCM code;
+     long flags;
+     char *what;
+{
+  register SCM z;
+  ASSERT(scm_arity_check(code, (MAC_PRIMITIVE & flags ? 3L : 2L),
+			 (char *)0), code, ARG1, what);
+  NEWCELL(z);
+  CDR(z) = code;
+  CAR(z) = tc16_macro | (flags << 16);
+  return z;
+}
 static char s_makacro[] = "procedure->syntax";
 SCM makacro(code)
      SCM code;
 {
-	register SCM z;
-	ASSERT(scm_arity_check(code, 2L, (char *)0), code, ARG1, s_makacro);
-	NEWCELL(z);
-	CDR(z) = code;
-	CAR(z) = tc16_macro;
-	return z;
+  return makro(code, MAC_ACRO, s_makacro);
 }
 static char s_makmacro[] = "procedure->macro";
 SCM makmacro(code)
      SCM code;
 {
-	register SCM z;
-	ASSERT(scm_arity_check(code, 2L, (char *)0), code, ARG1, s_makmacro);
-	NEWCELL(z);
-	CDR(z) = code;
-	CAR(z) = tc16_macro | (1L<<16);
-	return z;
+  return makro(code, MAC_MACRO, s_makmacro);
 }
 static char s_makmmacro[] = "procedure->memoizing-macro";
 SCM makmmacro(code)
      SCM code;
 {
-	register SCM z;
-	ASSERT(scm_arity_check(code, 2L, (char *)0), code, ARG1, s_makmmacro);
-	NEWCELL(z);
-	CDR(z) = code;
-	CAR(z) = tc16_macro | (2L<<16);
-	return z;
+  return makro(code, MAC_MMACRO, s_makmmacro);
+}
+static char s_makidmacro[] = "procedure->identifier-macro";
+SCM makidmacro(code)
+     SCM code;
+{
+  return makro(code, MAC_IDMACRO, s_makidmacro);
 }
 #ifdef MACRO
-/* Functions for (eventual) smart expansion */
+/* Functions for  smart expansion */
+
+/* @MACROEXPAND1 returns:
+   #F if its argument is not a macro invocation,
+   the argument if the argument is a primitive syntax invocation,
+   the result of expansion if the argument is a macro invocation
+   (BEGIN #F) will be returned instead of #F if #F is the result.
+ */
 static char s_macroexpand1[] = "@macroexpand1";
 SCM scm_macroexpand1(x, env)
      SCM x, env;
 {
-  SCM res, proc;
-  if (IMP(x) || NCONSP(x)) return x;
-  res = CAR(x);
-  if (IMP(res) || !IDENTP(res)) return x;
-  ENV_PUSH;
-  PUSH_TRACE;
-  if (NULLP(env))
-    scm_env = env;
-  else {
-    ASSERT(NIMP(env) && ENVP(env), env, ARG2, s_macroexpand1);
-    scm_env = CDR(env);
+  SCM name;
+  if (IMP(x)) return BOOL_F;
+  if (CONSP(x)) {
+    name = CAR(x);
+    if (IMP(name) || !IDENTP(name)) return BOOL_F; /* probably an error */
   }
-  proc = *lookupcar(x, 0);
-  ENV_POP;
-  ALLOW_INTS_EGC;
-  if (NIMP(proc) && MACROP(proc)) {
-    SCM argv[2];
-    switch ((int)(CAR(proc)>>16) & 0x7f) {
-    default: return x;		/* Primitive macro invocation. */
-    case 2: case 1:
-      argv[0] = x;
-      argv[1] = env;
-      res = scm_cvapply(CDR(proc), 2L, argv);
-      if (res==x) return cons(CAR(x), CDR(x));
-      return res;
-    case 0: case 4:		/* Acros, primitive or not. */
-      argv[0] = x;
-      argv[1] = env;
-      return cons2(TOPRENAME(i_quote),
-		   scm_cvapply(CDR(proc), 2L, argv),
-		   EOL);
-    }
+  else if (IDENTP(x)) {
+    name = x;
   }
-  return x;
-}
-static char s_env_ref[] = "environment-ref";
-SCM scm_env_ref(env, ident)
-     SCM env, ident;
-{
-  SCM *p, ret;
-  if NULLP(env) return BOOL_F;
-  ASSERT(NIMP(env) && ENVP(env), env, ARG1, s_env_ref);
-  ASSERT(NIMP(ident) && IDENTP(ident), ident, ARG2, s_env_ref);
-  ENV_PUSH;
-  PUSH_TRACE;
-  scm_env = CDR(env);
-  p = id_denote(ident);
-  ret = p ? *p : BOOL_F;
-  ENV_POP;
-  ALLOW_INTS_EGC;
-  return ret;
-}
-static char s_extended_env[] = "extended-environment";
-SCM scm_extended_env(names, vals, env)
-     SCM names, vals, env;
-{
-  SCM z, nenv;
-# ifndef RECKLESS
-  SCM v = vals;
-  z = names;
-  for (z = names; NIMP(z) && CONSP(z); z = CDR(z)) {
-    ASSERT(NIMP(v) && CONSP(v), vals, ARG2, s_extended_env);
-    v = CDR(v);
-  }
-  ASSERT(NNULLP(z) || NULLP(v), vals, ARG2, s_extended_env);
-# endif
-  nenv = acons(names, vals, env2tree(env));
-  NEWCELL(z);
-  CDR(z) = nenv;
-  CAR(z) = tc16_env | (1L << 16);
-  return z;
+  else
+    return BOOL_F;
+  return macroexp1(x, env, BOOL_F, 0);
 }
+
 static char s_eval_syntax[] = "eval-syntax";
 SCM scm_eval_syntax(x, env)
      SCM x, env;
 {
-  ASSERT(IMP(env) ? NULLP(env) : ENVP(env), env, ARG2, s_eval_syntax);
-  return EVAL(x, env);
+  SCM venv = cons(undefineds, undefineds);
+  CDR(venv) = venv;
+  return EVAL(x, env, venv);
 }
 #endif /* MACRO */
 
@@ -2666,11 +3231,19 @@ static int prinmacro(exp, port, writing)
      SCM port;
      int writing;
 {
-  if (CAR(exp) & (4L<<16)) lputs("#<primitive-", port);
-  else lputs("#<", port);
-  if (CAR(exp) & (3L<<16)) lputs("macro", port);
-  else lputs("syntax", port);
-  if (CAR(exp) & (2L<<16)) lputc('!', port);
+  lputs("#<", port);
+  if (MAC_TYPE(exp) & MAC_PRIMITIVE) lputs("primitive-", port);
+  switch (MAC_TYPE(exp) & ~MAC_PRIMITIVE) {
+  default:
+    lputs("macro", port); break;
+  case MAC_ACRO:
+    lputs("syntax", port); break;
+#ifdef MAC_INLINE
+  case MAC_INLINE:
+    lputs("inline function", port); break;
+#endif
+  }
+  if (MAC_TYPE(exp) & MAC_MEMOIZING) lputc('!', port);
   lputc(' ', port);
   iprin1(CDR(exp), port, writing);
   lputc('>', port);
@@ -2694,8 +3267,8 @@ static int prinid(exp, port, writing)
      int writing;
 {
   SCM s = IDENT_PARENT(exp);
-  while (!IDENTP(s)) s = IDENT_PARENT(s);
-  lputs("#<identifier ", port);
+  while (M_IDENTP(s)) s = IDENT_PARENT(s);
+  lputs("#<id ", port);
   iprin1(s, port, writing);
   lputc(':', port);
   intprint((long)exp, -16, port);
@@ -2707,17 +3280,41 @@ char s_force[] = "force";
 SCM force(x)
      SCM x;
 {
-  ASSERT(NIMP(x) && (TYP16(x)==tc16_promise), x, ARG1, s_force);
-  if (!((1L<<16) & CAR(x))) {
-    SCM ans = scm_cvapply(CDR(x), 0L, (SCM *)0);
-    if (!((1L<<16) & CAR(x))) {
-      DEFER_INTS;
-      CDR(x) = ans;
-      CAR(x) |= (1L<<16);
-      ALLOW_INTS;
+ tail:
+  ASRTGO(NIMP(x) && (TYP16(x)==tc16_promise), badx);
+  switch (CAR(x)>>16) {
+  default:
+  badx: wta(x, (char *)ARG1, s_force);
+  case 0:
+    {
+      SCM ans;
+      int mv = (IM_VALUES_TOKEN==scm_env_tmp);
+      ans = scm_cvapply(CDR(x), 0L, (SCM *)0);
+      if (mv) {
+	DEFER_INTS_EGC;
+	if (IM_VALUES_TOKEN==scm_env_tmp) {
+	  if (!UNBNDP(ans)) mv = 0;
+	}
+	else {
+	  ans = cons2(ans, CAR(scm_env_tmp), CDR(scm_env_tmp));
+	  scm_env_tmp = IM_VALUES_TOKEN;
+	}
+	ALLOW_INTS_EGC;
+      }
+      if (!((1L<<16) & CAR(x))) {
+	DEFER_INTS;
+	CDR(x) = ans;
+	CAR(x) |= mv ? (3L<<16) : (1L<<16);
+	ALLOW_INTS;
+      }
+      goto tail;
     }
+  case 1: return CDR(x);
+  case 3:
+    x = CDR(x);
+    if (UNBNDP(x)) return scm_values(UNDEFINED, UNDEFINED, EOL, s_force);
+    return scm_values(CAR(x), CAR(CDR(x)), CDR(CDR(x)), s_force);
   }
-  return CDR(x);
 }
 
 SCM copytree(obj)
@@ -2743,7 +3340,7 @@ SCM eval(obj)
      SCM obj;
 {
   obj = copytree(obj);
-  return EVAL(obj, (SCM)EOL);
+  return EVAL(obj, EOL, EOL);
 }
 
 SCM definedp(x, env)
@@ -2771,7 +3368,7 @@ static char s_ident_eqp[] = "identifier-equal?";
 SCM ident_eqp(id1, id2, env)
      SCM id1, id2, env;
 {
-  SCM s1 = id1, s2 = id2, ret;
+  SCM s1 = id1, s2 = id2;
 # ifndef RECKLESS
   if IMP(id1)
   badarg1: wta(id1, (char *)ARG1, s_ident_eqp);
@@ -2784,16 +3381,12 @@ SCM ident_eqp(id1, id2, env)
   ASRTGO(SYMBOLP(s1), badarg1);
   ASRTGO(SYMBOLP(s2), badarg2);
   if (s1 != s2) return BOOL_F;
-  ENV_PUSH;
-  PUSH_TRACE;
-  if NULLP(env) scm_env = env;
-  else {
-    ASSERT(NIMP(env) && tc16_env==TYP16(env), env, ARG3, s_ident_eqp);
-    scm_env = CDR(env);
-  }
-  ret = (id_denote(id1)==id_denote(id2)) ? BOOL_T : BOOL_F;
-  ENV_POP;
-  return ret;
+  s1 = scm_env_lookup(id1, env);
+  s2 = scm_env_lookup(id2, env);
+  if (s1==s2) return BOOL_T;
+  if (NIMP(s1) && ISYMP(CAR(s1)))	/* FARLOC case */
+    return equal(s1, s2);
+  return BOOL_F;
 }
 
 static char s_ident2sym[] = "identifier->symbol";
@@ -2811,13 +3404,22 @@ SCM renamed_ident(id, env)
 {
   SCM z;
   ASSERT(NIMP(id) && IDENTP(id), id, ARG1, s_renamed_ident);
-  if NIMP(env) {
-    ASSERT(ENVP(env), env, ARG2, s_renamed_ident);
-    DEFER_INTS_EGC;
-    env = CDR(env);
-  }
   NEWCELL(z);
-  if IMP(env) {
+  while (NIMP(env)) {
+    if (INUMP(CAR(env))) {
+      ASSERT(NIMP(CDR(env)), env, s_badenv, s_renamed_ident);
+      env = CDR(CDR(env));
+    }
+    else if (SCM_LINUMP(CAR(env))) {
+      env = CDR(env);
+    }
+    else {
+      ASSERT(NULLP(env) || (NIMP(env) && CONSP(env)),
+	     env, s_badenv, s_renamed_ident);
+      break;
+    }
+  }
+  if (scm_nullenv_p(env)) {
     CAR(z) = tc16_ident;
     CDR(z) = id;
     return z;
@@ -2825,7 +3427,7 @@ SCM renamed_ident(id, env)
   else {
     SCM y;
     CAR(z) = id;
-    CDR(z) = CAR(CAR(env));
+    CDR(z) = env;
     NEWCELL(y);
     CAR(y) = tc16_ident | 1L<<16;
     CDR(y) = z;
@@ -2834,117 +3436,119 @@ SCM renamed_ident(id, env)
 }
 
 static char s_syn_quote[] = "syntax-quote";
-SCM m_syn_quote(xorig, env)
-     SCM xorig, env;
+SCM m_syn_quote(xorig, env, ctxt)
+     SCM xorig, env, ctxt;
 {
   ASSYNT(ilength(CDR(xorig))==1, xorig, s_expression, s_syn_quote);
   return cons(IM_QUOTE, CDR(xorig));
 }
 
-/* Ensure that the environment for LET-SYNTAX can be uniquely identified. */
-SCM m_atlet_syntax(xorig, env)
-     SCM xorig, env;
-{
-  SCM mark;
-  DEFER_INTS_EGC;
-  if (NIMP(env) && ENVP(env))
-    env = CDR(env);
-  if NULLP(env) return m_let(xorig, env);
-  mark = CAR(CAR(env));
-  if (NIMP(mark) && CONSP(mark)) return m_let(xorig, env);
-  mark = renamed_ident(i_mark, BOOL_F);
-  return m_letstar(cons2(i_let,
-			 cons(cons2(mark, BOOL_F, EOL), EOL),
-			 acons(TOPRENAME(i_let), CDR(xorig), EOL)),
-		   env);
+static char s_defsyntax[] = "defsyntax";
+SCM m_defsyntax(xorig, env, ctxt)
+     SCM xorig, env, ctxt;
+{
+  SCM x = CDR(xorig), name, val;
+  ASSYNT(ilength(x)==2, xorig, s_expression, s_defsyntax);
+  ASSYNT(scm_nullenv_p(env), xorig, s_placement, s_defsyntax);
+  name = CAR(x);
+  ASSYNT(NIMP(name) && IDENTP(name), name, s_variable, s_defsyntax);
+  val = evalcar(CDR(x));
+  ASSYNT(NIMP(val) && MACROP(val), CAR(CDR(x)), s_expr, s_defsyntax);
+  checked_define(name, cons(IM_KEYWORD, val), s_defsyntax);
+  return UNSPECIFIED;
+}
+
+SCM m_let_syntax(xorig, env, ctxt)
+     SCM xorig, env, ctxt;
+{
+  SCM proc, vars, inits, fr;
+  SCM body = m_parse_let(EOL, xorig, CDR(xorig), &vars, &inits);
+  /*  if (IMP(vars)) return m_let_null(body, env, ctxt); */
+  /* Add a unique frame for an environment mark. */
+  env = EXTEND_ENV(cons(SCM_ENV_SYNTAX, EOL), env);
+  for (fr = EOL; NIMP(inits); inits = CDR(inits)) {
+    proc = scm_eval_syntax(CAR(inits), env);
+    ASSYNT(NIMP(proc) && MACROP(proc), CAR(inits), s_expr, s_let_syntax);
+    fr = acons(CAR(vars), proc, fr);
+    vars = CDR(vars);
+  }
+  fr = cons(SCM_ENV_SYNTAX, fr);
+  env = EXTEND_ENV(fr, env);
+  return cons2(IM_LET_SYNTAX, env, m_body(body, env, ctxt));
+}
+static char s_letrec_syntax[] = "letrec-syntax";
+SCM m_letrec_syntax(xorig, env, ctxt)
+     SCM xorig, env, ctxt;
+{
+  SCM proc, vars, vals, inits, fr;
+  SCM body = m_parse_let(EOL, xorig, CDR(xorig), &vars, &inits);
+  /*  if (IMP(vars)) return m_let_null(body, env, ctxt); */
+  for (fr = EOL; NIMP(vars); vars = CDR(vars))
+    fr = acons(CAR(vars), UNDEFINED, fr);
+  fr = cons(SCM_ENV_SYNTAX, fr);
+  env = EXTEND_ENV(fr, env);
+  for (vals = EOL; NIMP(inits); inits = CDR(inits)) {
+    proc = scm_eval_syntax(CAR(inits), env);
+    ASSYNT(NIMP(proc) && MACROP(proc), CAR(inits), s_expr, s_letrec_syntax);
+    vals = cons(proc, vals);
+  }
+  for (fr = CDR(fr); NIMP(fr); fr = CDR(fr)) {
+    CDR(CAR(fr)) = CAR(vals);
+    vals = CDR(vals);
+  }
+  return cons2(IM_LET_SYNTAX, env, m_body(body, env, ctxt));
 }
 
 static char s_the_macro[] = "the-macro";
-SCM m_the_macro(xorig, env)
-     SCM xorig, env;
+SCM m_the_macro(xorig, env, ctxt)
+     SCM xorig, env, ctxt;
 {
-  SCM x = CDR(xorig);
+  SCM addr, x = CDR(xorig);
   ASSYNT(1==ilength(x), xorig, s_expression, s_the_macro);
-  if (NIMP(CAR(x)) && IDENTP(CAR(x)))
-    x = *lookupcar(x, LOOKUP_UNDEFP);
-  else
-    x = evalcar(x);
-  ASSYNT(NIMP(x) && MACROP(x), xorig, ARG1, s_the_macro);
-  return cons2(IM_QUOTE, x, EOL);
+  x = CAR(x);
+  ASSYNT(NIMP(x) && IDENTP(x), x, s_expression, s_the_macro);
+  addr = scm_env_lookup(x, env);
+				/* Require global ref for now. */
+  ASSYNT(NIMP(addr) && SYMBOLP(addr), x, s_expression, s_the_macro);
+  x = CDR(sym2vcell(addr));
+  ASSYNT(KEYWORDP(x), xorig, ARG1, s_the_macro);
+  return KEYWORD_MACRO(x);
 }
 #endif
 
-static char s_env2tree[] = "environment->tree";
-SCM env2tree(env)
-     SCM env;
-{
-  SCM ans, a, *lloc;
-  if NULLP(env) return env;
-  ASSERT(NIMP(env) && ENVP(env), env, ARG1, s_env2tree);
-  if ((1L << 16) & CAR(env)) return CDR(env);
-  if IMP(CDR(env)) return CDR(env);
-  ENV_PUSH;
-  PUSH_TRACE;
-  scm_env = CDR(env);
-  ans = a = cons(UNSPECIFIED, UNSPECIFIED);
-  while (!0) {
-    scm_env_tmp = CAR(scm_env);
-    lloc = &CAR(a);
-    while (NIMP(scm_env_tmp) && CONSP(scm_env_tmp)) {
-      if (undefineds==*lloc) {
-        *lloc = BOOL_F;
-        break;
-      }
-      *lloc = cons(CAR(scm_env_tmp), CDR(scm_env_tmp));
-      lloc = &CDR(*lloc);
-      DEFER_INTS_EGC;
-      scm_env_tmp = CDR(scm_env_tmp);
-    }
-    scm_env = CDR(scm_env);
-    if IMP(scm_env) {
-      CDR(a) = scm_env;
-      break;
-    }
-    a = (CDR(a) = cons(UNSPECIFIED, UNSPECIFIED));
-  }
-  ENV_POP;
-  ALLOW_INTS_EGC;
-  CDR(env) = ans;		/* Memoize migrated environment. */
-  CAR(env) |= (1L << 16);
-  return ans;
-}
-
 static iproc subr1s[] = {
 	{"@copy-tree", copytree},
 /*	{s_eval, eval}, now a (tail recursive) specfun */
 	{s_force, force},
 	{s_proc_doc, l_proc_doc},
-	{"procedure->syntax", makacro},
-	{"procedure->macro", makmacro},
-	{"procedure->memoizing-macro", makmmacro},
+	{s_makacro, makacro},
+	{s_makmacro, makmacro},
+	{s_makmmacro, makmmacro},
+	{s_makidmacro, makidmacro},
 	{"apply:nconc-to-last", nconc2copy},
-	{s_env2tree, env2tree},
+	/*	{s_env2tree, env2tree}, */
 #ifdef MACRO
 	{s_identp, identp},
 	{s_ident2sym, ident2sym},
 #endif
 	{0, 0}};
 
-static iproc lsubr2s[] = {
-/*	{s_apply, apply}, now explicity initted */
-	{s_map, map},
-	{s_for_each, for_each},
+static iproc subr2s[] = {
 #ifdef MACRO
 	{s_macroexpand1, scm_macroexpand1},
-	{s_env_ref, scm_env_ref},
 	{s_eval_syntax, scm_eval_syntax},
 #endif
 	{0, 0}};
 
+static iproc lsubr2s[] = {
+/*	{s_apply, apply}, now explicity initted */
+	{s_map, map},
+	{s_for_each, for_each},
+	{0, 0}};
+
 static iproc subr3s[] = {
 #ifdef MACRO
   {s_ident_eqp, ident_eqp},
-  {s_extended_env, scm_extended_env},
 #endif
   {0, 0}};
 
@@ -2955,25 +3559,28 @@ static smobfuns envsmob = {markcdr, free0, prinenv};
 static smobfuns idsmob = {markcdr, free0, prinid};
 #endif
 
-SCM make_synt(name, macroizer, fcn)
+SCM make_synt(name, flags, fcn)
      const char *name;
-     SCM (*macroizer)();
+     long flags;
      SCM (*fcn)();
 {
   SCM symcell = sysintern(name, UNDEFINED);
-  SCM z = macroizer(scm_maksubr(name, tc7_subr_2, fcn));
-  CAR(z) |= (4L << 16);         /* Flags result as primitive macro. */
+  SCM z = makro(scm_maksubr(name, tc7_subr_3, fcn),
+		flags | MAC_PRIMITIVE, "make_synt");
+#ifdef MACRO
+  z = cons(IM_KEYWORD, z);
+#endif
   CDR(symcell) = z;
   return CAR(symcell);
 }
-SCM make_specfun(name, typ)
+SCM make_specfun(name, typ, flags)
      char *name;
-     int typ;
+     int typ, flags;
 {
   SCM symcell = sysintern(name, UNDEFINED);
   register SCM z;
   NEWCELL(z);
-  CAR(z) = (long)typ;
+  CAR(z) = (long)typ | ((long)flags)<<16;
   CDR(z) = CAR(symcell);
   CDR(symcell) = z;
   return z;
@@ -2984,56 +3591,81 @@ void init_eval()
   tc16_macro = newsmob(&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)))");
 }