Import Upstream version 5b3upstream/5b3

1 files changed, 468 insertions, 106 deletions

diff --git a/eval.c b/eval.c
index 2cf04fe..8620edc 100644
--- a/eval.c
+++ b/eval.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc.
+/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1997 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
@@ -47,17 +47,36 @@
 
 #define I_SYM(x) (CAR((x)-1L))
 #define I_VAL(x) (CDR((x)-1L))
-#define EVALCELLCAR(x, env) SYMBOLP(CAR(x))?*lookupcar(x, env):ceval(CAR(x), env)
-#ifdef MEMOIZE_LOCALS
-# define EVALIMP(x, env) (ILOCP(x)?*ilookup((x), env):x)
+#ifdef MACRO
+# define ATOMP(x) (5==(5 & (int)CAR(x)))
+# define EVALCELLCAR(x,env) (ATOMP(CAR(x))?evalatomcar(x,env):ceval(CAR(x),env))
 #else
-# define EVALIMP(x, env) x
+# define EVALCELLCAR(x, env) SYMBOLP(CAR(x))?*lookupcar(x, env):ceval(CAR(x), env)
 #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
 
-#ifdef MEMOIZE_LOCALS
+long tc16_macro;		/* Type code for macros */
+#define MACROP(x) (tc16_macro==TYP16(x))
+
+#ifdef MACRO
+long tc16_ident;		/* synthetic macro identifier */
+SCM i_mark;
+static char s_escaped[] = "escaped synthetic identifier";
+# define M_IDENTP(x) (tc16_ident==TYP16(x))
+# define M_IDENT_LEXP(x) ((tc16_ident | (1L<<16))==CAR(x))
+# define IDENTP(x) (SYMBOLP(x) || M_IDENTP(x))
+# define IDENT_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
+#else
+# define IDENTP SYMBOLP
+#endif
+
 SCM *ilookup(iloc, env)
      SCM iloc, env;
 {
@@ -69,56 +88,89 @@ SCM *ilookup(iloc, env)
   if ICDRP(iloc) return &CDR(er);
   return &CAR(CDR(er));
 }
-#endif
+
+SCM *farlookup(farloc, env)
+     SCM farloc, env;
+{
+  register int ir;
+  register SCM er = env;
+  SCM x = CDR(farloc);
+  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);
+  if (IM_FARLOC_CDR==CAR(farloc)) return &CDR(er);
+  return &CAR(CDR(er));
+}
+
 SCM *lookupcar(vloc, genv)
      SCM vloc, genv;
 {
   SCM env = genv;
   register SCM *al, fl, var = CAR(vloc);
-#ifdef MEMOIZE_LOCALS
-  register SCM iloc = ILOC00;
+  register unsigned int idist, iframe = 0;
+#ifdef MACRO
+  SCM mark = IDENT_MARK(var);
 #endif
-  for(;NIMP(env);env = CDR(env)) {
+  for(; NIMP(env); env = CDR(env)) {
+    idist = 0;
     al = &CAR(env);
     for(fl = CAR(*al);NIMP(fl);fl = CDR(fl)) {
+#ifdef MACRO
+      if (fl==mark) {
+	var = IDENT_PARENT(var);
+	mark = IDENT_MARK(var);
+      }
+#endif
       if NCONSP(fl)
 	if (fl==var) {
-#ifdef MEMOIZE_LOCALS
-	  CAR(vloc) = iloc + ICDR;
+#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);
 	}
 	else break;
       al = &CDR(*al);
       if (CAR(fl)==var) {
-#ifdef MEMOIZE_LOCALS
-# ifndef RECKLESS		/* letrec inits to UNDEFINED */
+#ifndef RECKLESS		/* letrec inits to UNDEFINED */
 	if UNBNDP(CAR(*al)) {env = EOL; goto errout;}
-# endif
-	CAR(vloc) = iloc;
 #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);
       }
-#ifdef MEMOIZE_LOCALS
-      iloc += IDINC;
-#endif
+      idist++;
     }
-#ifdef MEMOIZE_LOCALS
-    iloc = (~IDSTMSK) & (iloc + IFRINC);
-#endif
+    iframe++;
+  }
+#ifdef MACRO
+  while M_IDENTP(var) {
+    ASRTGO(IMP(IDENT_MARK(var)), errout);
+    var = IDENT_PARENT(var);
   }
+#endif
   var = sym2vcell(var);
 #ifndef RECKLESS
   if (NNULLP(env) || UNBNDP(CDR(var))) {
     var = CAR(var);
   errout:
     everr(vloc, genv, var,
-	  NULLP(env)?"unbound variable: ":"damaged environment", "");
+# ifdef MACRO
+	  M_IDENTP(var) ? s_escaped :
+# endif
+	  (NULLP(env) ? "unbound variable: " : "damaged environment"), "");
   }
 #endif
   CAR(vloc) = var + 1;
   return &CDR(var);
 }
