Import Upstream version 5c3upstream/5c3

1 files changed, 1200 insertions, 481 deletions

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