Import Upstream version 5d2upstream/5d2

1 files changed, 910 insertions, 446 deletions

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