+
 static SCM unmemocar(form, env)
      SCM form, env;
 {
@@ -126,17 +178,48 @@ static SCM unmemocar(form, env)
   if IMP(form) return form;
   if (1==TYP3(form))
     CAR(form) = I_SYM(CAR(form));
-#ifdef MEMOIZE_LOCALS
   else if ILOCP(CAR(form)) {
     for(ir = IFRAME(CAR(form)); ir != 0; --ir) env = CDR(env);
     env = CAR(CAR(env));
     for(ir = IDIST(CAR(form));ir != 0;--ir) env = CDR(env);
     CAR(form) = ICDRP(CAR(form)) ? env : CAR(env);
   }
-#endif
   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;
+{
+  SCM r;
+  switch TYP7(CAR(x)) {
+  default:
+    everr(x, 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;
+  case tc7_vector:
+  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;
 {
@@ -163,10 +246,65 @@ static char s_formals[] = "bad formals";
 
 SCM i_dot, i_quote, i_quasiquote, i_lambda,
   i_let, i_arrow, i_else, i_unquote, i_uq_splicing, i_apply;
-static char s_quasiquote[] = "quasiquote";
-static char s_delay[] = "delay";
 
 #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 TOPRENAME(v) (renamed_ident(v, BOOL_F))
+
+static SCM ident2sym(id)
+     SCM id;
+{
+  if NIMP(id)
+    while M_IDENTP(id)
+      id = IDENT_PARENT(id);
+  return id;
+}
+
+static SCM *id_denote(var, env)
+     SCM var, env;
+{
+  register SCM *al, fl;
+  SCM mark = IDENT_MARK(var);
+  for(;NIMP(env); env = CDR(env)) {
+    al = &CAR(env);
+    for(fl = CAR(*al);NIMP(fl);fl = CDR(fl)) {
+      if (fl==mark) {
+	var = IDENT_PARENT(var);
+	mark = IDENT_MARK(var);
+      }
+      if NCONSP(fl)
+	if (fl==var) return &CDR(*al);
+	else break;
+      al = &CDR(*al);
+      if (CAR(fl)==var) return &CAR(*al);
+    }
+  }
+  return (SCM *)0;
+}
+
+static void unpaint(p)
+     SCM *p;
+{
+  SCM x;
+  while NIMP((x = *p)) {
+    if CONSP(x) {
+      if NIMP(CAR(x)) unpaint(&CAR(x));
+      p = &CDR(*p);
+    }      
+    else {
+      while M_IDENTP(x) *p = x = IDENT_PARENT(x);
+      return;
+    }
+  }
+}
+#else /* def MACRO */
+# define TOPDENOTE_EQ(sym, x, env) ((sym)==(x))
+# define TOPLEVELP(x,env) (!0)
+# define TOPRENAME(v) (v)
+#endif
 
 static void bodycheck(xorig, bodyloc, what)
      SCM xorig, *bodyloc;
@@ -179,6 +317,11 @@ SCM m_quote(xorig, env)
      SCM xorig, env;
 {
   ASSYNT(ilength(CDR(xorig))==1, xorig, s_expression, s_quote);
+#ifdef MACRO
+  DEFER_INTS;
+  unpaint(&CAR(CDR(xorig)));
+  ALLOW_INTS;
+#endif
   return cons(IM_QUOTE, CDR(xorig));
 }
 
@@ -202,7 +345,7 @@ SCM m_set(xorig, env)
 {
   SCM x = CDR(xorig);
   ASSYNT(2==ilength(x), xorig, s_expression, s_set);
-  ASSYNT(NIMP(CAR(x)) && SYMBOLP(CAR(x)),
+  ASSYNT(NIMP(CAR(x)) && IDENTP(CAR(x)),
 	 xorig, s_variable, s_set);
   return cons(IM_SET, x);
 }
@@ -233,8 +376,16 @@ SCM m_case(xorig, env)
   while(NIMP(x = CDR(x))) {
     proc = CAR(x);
     ASSYNT(ilength(proc) >= 2, xorig, s_clauses, s_case);
-    ASSYNT(ilength(CAR(proc)) >= 0 || i_else==CAR(proc),
-	   xorig, s_clauses, s_case);
+    if TOPDENOTE_EQ(i_else, CAR(proc), env)
+		     CAR(proc) = IM_ELSE;
+    else {
+      ASSYNT(ilength(CAR(proc)) >= 0, xorig, s_clauses, s_case);
+#ifdef MACRO
+      DEFER_INTS;
+      unpaint(&CAR(proc));
+      ALLOW_INTS;
+#endif
+    }
   }
   return cons(IM_CASE, CDR(xorig));
 }
@@ -249,13 +400,15 @@ SCM m_cond(xorig, env)
     arg1 = CAR(x);
     len = ilength(arg1);
     ASSYNT(len >= 1, xorig, s_clauses, s_cond);
-    if (i_else==CAR(arg1)) {
+    if TOPDENOTE_EQ(i_else, CAR(arg1), env) {
       ASSYNT(NULLP(CDR(x)) && len >= 2, xorig, "bad ELSE clause", s_cond);
       CAR(arg1) = BOOL_T;
     }
-    if (len >= 2 && i_arrow==CAR(CDR(arg1)))
-      ASSYNT(3==len && NIMP(CAR(CDR(CDR(arg1)))),
-	     xorig, "bad recipient", s_cond);
+    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;
+    }
     x = CDR(x);
   }
   return cons(IM_COND, CDR(xorig));
@@ -269,13 +422,13 @@ SCM m_lambda(xorig, env)
   proc = CAR(x);
   if NULLP(proc) goto memlambda;
   if IMP(proc) goto badforms;
-  if SYMBOLP(proc) goto memlambda;
+  if IDENTP(proc) goto memlambda;
   if NCONSP(proc) goto badforms;
   while NIMP(proc) {
     if NCONSP(proc)
-      if (!SYMBOLP(proc)) goto badforms;
+      if (!IDENTP(proc)) goto badforms;
       else goto memlambda;
-    if (!(NIMP(CAR(proc)) && SYMBOLP(CAR(proc)))) goto badforms;
+    if (!(NIMP(CAR(proc)) && IDENTP(CAR(proc)))) goto badforms;
     proc = CDR(proc);
   }
   if NNULLP(proc)
@@ -295,7 +448,7 @@ SCM m_letstar(xorig, env)
   while NIMP(proc) {
     arg1 = CAR(proc);
     ASSYNT(2==ilength(arg1), xorig, s_bindings, s_letstar);
-    ASSYNT(NIMP(CAR(arg1)) && SYMBOLP(CAR(arg1)), xorig, s_variable, s_letstar);
+    ASSYNT(NIMP(CAR(arg1)) && IDENTP(CAR(arg1)), xorig, s_variable, s_letstar);
     *varloc = cons2(CAR(arg1), CAR(CDR(arg1)), EOL);
     varloc = &CDR(CDR(*varloc));
     proc = CDR(proc);
@@ -332,7 +485,7 @@ 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)) && SYMBOLP(CAR(arg1)), xorig, s_variable, 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);
@@ -358,59 +511,109 @@ static SCM evalcar(x, env)
   return EVALCAR(x, env);
 }
 
-static SCM iqq(form, env, depth)
+/* Here are acros which return values rather than code. */
+
+static SCM iqq(form, env)
      SCM form, env;
-     int depth;
 {
   SCM tmp;
-  int edepth = depth;
   if IMP(form) return form;
   if VECTORP(form) {
     long i = LENGTH(form);
     SCM *data = VELTS(form);
     tmp = EOL;
     for(;--i >= 0;) tmp = cons(data[i], tmp);
-    return vector(iqq(tmp, env, depth));
+    return vector(iqq(tmp, env));
   }
   if NCONSP(form) return form;
   tmp = CAR(form);
-  if (i_quasiquote==tmp) {
-    depth++;
-    goto label;
+  if (IM_UNQUOTE==tmp) 
+    return evalcar(CDR(form), env);
+  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));
+}
+
+static SCM m_iqq(form, depth, env)
+     SCM form, env;
+     int depth;
+{
+  SCM tmp;
+  int edepth = depth;
+  if IMP(form) return form;
+  if VECTORP(form) {
+    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);
+      tmp = CDR(tmp);
+    }
+    return form;
   }
