Import Upstream version 4e6upstream/4e6

1 files changed, 1494 insertions, 0 deletions

diff --git a/eval.c b/eval.c
new file mode 100644
index 0000000..2cf04fe
--- /dev/null
+++ b/eval.c
@@ -0,0 +1,1494 @@
+/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc.
+ * 
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ * 
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ * 
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING.  If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE.  If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way.  To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.  
+ */
+
+/* "eval.c" eval and apply.
+   Authors: Aubrey Jaffer & Hugh E. Secker-Walker. */
+
+#include "scm.h"
+#include "setjump.h"
+
+#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)
+#else
+# define EVALIMP(x, env) x
+#endif
+#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
+SCM *ilookup(iloc, env)
+     SCM iloc, env;
+{
+  register int ir = IFRAME(iloc);
+  register SCM er = 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));
+}
+#endif
+SCM *lookupcar(vloc, genv)
+     SCM vloc, genv;
+{
+  SCM env = genv;
+  register SCM *al, fl, var = CAR(vloc);
+#ifdef MEMOIZE_LOCALS
+  register SCM iloc = ILOC00;
+#endif
+  for(;NIMP(env);env = CDR(env)) {
+    al = &CAR(env);
+    for(fl = CAR(*al);NIMP(fl);fl = CDR(fl)) {
+      if NCONSP(fl)
+	if (fl==var) {
+#ifdef MEMOIZE_LOCALS
+	  CAR(vloc) = iloc + ICDR;
+#endif
+	  return &CDR(*al);
+	}
+	else break;
+      al = &CDR(*al);
+      if (CAR(fl)==var) {
+#ifdef MEMOIZE_LOCALS
+# ifndef RECKLESS		/* letrec inits to UNDEFINED */
+	if UNBNDP(CAR(*al)) {env = EOL; goto errout;}
+# endif
+	CAR(vloc) = iloc;
+#endif
+	return &CAR(*al);
+      }
+#ifdef MEMOIZE_LOCALS
+      iloc += IDINC;
+#endif
+    }
+#ifdef MEMOIZE_LOCALS
+    iloc = (~IDSTMSK) & (iloc + IFRINC);
+#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", "");
+  }
+#endif
+  CAR(vloc) = var + 1;
+  return &CDR(var);
+}
+static SCM unmemocar(form, env)
+     SCM form, env;
+{
+  register int ir;
+  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;
+}
+
+SCM eval_args(l, env)
+     SCM l, env;
+{
+	SCM res = EOL, *lloc = &res;
+	while NIMP(l) {
+		*lloc = cons(EVALCAR(l, env), EOL);
+		lloc = &CDR(*lloc);
+		l = CDR(l);
+	}
+	return res;
+}
+
+    /* the following rewrite expressions and
+     * some memoized forms have different syntax */
+
+static char s_expression[] = "missing or extra expression";
+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_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;
+static char s_quasiquote[] = "quasiquote";
+static char s_delay[] = "delay";
+
+#define ASRTSYNTAX(cond_, msg_) if(!(cond_))wta(xorig, (msg_), what);
+
+static void bodycheck(xorig, bodyloc, what)
+     SCM xorig, *bodyloc;
+     char *what;
+{
+  ASRTSYNTAX(ilength(*bodyloc) >= 1, s_expression);
+}
+
+SCM m_quote(xorig, env)
+     SCM xorig, env;
+{
+  ASSYNT(ilength(CDR(xorig))==1, xorig, s_expression, s_quote);
+  return cons(IM_QUOTE, CDR(xorig));
+}
+
+SCM m_begin(xorig, env)
+     SCM xorig, env;
+{
+  ASSYNT(ilength(CDR(xorig)) >= 1, xorig, s_expression, s_begin);
+  return cons(IM_BEGIN, CDR(xorig));
+}
+
+SCM m_if(xorig, env)
+     SCM xorig, env;
+{
+  int len = ilength(CDR(xorig));
+  ASSYNT(len >= 2 && len <= 3, xorig, s_expression, s_if);
+  return cons(IM_IF, CDR(xorig));
+}
+
+SCM m_set(xorig, env)
+     SCM xorig, env;
+{
+  SCM x = CDR(xorig);
+  ASSYNT(2==ilength(x), xorig, s_expression, s_set);
+  ASSYNT(NIMP(CAR(x)) && SYMBOLP(CAR(x)),
+	 xorig, s_variable, s_set);
+  return cons(IM_SET, x);
+}
+
+SCM m_and(xorig, env)
+     SCM xorig, env;
+{
+  int len = ilength(CDR(xorig));
+  ASSYNT(len >= 0, xorig, s_test, s_and);
+  if (len >= 1) return cons(IM_AND, CDR(xorig));
+  else return BOOL_T;
+}
+
+SCM m_or(xorig, env)
+     SCM xorig, env;
+{
+  int len = ilength(CDR(xorig));
+  ASSYNT(len >= 0, xorig, s_test, s_or);
+  if (len >= 1) return cons(IM_OR, CDR(xorig));
+  else return BOOL_F;
+}
+
+SCM m_case(xorig, env)
+     SCM xorig, env;
+{
+  SCM proc, x = CDR(xorig);
+  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);
+    ASSYNT(ilength(CAR(proc)) >= 0 || i_else==CAR(proc),
+	   xorig, s_clauses, s_case);
+  }
+  return cons(IM_CASE, CDR(xorig));
+}
+
+SCM m_cond(xorig, env)
+     SCM xorig, env;
+{
+  SCM arg1, x = CDR(xorig);
+  int len = ilength(x);
+  ASSYNT(len >= 1, xorig, s_clauses, s_cond);
+  while(NIMP(x)) {
+    arg1 = CAR(x);
+    len = ilength(arg1);
+    ASSYNT(len >= 1, xorig, s_clauses, s_cond);
+    if (i_else==CAR(arg1)) {
+      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);
+    x = CDR(x);
+  }
+  return cons(IM_COND, CDR(xorig));
+}
+
+SCM m_lambda(xorig, env)
+     SCM xorig, env;
+{
+  SCM proc, x = CDR(xorig);
+  if (ilength(x) < 2) goto badforms;
+  proc = CAR(x);
+  if NULLP(proc) goto memlambda;
+  if IMP(proc) goto badforms;
+  if SYMBOLP(proc) goto memlambda;
+  if NCONSP(proc) goto badforms;
+  while NIMP(proc) {
+    if NCONSP(proc)
+      if (!SYMBOLP(proc)) goto badforms;
+      else goto memlambda;
+    if (!(NIMP(CAR(proc)) && SYMBOLP(CAR(proc)))) goto badforms;
+    proc = CDR(proc);
+  }
+  if NNULLP(proc)
+  badforms: wta(xorig, s_formals, s_lambda);
+ memlambda:
+  bodycheck(xorig, &CDR(x), s_lambda);
+  return cons(IM_LAMBDA, CDR(xorig));
+}
+SCM m_letstar(xorig, env)
+     SCM xorig, env;
+{
+  SCM x = CDR(xorig), arg1, proc, vars = EOL, *varloc = &vars;
+  int len = ilength(x);
+  ASSYNT(len >= 2, xorig, s_body, s_letstar);
+  proc = CAR(x);
+  ASSYNT(ilength(proc) >= 0, xorig, s_bindings, s_letstar);
+  while NIMP(proc) {
+    arg1 = CAR(proc);
+    ASSYNT(2==ilength(arg1), xorig, s_bindings, s_letstar);
+    ASSYNT(NIMP(CAR(arg1)) && SYMBOLP(CAR(arg1)), xorig, s_variable, s_letstar);
+    *varloc = cons2(CAR(arg1), CAR(CDR(arg1)), EOL);
+    varloc = &CDR(CDR(*varloc));
+    proc = CDR(proc);
+  }
+  x = cons(vars, CDR(x));
+  bodycheck(xorig, &CDR(x), s_letstar);
+  return cons(IM_LETSTAR, x);
+}
+
+/* DO gets the most radically altered syntax
+   (do ((<var1> <init1> <step1>)
+   (<var2> <init2>)
+   ... )
+   (<test> <return>)
+   <body>)
+   ;; becomes
+   (do_mem (varn ... var2 var1)
+   (<init1> <init2> ... <initn>)
+   (<test> <return>)
+   (<body>)
+   <step1> <step2> ... <stepn>) ;; missing steps replaced by var
+   */
+SCM m_do(xorig, env)
+     SCM xorig, env;
+{
+  SCM x = CDR(xorig), arg1, proc;
+  SCM vars = EOL, inits = EOL, steps = EOL;
+  SCM *initloc = &inits, *steploc = &steps;
+  int len = ilength(x);
+  ASSYNT(len >= 2, xorig, s_test, s_do);
+  proc = CAR(x);
+  ASSYNT(ilength(proc) >= 0, xorig, s_bindings, s_do);
+  while NIMP(proc) {
+    arg1 = CAR(proc);
+    len = ilength(arg1);
+    ASSYNT(2==len || 3==len, xorig, s_bindings, s_do);
+    ASSYNT(NIMP(CAR(arg1)) && SYMBOLP(CAR(arg1)), xorig, s_variable, s_do);
+    /* vars reversed here, inits and steps reversed at evaluation */
+    vars = cons(CAR(arg1), vars); /* variable */
+    arg1 = CDR(arg1);
+    *initloc = cons(CAR(arg1), EOL); /* init */
+    initloc = &CDR(*initloc);
+    arg1 = CDR(arg1);
+    *steploc = cons(IMP(arg1)?CAR(vars):CAR(arg1), EOL); /* step */
+    steploc = &CDR(*steploc);
+    proc = CDR(proc);
+  }
+  x = CDR(x);
+  ASSYNT(ilength(CAR(x)) >= 1, xorig, s_test, s_do);
+  x = cons2(CAR(x), CDR(x), steps);
+  x = cons2(vars, inits, x);
+  bodycheck(xorig, &CAR(CDR(CDR(x))), s_do);
+  return cons(IM_DO, x);
+}
+
+/* evalcar is small version of inline EVALCAR when we don't care about speed */
+static SCM evalcar(x, env)
+     SCM x, env;
+{
+  return EVALCAR(x, env);
+}
+
+static SCM iqq(form, env, depth)
+     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));
+  }
+  if NCONSP(form) return form;
+  tmp = CAR(form);
+  if (i_quasiquote==tmp) {
+    depth++;
+    goto label;
+  }
+  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 (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));
+  }
+  return cons(iqq(CAR(form), env, edepth), iqq(CDR(form), env, depth));
+}
+
+/* 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);
+}
+
+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));
+}
+
+extern int verbose;
+SCM m_define(x, env)
+     SCM x, env;
+{
+  SCM proc, arg1 = x; x = CDR(x);
+  /*  ASSYNT(NULLP(env), x, "bad placement", s_define);*/
+  ASSYNT(ilength(x) >= 2, arg1, s_expression, s_define);
+  proc = CAR(x); x = CDR(x);
+  while (NIMP(proc) && CONSP(proc)) { /* nested define syntax */
+    x = cons(cons2(i_lambda, CDR(proc), x), EOL);
+    proc = CAR(proc);
+  }
+  ASSYNT(NIMP(proc) && SYMBOLP(proc), arg1, s_variable, s_define);
+  ASSYNT(1==ilength(x), arg1, s_expression, s_define);
+  if NULLP(env) {
+    x = evalcar(x, env);
+    arg1 = sym2vcell(proc);
+#ifndef RECKLESS
+    if (NIMP(CDR(arg1)) && ((SCM) SNAME(CDR(arg1))==proc)
+	&& (CDR(arg1) != x))
+      warn("redefining built-in ", CHARS(proc));
+    else
+#endif
+    if (5 <= verbose && UNDEFINED != CDR(arg1))
+      warn("redefining ", CHARS(proc));
+    CDR(arg1) = x;
+#ifdef SICP
+    return cons2(i_quote, CAR(arg1), EOL);
+#else
+    return UNSPECIFIED;
+#endif
+  }
+  return cons2(IM_DEFINE, proc, x);
+}
+/* end of acros */
+
+SCM m_letrec(xorig, env)
+     SCM 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;
+
+  ASRTSYNTAX(ilength(x) >= 2, s_body);
+  proc = CAR(x);
+  if NULLP(proc) return m_letstar(xorig, env); /* null binding, let* faster */
+  ASRTSYNTAX(ilength(proc) >= 1, s_bindings);
+  do {
+    /* vars list reversed here, inits reversed at evaluation */
+    arg1 = CAR(proc);
+    ASRTSYNTAX(2==ilength(arg1), s_bindings);
+    ASRTSYNTAX(NIMP(CAR(arg1)) && SYMBOLP(CAR(arg1)), s_variable);
+    vars = cons(CAR(arg1), vars);
+    *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);
+}
+
+SCM m_let(xorig, env)
+     SCM 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;
+
+  ASSYNT(ilength(x) >= 2, xorig, s_body, s_let);
+  proc = CAR(x);
+  if (NULLP(proc)
+      || (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 */
+  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 */
+  name = proc;			/* named let, build equiv letrec */
+  x = CDR(x);
+  ASSYNT(ilength(x) >= 2, xorig, s_body, s_let);
+  proc = CAR(x);		/* bindings list */
+  ASSYNT(ilength(proc) >= 0, xorig, s_bindings, s_let);
+  while NIMP(proc) {		/* vars and inits both in order */
+    arg1 = CAR(proc);
+    ASSYNT(2==ilength(arg1), xorig, s_bindings, s_let);
+    ASSYNT(NIMP(CAR(arg1)) && SYMBOLP(CAR(arg1)), xorig, s_variable, s_let);
+    *varloc = cons(CAR(arg1), EOL);
+    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(i_lambda, vars, CDR(x)), EOL), EOL),
+		   acons(name, inits, EOL)), /* body */
+	     env);
+}
+
+#define s_atapply (ISYMCHARS(IM_APPLY)+1)
+
+SCM m_apply(xorig, env)
+     SCM xorig, env;
+{
+  ASSYNT(ilength(CDR(xorig))==2, xorig, s_expression, s_atapply);
+  return cons(IM_APPLY, CDR(xorig));
+}
+
+#define s_atcall_cc (ISYMCHARS(IM_CONT)+1)
+
+SCM m_cont(xorig, env)
+     SCM xorig, env;
+{
+  ASSYNT(ilength(CDR(xorig))==1, xorig, s_expression, s_atcall_cc);
+  return cons(IM_CONT, CDR(xorig));
+}
+
+#ifndef RECKLESS
+int badargsp(formals, args)
+     SCM formals, args;
+{
+  while NIMP(formals) {
+    if NCONSP(formals) return 0;
+    if IMP(args) return 1;
+    formals = CDR(formals);
+    args = CDR(args);
+  }
+  return NNULLP(args) ? 1 : 0;
+}
+#endif
+
+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
+
+SCM ceval(x, env)
+     SCM x, env;
+{
+  union {SCM *lloc; SCM arg1;} t;
+  SCM proc, arg2;
+  CHECK_STACK;
+ loop: POLL;
+  switch TYP7(x) {
+  case tcs_symbols:
+    /* only happens when called at top level */
+    x = cons(x, UNDEFINED);
+    goto retval;
+  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;
+      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);
+      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);
+    }
+    if SYMBOLP(CAR(x)) {
+ retval:
+      return *lookupcar(x, env);
+    }
+    x = CAR(x);
+    goto loop;			/* tail recurse */
+
+  case (127 & IM_CASE):
+    x = CDR(x);
+    t.arg1 = EVALCAR(x, env);
+    while(NIMP(x = CDR(x))) {
+      proc = CAR(x);
+      if (i_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))
+#endif
+	    ) {
+	  x = CDR(CAR(x));
+	  goto begin;
+	}
+	proc = CDR(proc);
+      }
+    }
+    return UNSPECIFIED;
+  case (127 & IM_COND):
+    while(NIMP(x = CDR(x))) {
+      proc = CAR(x);
+      t.arg1 = EVALCAR(proc, env);
+      if NFALSEP(t.arg1) {
+	x = CDR(proc);
+	if NULLP(x) return t.arg1;
+	if (i_arrow != CAR(x)) goto begin;
+	proc = CDR(x);
+	proc = EVALCAR(proc, env);
+	ASRTGO(NIMP(proc), badfun);
+#ifdef CAUTIOUS
+	if CLOSUREP(proc) goto checkargs1;
+#endif
+	goto evap1;
+      }
+    }
+    return UNSPECIFIED;
+  case (127 & IM_DO):
+    x = CDR(x);
+    proc = CAR(CDR(x)); /* inits */
+    t.arg1 = EOL; /* values */
+    while NIMP(proc) {
+      t.arg1 = cons(EVALCAR(proc, env), t.arg1);
+      proc = CDR(proc);
+    }
+    env = EXTEND_ENV(CAR(x), t.arg1, env);
+    x = CDR(CDR(x));
+    while (proc = CAR(x), FALSEP(EVALCAR(proc, env))) {
+      for(proc = CAR(CDR(x));NIMP(proc);proc = CDR(proc)) {
+	t.arg1 = CAR(proc);	/* body */
+	SIDEVAL(t.arg1, env);
+      }
+      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));
+    }
+    x = CDR(proc);
+    if NULLP(x) return UNSPECIFIED;
+    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;
+    goto carloop;
+  case (127 & IM_LET):
+    x = CDR(x);
+    proc = CAR(CDR(x));
+    t.arg1 = EOL;
+    do {
+      t.arg1 = cons(EVALCAR(proc, env), t.arg1);
+    } while NIMP(proc = CDR(proc));
+    env = EXTEND_ENV(CAR(x), t.arg1, env);
+    x = CDR(x);
+    goto cdrxbegin;
+  case (127 & IM_LETREC):
+    x = CDR(x);
+    env = EXTEND_ENV(CAR(x), undefineds, env);
+    x = CDR(x);
+    proc = CAR(x);
+    t.arg1 = EOL;
+    do {
+	t.arg1 = cons(EVALCAR(proc, env), t.arg1);
+    } while NIMP(proc = CDR(proc));
+    CDR(CAR(env)) = t.arg1;
+    goto cdrxbegin;
+  case (127 & IM_LETSTAR):
+    x = CDR(x);
+    proc = CAR(x);
+    if IMP(proc) {
+      env = EXTEND_ENV(EOL, EOL, env);
+      goto cdrxbegin;
+    }
+    do {
+      t.arg1 = CAR(proc);
+      proc = CDR(proc);
+      env = EXTEND_ENV(t.arg1, EVALCAR(proc, env), env);
+    } 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 = t.arg1;
+    }
+    goto carloop;
+  case (127 & IM_LAMBDA):
+    return closure(CDR(x), env);
+  case (127 & IM_QUOTE):
+    return CAR(CDR(x));
+  case (127 & IM_SET):
+    x = CDR(x);
+    proc = CAR(x);
+    switch (7 & (int)proc) {
+    case 0:
+      t.lloc = lookupcar(x, env);
+      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);
+#ifdef SICP
+    return *t.lloc;
+#else
+    return UNSPECIFIED;
+#endif
+  case (127 & IM_DEFINE):	/* only for internal defines */
+    x = CDR(x);
+    proc = CAR(x);
+    x = CDR(x);
+    x = evalcar(x, env);
+    env = CAR(env);
+    DEFER_INTS;
+    CAR(env) = cons(proc, CAR(env));
+    CDR(env) = cons(x, CDR(env));
+    ALLOW_INTS;
+    return UNSPECIFIED;
+	/* new syntactic forms go here. */
+  case (127 & MAKISYM(0)):
+    proc = CAR(x);
+    ASRTGO(ISYMP(proc), badfun);
+    switch ISYMNUM(proc) {
+    case (ISYMNUM(IM_APPLY)):
+      proc = CDR(x);
+      proc = EVALCAR(proc, env);
+      ASRTGO(NIMP(proc), badfun);
+      if (CLOSUREP(proc)) {
+	t.arg1 = CDR(CDR(x));
+	t.arg1 = EVALCAR(t.arg1, env);
+#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 = setjmp(CONT(t.arg1)->jmpbuf))
+#ifdef SHORT_INT
+	return (SCM)thrown_value;
+#else
+	return (SCM)proc;
+#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;
+    default:
+      goto badfun;
+    }
+  default:
+    proc = x;
+  badfun:
+    everr(x, env, proc, "Wrong type to apply: ", "");
+  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:
+    return x;
+#ifdef MEMOIZE_LOCALS
+  case (127 & ILOC00):
+    proc = *ilookup(CAR(x), env);
+    ASRTGO(NIMP(proc), badfun);
+# ifndef RECKLESS
+#  ifdef CAUTIOUS
+    goto checkargs;
+#  endif
+# endif
+    break;
+#endif /* ifdef MEMOIZE_LOCALS */
+  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 SYMBOLP(CAR(x)) {
+      proc = *lookupcar(x, env);
+      if IMP(proc) {unmemocar(x, env); goto badfun;}
+      if (tc16_macro==TYP16(proc)) {
+	unmemocar(x, env);
+	t.arg1 = apply(CDR(proc), x, cons(env, listofnull));
+	switch ((int)(CAR(proc)>>16)) {
+	case 2:
+	  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:
+	  if NIMP(x = t.arg1) goto loop;
+	case 0:
+	  return t.arg1;
+	}
+      }
+    }
+    else proc = ceval(CAR(x), env);
+    ASRTGO(NIMP(proc), badfun);
+#ifndef RECKLESS
+# ifdef CAUTIOUS
+  checkargs:
+# endif
+    /* 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;
+	}
+	if IMP(t.arg1) goto umwrongnumargs;
+	arg2 = CDR(arg2);
+	t.arg1 = CDR(t.arg1);
+      }
+      if NNULLP(t.arg1) goto umwrongnumargs;
+    }
+#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);
+#ifdef CCLO
+  case tc7_cclo:
+    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;
+  }
+  x = CDR(x);
+#ifdef CAUTIOUS
+  if (IMP(x)) goto wrongnumargs;
+#endif
+  t.arg1 = EVALCAR(x, env);
+  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:
+#ifdef FLOATS
+    if SUBRF(proc) {
+      if INUMP(t.arg1)
+	return makdbl(DSUBRF(proc)((double) INUM(t.arg1)), 0.0);
+      ASRTGO(NIMP(t.arg1), floerr);
+      if REALP(t.arg1)
+	return makdbl(DSUBRF(proc)(REALPART(t.arg1)), 0.0);
+# ifdef BIGDIG
+      if BIGP(t.arg1)
+	return makdbl(DSUBRF(proc)(big2dbl(t.arg1)), 0.0);
+# endif
+    floerr:
+      wta(t.arg1, (char *)ARG1, CHARS(SNAME(proc)));
+    }
+#endif
+    proc = (SCM)SNAME(proc);
+    {
+      char *chrs = CHARS(proc)+LENGTH(proc)-1;
+      while('c' != *--chrs) {
+	ASSERT(NIMP(t.arg1) && CONSP(t.arg1),
+	       t.arg1, ARG1, CHARS(proc));
+	t.arg1 = ('a'==*chrs)?CAR(t.arg1):CDR(t.arg1);
+      }
+      return t.arg1;
+    }
+  case tc7_rpsubr:
+    return BOOL_T;
+  case tc7_asubr:
+    return SUBRF(proc)(t.arg1, UNDEFINED);
+  case tc7_lsubr:
+    return SUBRF(proc)(cons(t.arg1, EOL));
+#ifdef CCLO
+  case tc7_cclo:
+    arg2 = t.arg1;
+    t.arg1 = proc;
+    proc = CCLO_SUBR(proc);
+    goto evap2;
+#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;
+#endif
+  {				/* have two or more arguments */
+    arg2 = EVALCAR(x, env);
+    x = CDR(x);
+    if NULLP(x)
+#ifdef CCLO
+  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:
+      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);
+      }
+      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)));
+#ifdef CCLO
+    case tc7_cclo: 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;
+    }
+  }
+}
+
+SCM procedurep(obj)
+     SCM obj;
+{
+	if NIMP(obj) switch TYP7(obj) {
+	case tcs_closures:
+	case tc7_contin:
+	case tcs_subrs:
+#ifdef CCLO
+	case tc7_cclo:
+#endif
+	  return BOOL_T;
+	}
+	return BOOL_F;
+}
+
+static char s_proc_doc[] = "procedure-documentation";
+SCM l_proc_doc(proc)
+     SCM proc;
+{
+  SCM code;
+  ASSERT(BOOL_T==procedurep(proc) && NIMP(proc) && TYP7(proc) != tc7_contin,
+	 proc, ARG1, s_proc_doc);
+  switch TYP7(proc) {
+  case tcs_closures:
+    code = CDR(CODE(proc));
+    if IMP(CDR(code)) return BOOL_F;
+    code = CAR(code);
+    if IMP(code) return BOOL_F;
+    if STRINGP(code) return code;
+  default:
+    return BOOL_F;
+/*
+  case tcs_subrs:
+#ifdef CCLO
+  case tc7_cclo:
+#endif
+*/
+  }
+}
+
+/* This code is for apply. it is destructive on multiple args.
+   This will only screw you if you do (apply apply '( ... )) */
+SCM nconc2last(lst)
+     SCM lst;
+{
+  SCM *lloc = &lst;
+#ifdef CAUTIOUS
+  ASSERT(ilength(lst) >= 1, lst, WNA, s_apply);
+#endif
+  while NNULLP(CDR(*lloc)) lloc = &CDR(*lloc);
+#ifdef CAUTIOUS
+  ASSERT(ilength(CAR(*lloc)) >= 0, lst, ARGn, s_apply);
+#endif
+  *lloc = CAR(*lloc);
+  return lst;
+}
+
+
+SCM apply(proc, arg1, args)
+     SCM proc, arg1, args;
+{
+  ASRTGO(NIMP(proc), badproc);
+  if NULLP(args)
+    if NULLP(arg1) arg1 = UNDEFINED;
+    else {
+      args = CDR(arg1);
+      arg1 = CAR(arg1);
+    }
+  else {
+    /*		ASRTGO(NIMP(args) && CONSP(args), wrongnumargs); */
+    args = nconc2last(args);
+  }
+#ifdef CCLO
+ tail:
+#endif
+  switch TYP7(proc) {
+  case tc7_subr_2o:
+    args = NULLP(args)?UNDEFINED:CAR(args);
+    return SUBRF(proc)(arg1, args);
+  case tc7_subr_2:
+    ASRTGO(NULLP(CDR(args)), wrongnumargs);
+    args = CAR(args);
+    return SUBRF(proc)(arg1, args);
+  case tc7_subr_0:
+    ASRTGO(UNBNDP(arg1), wrongnumargs);
+    return SUBRF(proc)();
+  case tc7_subr_1:
+  case tc7_subr_1o:
+    ASRTGO(NULLP(args), wrongnumargs);
+    return SUBRF(proc)(arg1);
+  case tc7_cxr:
+    ASRTGO(NULLP(args), wrongnumargs);
+#ifdef FLOATS
+    if SUBRF(proc) {
+      if INUMP(arg1)
+	return makdbl(DSUBRF(proc)((double) INUM(arg1)), 0.0);
+      ASRTGO(NIMP(arg1), floerr);
+      if REALP(arg1)
+	return makdbl(DSUBRF(proc)(REALPART(arg1)), 0.0);
+# ifdef BIGDIG
+      if BIGP(arg1)
+	return makdbl(DSUBRF(proc)(big2dbl(arg1)), 0.0);
+# endif
+    floerr:
+      wta(arg1, (char *)ARG1, CHARS(SNAME(proc)));
+    }
+#endif
+    proc = (SCM)SNAME(proc);
+    {
+      char *chrs = CHARS(proc)+LENGTH(proc)-1;
+      while('c' != *--chrs) {
+	ASSERT(NIMP(arg1) && CONSP(arg1),
+	       arg1, ARG1, CHARS(proc));
+	arg1 = ('a'==*chrs)?CAR(arg1):CDR(arg1);
+      }
+      return arg1;
+    }
+  case tc7_subr_3:
+    return SUBRF(proc)(arg1, CAR(args), CAR(CDR(args)));
+  case tc7_lsubr:
+    return SUBRF(proc)(UNBNDP(arg1) ? EOL : cons(arg1, args));
+  case tc7_lsubr_2:
+    ASRTGO(NIMP(args) && CONSP(args), wrongnumargs);
+    return SUBRF(proc)(arg1, CAR(args), CDR(args));
+  case tc7_asubr:
+    if NULLP(args) return SUBRF(proc)(arg1, UNDEFINED);
+    while NIMP(args) {
+      ASSERT(CONSP(args), args, ARG2, s_apply);
+      arg1 = SUBRF(proc)(arg1, CAR(args));
+      args = CDR(args);
+    }
+    return arg1;
+  case tc7_rpsubr:
+    if NULLP(args) return BOOL_T;
+    while NIMP(args) {
+      ASSERT(CONSP(args), args, ARG2, s_apply);
+      if FALSEP(SUBRF(proc)(arg1, CAR(args))) return BOOL_F;
+      arg1 = CAR(args);
+      args = CDR(args);
+    }
+    return BOOL_T;
+  case tcs_closures:
+    arg1 = (UNBNDP(arg1) ? EOL : cons(arg1, args));
+#ifndef RECKLESS
+    if (badargsp(CAR(CODE(proc)), arg1)) goto wrongnumargs;
+#endif
+    args = EXTEND_ENV(CAR(CODE(proc)), arg1, ENV(proc));
+    proc = CODE(proc);
+    while NNULLP(proc = CDR(proc)) arg1 = EVALCAR(proc, args);
+    return arg1;
+  case tc7_contin:
+    ASRTGO(NULLP(args), wrongnumargs);
+    scm_dynthrow(CONT(proc), arg1);
+#ifdef CCLO
+  case tc7_cclo:
+    args = (UNBNDP(arg1) ? EOL : cons(arg1, args));
+    arg1 = proc;
+    proc = CCLO_SUBR(proc);
+    goto tail;
+#endif
+  wrongnumargs:
+    wta(proc, (char *)WNA, s_apply);
+  default:
+  badproc:
+    wta(proc, (char *)ARG1, s_apply);
+    return arg1;
+  }
+}
+
+SCM map(proc, arg1, args)
+     SCM proc, arg1, args;
+{
+	long i;
+	SCM res = EOL, *pres = &res;
+	SCM *ve = &args;	/* Keep args from being optimized away. */
+	if NULLP(arg1) return res;
+	ASSERT(NIMP(arg1), arg1, ARG2, s_map);
+	if NULLP(args) {
+		while NIMP(arg1) {
+			ASSERT(CONSP(arg1), arg1, ARG2, s_map);
+			*pres = cons(apply(proc, CAR(arg1), listofnull), EOL);
+			pres = &CDR(*pres);
+			arg1 = CDR(arg1);
+		}
+		return res;
+	}
+	args = vector(cons(arg1, args));
+	ve = VELTS(args);
+#ifndef RECKLESS
+	for(i = LENGTH(args)-1; i >= 0; i--)
+	  ASSERT(NIMP(ve[i]) && CONSP(ve[i]), args, ARG2, s_map);
+#endif
+	while (1) {
+		arg1 = EOL;
+		for (i = LENGTH(args)-1;i >= 0;i--) {
+			if IMP(ve[i]) return res;
+			arg1 = cons(CAR(ve[i]), arg1);
+			ve[i] = CDR(ve[i]);
+		}
+		*pres = cons(apply(proc, arg1, EOL), EOL);
+		pres = &CDR(*pres);
+	}
+}
+SCM for_each(proc, arg1, args)
+     SCM proc, arg1, args;
+{
+	SCM *ve = &args;	/* Keep args from being optimized away. */
+	long i;
+	if NULLP(arg1) return UNSPECIFIED;
+	ASSERT(NIMP(arg1), arg1, ARG2, s_for_each);
+	if NULLP(args) {
+		while NIMP(arg1) {
+			ASSERT(CONSP(arg1), arg1, ARG2, s_for_each);
+			apply(proc, CAR(arg1), listofnull);
+			arg1 = CDR(arg1);
+		}
+		return UNSPECIFIED;
+	}
+	args = vector(cons(arg1, args));
+	ve = VELTS(args);
+	while (1) {
+		arg1 = EOL;
+		for (i = LENGTH(args)-1;i >= 0;i--) {
+			if IMP(ve[i]) return UNSPECIFIED;
+			arg1 = cons(CAR(ve[i]), arg1);
+			ve[i] = CDR(ve[i]);
+		}
+		apply(proc, arg1, EOL);
+	}
+}
+
+SCM closure(code, env)
+     SCM code, env;
+{
+	register SCM z;
+	NEWCELL(z);
+	SETCODE(z, code);
+	ENV(z) = env;
+	return z;
+}
+
+long tc16_promise;
+SCM makprom(code)
+     SCM code;
+{
+	register SCM z;
+	NEWCELL(z);
+	CDR(z) = code;
+	CAR(z) = tc16_promise;
+	return z;
+}
+static int prinprom(exp, port, writing)
+     SCM exp;
+     SCM port;
+     int writing;
+{
+  lputs("#<promise ", port);
+  iprin1(CDR(exp), port, writing);
+  lputc('>', port);
+  return !0;
+}
+
+SCM makacro(code)
+     SCM code;
+{
+	register SCM z;
+	NEWCELL(z);
+	CDR(z) = code;
+	CAR(z) = tc16_macro;
+	return z;
+}
+SCM makmacro(code)
+     SCM code;
+{
+	register SCM z;
+	NEWCELL(z);
+	CDR(z) = code;
+	CAR(z) = tc16_macro | (1L<<16);
+	return z;
+}
+SCM makmmacro(code)
+     SCM code;
+{
+	register SCM z;
+	NEWCELL(z);
+	CDR(z) = code;
+	CAR(z) = tc16_macro | (2L<<16);
+	return z;
+}
+static int prinmacro(exp, port, writing)
+     SCM exp;
+     SCM port;
+     int writing;
+{
+  if (CAR(exp) & (3L<<16)) lputs("#<macro", port);
+  else lputs("#<syntax", port);
+  if (CAR(exp) & (2L<<16)) lputc('!', port);
+  lputc(' ', port);
+  iprin1(CDR(exp), port, writing);
+  lputc('>', port);
+  return !0;
+}
+
+char s_force[] = "force";
+SCM force(x)
+     SCM x;
+{
+  ASSERT((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))) {
+      DEFER_INTS;
+      CDR(x) = ans;
+      CAR(x) |= (1L<<16);
+      ALLOW_INTS;
+    }
+  }
+  return CDR(x);
+}
+
+SCM copytree(obj)
+     SCM obj;
+{
+  SCM ans, tl;
+  if IMP(obj) return obj;
+  if VECTORP(obj) {
+    sizet i = LENGTH(obj);
+    ans = make_vector(MAKINUM(i), UNSPECIFIED);
+    while(i--) VELTS(ans)[i] = copytree(VELTS(obj)[i]);
+    return ans;
+  }
+  if NCONSP(obj) return obj;
+/*  return cons(copytree(CAR(obj)), copytree(CDR(obj))); */
+  ans = tl = cons(copytree(CAR(obj)), UNSPECIFIED);
+  while(NIMP(obj = CDR(obj)) && CONSP(obj))
+    tl = (CDR(tl) = cons(copytree(CAR(obj)), UNSPECIFIED));
+  CDR(tl) = obj;
+  return ans;
+}
+SCM eval(obj)
+     SCM obj;
+{
+  obj = copytree(obj);
+  return EVAL(obj, (SCM)EOL);
+}
+
+SCM definedp(x, env)
+     SCM x, env;
+{
+  SCM proc = CAR(x = CDR(x));
+  return (ISYMP(proc)
+	  || (NIMP(proc) && SYMBOLP(proc)
+	      && !UNBNDP(CDR(sym2vcell(proc)))))?
+		(SCM)BOOL_T : (SCM)BOOL_F;
+}
+
+static iproc subr1s[] = {
+	{"copy-tree", copytree},
+	{s_eval, eval},
+	{s_force, force},
+	{s_proc_doc, l_proc_doc},
+	{"procedure->syntax", makacro},
+	{"procedure->macro", makmacro},
+	{"procedure->memoizing-macro", makmmacro},
+	{"apply:nconc-to-last", nconc2last},
+	{0, 0}};
+
+static iproc lsubr2s[] = {
+/*	{s_apply, apply}, now explicity initted */
+	{s_map, map},
+	{s_for_each, for_each},
+	{0, 0}};
+
+static smobfuns promsmob = {markcdr, free0, prinprom};
+static smobfuns macrosmob = {markcdr, free0, prinmacro};
+
+SCM make_synt(name, macroizer, fcn)
+     char *name;
+     SCM (*macroizer)();
+     SCM (*fcn)();
+{
+  SCM symcell = sysintern(name, UNDEFINED);
+  long tmp = ((((CELLPTR)(CAR(symcell)))-heap_org)<<8);
+  register SCM z;
+  if ((tmp>>8) != ((CELLPTR)(CAR(symcell))-heap_org))
+    tmp = 0;
+  NEWCELL(z);
+  SUBRF(z) = fcn;
+  CAR(z) = tmp + tc7_subr_2;
+  CDR(symcell) = macroizer(z);
+  return CAR(symcell);
+}
+
+void init_eval()
+{
+  tc16_promise = newsmob(&promsmob);
+  tc16_macro = newsmob(&macrosmob);
+  init_iprocs(subr1s, tc7_subr_1);
+  init_iprocs(lsubr2s, tc7_lsubr_2);
+  i_apply = make_subr(s_apply, tc7_lsubr_2, apply);
+  i_dot = CAR(sysintern(".", UNDEFINED));
+  i_arrow = CAR(sysintern("=>", UNDEFINED));
+  i_else = CAR(sysintern("else", UNDEFINED));
+  i_unquote = CAR(sysintern("unquote", UNDEFINED));
+  i_uq_splicing = CAR(sysintern("unquote-splicing", UNDEFINED));
+
+  /* acros */
+  i_quasiquote = make_synt(s_quasiquote, makacro, m_quasiquote);
+  make_synt(s_define, makmmacro, m_define);
+  make_synt(s_delay, makacro, m_delay);
+  /* end of acros */
+
+  make_synt(s_and, makmmacro, m_and);
+  make_synt(s_begin, makmmacro, m_begin);
+  make_synt(s_case, makmmacro, m_case);
+  make_synt(s_cond, makmmacro, m_cond);
+  make_synt(s_do, makmmacro, m_do);
+  make_synt(s_if, makmmacro, m_if);
+  i_lambda = make_synt(s_lambda, makmmacro, m_lambda);
+  i_let = make_synt(s_let, makmmacro, m_let);
+  make_synt(s_letrec, makmmacro, m_letrec);
+  make_synt(s_letstar, makmmacro, m_letstar);
+  make_synt(s_or, makmmacro, m_or);
+  i_quote = make_synt(s_quote, makmmacro, m_quote);
+  make_synt(s_set, makmmacro, m_set);
+  make_synt(s_atapply, makmmacro, m_apply);
+  make_synt(s_atcall_cc, makmmacro, m_cont);
+
+  make_synt("defined?", makacro, definedp);
+}