-  if (i_unquote==tmp) {
-    --depth;
-  label:
-    form = CDR(form);
-    ASSERT(NIMP(form) && ECONSP(form) && NULLP(CDR(form)),
-	   form, ARG1, s_quasiquote);
-    if (0==depth) return evalcar(form, env);
-    return cons2(tmp, iqq(CAR(form), env, depth), EOL);
+  if NCONSP(form) {
+#ifdef MACRO
+    while M_IDENTP(form) form = IDENT_PARENT(form);
+#endif
+    return form;
   }
-  if (NIMP(tmp) && (i_uq_splicing==CAR(tmp))) {
-    tmp = CDR(tmp);
-    if (0==--edepth)
-      return append(cons2(evalcar(tmp, env), iqq(CDR(form), env, depth), EOL));
+  tmp = CAR(form);
+  if NIMP(tmp) {
+    if IDENTP(tmp) {
+#ifdef MACRO
+      while M_IDENTP(tmp) tmp = IDENT_PARENT(tmp);
+#endif
+      if (i_quasiquote==tmp && TOPLEVELP(CAR(form), env)) {
+	depth++;
+	if (0==depth) CAR(form) = IM_QUASIQUOTE;
+	goto label;
+      }
+      if (i_unquote==tmp && TOPLEVELP(CAR(form), env)) {
+	--depth;
+	if (0==depth) CAR(form) = IM_UNQUOTE; 
+      label:
+	tmp = CDR(form);
+	ASSERT(NIMP(tmp) && ECONSP(tmp) && NULLP(CDR(tmp)),
+	       tmp, ARG1, s_quasiquote);
+	if (0!=depth) CAR(tmp) = m_iqq(CAR(tmp), depth, env);
+	return form;
+      }
+    }
+    else {
+      if TOPDENOTE_EQ(i_uq_splicing, CAR(tmp), env) {
+	if (0==--edepth) {
+	  CAR(tmp) = IM_UQ_SPLICING;
+	  CDR(form) = m_iqq(CDR(form), depth, env);
+	  return form;
+	}
+      }
+      CAR(form) = m_iqq(tmp, edepth, env);
+    }
   }
-  return cons(iqq(CAR(form), env, edepth), iqq(CDR(form), env, depth));
+  CAR(form) = tmp;
+  CDR(form) = m_iqq(CDR(form), depth, env);
+  return form;
 }
-
-/* Here are acros which return values rather than code. */
-
 SCM m_quasiquote(xorig, env)
      SCM xorig, env;
 {
   SCM x = CDR(xorig);
   ASSYNT(ilength(x)==1, xorig, s_expression, s_quasiquote);
-  return iqq(CAR(x), env, 1);
+  DEFER_INTS;
+  x = m_iqq(x, 1, env);
+  ALLOW_INTS;
+  return cons(IM_QUASIQUOTE, x);
 }
 
 SCM m_delay(xorig, env)
      SCM xorig, env;
 {
   ASSYNT(ilength(xorig)==2, xorig, s_expression, s_delay);
-  xorig = CDR(xorig);
-  return makprom(closure(cons2(EOL, CAR(xorig), CDR(xorig)), env));
+  return cons2(IM_DELAY, EOL, CDR(xorig));
 }
 
 extern int verbose;
@@ -422,16 +625,24 @@ SCM m_define(x, env)
   ASSYNT(ilength(x) >= 2, arg1, s_expression, s_define);
   proc = CAR(x); x = CDR(x);
   while (NIMP(proc) && CONSP(proc)) { /* nested define syntax */
-    x = cons(cons2(i_lambda, CDR(proc), x), EOL);
+    x = cons(cons2(TOPRENAME(i_lambda), CDR(proc), x), EOL);
     proc = CAR(proc);
   }
-  ASSYNT(NIMP(proc) && SYMBOLP(proc), arg1, s_variable, s_define);
+  ASSYNT(NIMP(proc) && IDENTP(proc), arg1, s_variable, s_define);
   ASSYNT(1==ilength(x), arg1, s_expression, s_define);
   if NULLP(env) {
-    x = evalcar(x, env);
+    x = evalcar(x,env);
+#ifdef MACRO
+    while M_IDENTP(proc) {
+      ASSYNT(IMP(IDENT_MARK(proc)), proc, s_escaped, s_define);
+      proc = IDENT_PARENT(proc);
+    }
+#endif
     arg1 = sym2vcell(proc);
 #ifndef RECKLESS
-    if (NIMP(CDR(arg1)) && ((SCM) SNAME(CDR(arg1))==proc)
+    if (NIMP(CDR(arg1)) &&
+	(proc ==
+	 ((SCM) SNAME(MACROP(CDR(arg1)) ? CDR(CDR(arg1)) : CDR(arg1))))
 	&& (CDR(arg1) != x))
       warn("redefining built-in ", CHARS(proc));
     else
@@ -440,12 +651,12 @@ SCM m_define(x, env)
       warn("redefining ", CHARS(proc));
     CDR(arg1) = x;
 #ifdef SICP
-    return cons2(i_quote, CAR(arg1), EOL);
+    return m_quote(cons2(i_quote, CAR(arg1), EOL), EOL);
 #else
     return UNSPECIFIED;
 #endif
   }
-  return cons2(IM_DEFINE, proc, x);
+  return cons2(IM_DEFINE, cons(proc,CAR(CAR(env))), x);
 }
 /* end of acros */
 
@@ -465,7 +676,7 @@ SCM m_letrec(xorig, env)
     /* vars list reversed here, inits reversed at evaluation */
     arg1 = CAR(proc);
     ASRTSYNTAX(2==ilength(arg1), s_bindings);
-    ASRTSYNTAX(NIMP(CAR(arg1)) && SYMBOLP(CAR(arg1)), s_variable);
+    ASRTSYNTAX(NIMP(CAR(arg1)) && IDENTP(CAR(arg1)), s_variable);
     vars = cons(CAR(arg1), vars);
     *initloc = cons(CAR(CDR(arg1)), EOL);
     initloc = &CDR(*initloc);
@@ -491,7 +702,7 @@ SCM m_let(xorig, 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)));
-  if (!SYMBOLP(proc)) wta(xorig, s_bindings, s_let); /* bad let */
+  if (!IDENTP(proc)) wta(xorig, s_bindings, s_let); /* bad let */
   name = proc;			/* named let, build equiv letrec */
   x = CDR(x);
   ASSYNT(ilength(x) >= 2, xorig, s_body, s_let);
@@ -500,7 +711,7 @@ SCM m_let(xorig, env)
   while NIMP(proc) {		/* vars and inits both in order */
     arg1 = CAR(proc);
     ASSYNT(2==ilength(arg1), xorig, s_bindings, s_let);
-    ASSYNT(NIMP(CAR(arg1)) && SYMBOLP(CAR(arg1)), xorig, s_variable, s_let);
+    ASSYNT(NIMP(CAR(arg1)) && IDENTP(CAR(arg1)), xorig, s_variable, s_let);
     *varloc = cons(CAR(arg1), EOL);
     varloc = &CDR(*varloc);
     *initloc = cons(CAR(CDR(arg1)), EOL);
@@ -509,7 +720,9 @@ SCM m_let(xorig, env)
   }
   return
     m_letrec(cons2(i_let,
-		   cons(cons2(name, cons2(i_lambda, vars, CDR(x)), EOL), EOL),
+		   cons(cons2(name, 
+			      cons2(TOPRENAME(i_lambda), vars, CDR(x)), EOL),
+			EOL),
 		   acons(name, inits, EOL)), /* body */
 	     env);
 }
@@ -548,7 +761,6 @@ int badargsp(formals, args)
 
 char s_map[] = "map", s_for_each[] = "for-each", s_eval[] = "eval";
 SCM eqv P((SCM x, SCM y));
-long tc16_macro;		/* Type code for macros */
 #ifdef CAUTIOUS
 static char s_bottom[] = "stacktrace bottommed out";
 #endif
@@ -591,7 +803,7 @@ SCM ceval(x, env)
       x = CAR(x);
       return IMP(x)?EVALIMP(x, env):I_VAL(x);
     }
-    if SYMBOLP(CAR(x)) {
+    if IDENTP(CAR(x)) {
  retval:
       return *lookupcar(x, env);
     }
@@ -601,19 +813,22 @@ SCM ceval(x, env)
   case (127 & IM_CASE):
     x = CDR(x);
     t.arg1 = EVALCAR(x, env);
+#ifndef INUMS_ONLY
+    arg2 = (SCM)(IMP(t.arg1) || !NUMP(t.arg1));
+#endif
     while(NIMP(x = CDR(x))) {
       proc = CAR(x);
-      if (i_else==CAR(proc)) {
+      if (IM_ELSE==CAR(proc)) {
 	x = CDR(proc);
 	goto begin;
       }
       proc = CAR(proc);
       while NIMP(proc) {
-	if (CAR(proc)==t.arg1
-#ifdef FLOATS
-	    || NFALSEP(eqv(CAR(proc), t.arg1))
+	if (
+#ifndef INUMS_ONLY
+	    arg2 ? NFALSEP(eqv(CAR(proc), t.arg1)) :
 #endif
-	    ) {
+	    (CAR(proc)==t.arg1)) {
 	  x = CDR(CAR(x));
 	  goto begin;
 	}
@@ -628,7 +843,7 @@ SCM ceval(x, env)
       if NFALSEP(t.arg1) {
 	x = CDR(proc);
 	if NULLP(x) return t.arg1;
-	if (i_arrow != CAR(x)) goto begin;
+	if (IM_ARROW != CAR(x)) goto begin;
 	proc = CDR(x);
 	proc = EVALCAR(proc, env);
 	ASRTGO(NIMP(proc), badfun);
@@ -718,16 +933,26 @@ SCM ceval(x, env)
     proc = CAR(x);
     switch (7 & (int)proc) {
     case 0:
-      t.lloc = lookupcar(x, env);
+      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
+      }
       break;
     case 1:
       t.lloc = &I_VAL(proc);
       break;
-#ifdef MEMOIZE_LOCALS
     case 4:
       t.lloc = ilookup(proc, env);
       break;
-#endif
     }
     x = CDR(x);
     *t.lloc = EVALCAR(x, env);
@@ -743,7 +968,7 @@ SCM ceval(x, env)
     x = evalcar(x, env);
     env = CAR(env);
     DEFER_INTS;
-    CAR(env) = cons(proc, CAR(env));
+    CAR(env) = proc;
     CDR(env) = cons(x, CDR(env));
     ALLOW_INTS;
     return UNSPECIFIED;
@@ -770,7 +995,7 @@ SCM ceval(x, env)
       goto evapply;
     case (ISYMNUM(IM_CONT)):
       t.arg1 = scm_make_cont();
-      if (proc = setjmp(CONT(t.arg1)->jmpbuf))
+      if ((proc = setjump(CONT(t.arg1)->jmpbuf)))
 #ifdef SHORT_INT
 	return (SCM)thrown_value;
 #else
@@ -792,6 +1017,13 @@ SCM ceval(x, env)
       }
 #endif
       goto evap1;
+    case (ISYMNUM(IM_DELAY)):
+      return makprom(closure(CDR(x), env));
+    case (ISYMNUM(IM_QUASIQUOTE)):
+      return iqq(CAR(CDR(x)), env);
+    case (ISYMNUM(IM_FARLOC_CAR)):
+    case (ISYMNUM(IM_FARLOC_CDR)):
+      return *farlookup(x, env);
     default:
       goto badfun;
     }
@@ -804,18 +1036,22 @@ SCM ceval(x, env)
   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;
-#ifdef MEMOIZE_LOCALS
   case (127 & ILOC00):
     proc = *ilookup(CAR(x), env);
     ASRTGO(NIMP(proc), badfun);
-# ifndef RECKLESS
-#  ifdef CAUTIOUS
+#ifndef RECKLESS
+# ifdef CAUTIOUS
     goto checkargs;
-#  endif
 # endif
+#endif
     break;
-#endif /* ifdef MEMOIZE_LOCALS */
   case tcs_cons_gloc:
     proc = I_VAL(CAR(x));
     ASRTGO(NIMP(proc), badfun);
@@ -826,14 +1062,14 @@ SCM ceval(x, env)
 #endif
     break;
   case tcs_cons_nimcar:
-    if SYMBOLP(CAR(x)) {
+    if IDENTP(CAR(x)) {
       proc = *lookupcar(x, env);
       if IMP(proc) {unmemocar(x, env); goto badfun;}
-      if (tc16_macro==TYP16(proc)) {
+      if MACROP(proc) {
 	unmemocar(x, env);
 	t.arg1 = apply(CDR(proc), x, cons(env, listofnull));
 	switch ((int)(CAR(proc)>>16)) {
-	case 2:
+	case 2:			/* mmacro */
 	  if (ilength(t.arg1) <= 0)
 	    t.arg1 = cons2(IM_BEGIN, t.arg1, EOL);
 	  DEFER_INTS;
@@ -841,9 +1077,9 @@ SCM ceval(x, env)
 	  CDR(x) = CDR(t.arg1);
 	  ALLOW_INTS;
 	  goto loop;
-	case 1:
+	case 1:			/* macro */
 	  if NIMP(x = t.arg1) goto loop;
-	case 0:
+	case 0:			/* acro */
 	  return t.arg1;
 	}
       }
@@ -1142,7 +1378,7 @@ SCM apply(proc, arg1, args)
     args = NULLP(args)?UNDEFINED:CAR(args);
     return SUBRF(proc)(arg1, args);
   case tc7_subr_2:
-    ASRTGO(NULLP(CDR(args)), wrongnumargs);
+    ASRTGO(NIMP(args) && NULLP(CDR(args)), wrongnumargs);
     args = CAR(args);
     return SUBRF(proc)(arg1, args);
   case tc7_subr_0:
@@ -1364,12 +1600,27 @@ static int prinmacro(exp, port, writing)
   lputc('>', port);
   return !0;
 }
-
+#ifdef MACRO
+static int prinid(exp, port, writing)
+     SCM exp;
+     SCM port;
+     int writing;
+{
+  SCM s = IDENT_PARENT(exp);
+  while (!IDENTP(s)) s = IDENT_PARENT(s);
+  lputs("#<identifier ", port);
+  iprin1(s, port, writing);
+  lputc(':', port);
+  intprint((long)exp, 16, port);
+  lputc('>', port);
+  return !0;
+}
+#endif
 char s_force[] = "force";
 SCM force(x)
      SCM x;
 {
-  ASSERT((TYP16(x)==tc16_promise), x, ARG1, s_force);
+  ASSERT(NIMP(x) && (TYP16(x)==tc16_promise), x, ARG1, s_force);
   if (!((1L<<16) & CAR(x))) {
     SCM ans = apply(CDR(x), EOL, EOL);
     if (!((1L<<16) & CAR(x))) {
@@ -1412,14 +1663,108 @@ SCM definedp(x, env)
      SCM x, env;
 {
   SCM proc = CAR(x = CDR(x));
+#ifdef MACRO
+  proc = ident2sym(proc);
+#endif
   return (ISYMP(proc)
-	  || (NIMP(proc) && SYMBOLP(proc)
+	  || (NIMP(proc) && IDENTP(proc)
 	      && !UNBNDP(CDR(sym2vcell(proc)))))?
 		(SCM)BOOL_T : (SCM)BOOL_F;
 }
 
+#ifdef MACRO
+static char s_identp[] = "identifier?";
+SCM identp(obj)
+     SCM obj;
+{
+  return (NIMP(obj) && IDENTP(obj)) ? BOOL_T : BOOL_F;
+}
+
+static char s_ident_eqp[] = "identifier-equal?";
+SCM ident_eqp(id1, id2, env)
+     SCM id1, id2, env;
+{
+  SCM s1 = id1, s2 = id2;
+# ifndef RECKLESS
+  if IMP(id1)
+  badarg1: wta(id1, (char *)ARG1, s_ident_eqp);
+  if IMP(id1)
+  badarg2: wta(id2, (char *)ARG2, s_ident_eqp);
+# endif
+  if (id1==id2) return BOOL_T;
+  while M_IDENTP(s1) s1 = IDENT_PARENT(s1);
+  while M_IDENTP(s2) s2 = IDENT_PARENT(s2);
+  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;
+}
+
+static char s_renamed_ident[] = "renamed-identifier";
+SCM renamed_ident(id, env)
+     SCM id, env;
+{
+  SCM z;
+  ASSERT(NIMP(id) && IDENTP(id), id, ARG1, s_renamed_ident);
+  NEWCELL(z);
+  if IMP(env) {
+    CAR(z) = tc16_ident;
+    CDR(z) = id;
+    return z;
+  }
+  else {
+    SCM y;
+    CAR(z) = id;
+    CDR(z) = CAR(CAR(env));
+    NEWCELL(y);
+    CAR(y) = tc16_ident | 1L<<16;
+    CDR(y) = z;
+    return y;
+  }
+}
+
+static char s_syn_quote[] = "syntax-quote";
+SCM m_syn_quote(xorig, env)
+     SCM xorig, env;
+{
+  ASSYNT(ilength(CDR(xorig))==1, xorig, s_expression, s_syn_quote);
+  return cons(IM_QUOTE, CDR(xorig));
+}
+
+/* Ensure that the environment for LET-SYNTAX can be uniquely identified. */
+SCM m_atlet_syntax(xorig, env)
+     SCM xorig, env;
+{
+  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);
+  }
+}
+
+static char s_the_macro[] = "the-macro";
+SCM m_the_macro(xorig, env)
+     SCM 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);
+  else
+    x = evalcar(x, env);
+  ASSYNT(NIMP(x) && MACROP(x), xorig, ARG1, s_the_macro);
+  return cons2(IM_QUOTE, x, EOL);
+}
+#endif
+
+
 static iproc subr1s[] = {
-	{"copy-tree", copytree},
+	{"@copy-tree", copytree},
 	{s_eval, eval},
 	{s_force, force},
 	{s_proc_doc, l_proc_doc},
@@ -1427,6 +1772,9 @@ static iproc subr1s[] = {
 	{"procedure->macro", makmacro},
 	{"procedure->memoizing-macro", makmmacro},
 	{"apply:nconc-to-last", nconc2last},
+#ifdef MACRO
+	{s_identp, identp},
+#endif
 	{0, 0}};
 
 static iproc lsubr2s[] = {
@@ -1437,6 +1785,9 @@ static iproc lsubr2s[] = {
 
 static smobfuns promsmob = {markcdr, free0, prinprom};
 static smobfuns macrosmob = {markcdr, free0, prinmacro};
+#ifdef MACRO
+static smobfuns idsmob = {markcdr, free0, prinid};
+#endif
 
 SCM make_synt(name, macroizer, fcn)
      char *name;
@@ -1469,9 +1820,10 @@ void init_eval()
   i_uq_splicing = CAR(sysintern("unquote-splicing", UNDEFINED));
 
   /* acros */
-  i_quasiquote = make_synt(s_quasiquote, makacro, m_quasiquote);
+  i_quasiquote = make_synt(s_quasiquote, makmmacro, m_quasiquote);
   make_synt(s_define, makmmacro, m_define);
-  make_synt(s_delay, makacro, m_delay);
+  make_synt(s_delay, makmmacro, m_delay);
+  make_synt("defined?", makacro, definedp);
   /* end of acros */
 
   make_synt(s_and, makmmacro, m_and);
@@ -1490,5 +1842,15 @@ void init_eval()
   make_synt(s_atapply, makmmacro, m_apply);
   make_synt(s_atcall_cc, makmmacro, m_cont);
 
-  make_synt("defined?", makacro, definedp);
+#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. */
+  make_synt("@letrec-syntax", makmmacro, m_letrec);
+  make_synt(s_the_macro, makmmacro, m_the_macro);
+  i_mark = CAR(sysintern("let-syntax-mark", UNDEFINED));
+#endif
 }