path: root/eval.c

/* 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
 * 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))
#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 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

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;
{
  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));
}

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);
  register unsigned int idist, iframe = 0;
#ifdef MACRO
  SCM mark = IDENT_MARK(var);
#endif
  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) {
#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) {
#ifndef RECKLESS		/* letrec inits to UNDEFINED */
	if UNBNDP(CAR(*al)) {env = EOL; goto errout;}
#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);
      }
      idist++;
    }
    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,
# 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;
{
  register int ir;
  if IMP(form) return form;
  if (1==TYP3(form))
    CAR(form) = I_SYM(CAR(form));
  else if ILOCP(CAR(form)) {
    for(ir = IFRAME(CAR(form)); ir != 0; --ir) env = CDR(env);
    env = CAR(CAR(env));
    for(ir = IDIST(CAR(form));ir != 0;--ir) env = CDR(env);
    CAR(form) = ICDRP(CAR(form)) ? env : CAR(env);
  }
  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;
{
	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;

#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;
     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);
#ifdef MACRO
  DEFER_INTS;
  unpaint(&CAR(CDR(xorig)));
  ALLOW_INTS;
#endif
  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)) && IDENTP(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);
    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));
}

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 TOPDENOTE_EQ(i_else, CAR(arg1), env) {
      ASSYNT(NULLP(CDR(x)) && len >= 2, xorig, "bad ELSE clause", s_cond);
      CAR(arg1) = BOOL_T;
    }
    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));
}

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 IDENTP(proc) goto memlambda;
  if NCONSP(proc) goto badforms;
  while NIMP(proc) {
    if NCONSP(proc)
      if (!IDENTP(proc)) goto badforms;
      else goto memlambda;
    if (!(NIMP(CAR(proc)) && IDENTP(CAR(proc)))) goto badforms;
    proc = CDR(proc);
  }
  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)) && IDENTP(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)) && IDENTP(CAR(arg1)), xorig, s_variable, s_do);
    /* vars reversed here, inits and steps reversed at evaluation */
    vars = cons(CAR(arg1), vars); /* variable */
    arg1 = CDR(arg1);
    *initloc = cons(CAR(arg1), EOL); /* init */
    initloc = &CDR(*initloc);
    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);
}

/* Here are acros which return values rather than code. */

static SCM iqq(form, env)
     SCM form, env;
{
  SCM tmp;
  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));
  }
  if NCONSP(form) return form;
  tmp = CAR(form);
  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 NCONSP(form) {
#ifdef MACRO
    while M_IDENTP(form) form = IDENT_PARENT(form);
#endif
    return form;
  }
  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);
    }
  }
  CAR(form) = tmp;
  CDR(form) = m_iqq(CDR(form), depth, env);
  return form;
}
SCM m_quasiquote(xorig, env)
     SCM 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;
  return cons(IM_QUASIQUOTE, x);
}

SCM m_delay(xorig, env)
     SCM xorig, env;
{
  ASSYNT(ilength(xorig)==2, xorig, s_expression, s_delay);
  return cons2(IM_DELAY, EOL, CDR(xorig));
}

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(TOPRENAME(i_lambda), CDR(proc), x), EOL);
    proc = CAR(proc);
  }
  ASSYNT(NIMP(proc) && IDENTP(proc), arg1, s_variable, s_define);
  ASSYNT(1==ilength(x), arg1, s_expression, s_define);
  if NULLP(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)) &&
	(proc ==
	 ((SCM) SNAME(MACROP(CDR(arg1)) ? CDR(CDR(arg1)) : CDR(arg1))))
	&& (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 m_quote(cons2(i_quote, CAR(arg1), EOL), EOL);
#else
    return UNSPECIFIED;
#endif
  }
  return cons2(IM_DEFINE, cons(proc,CAR(CAR(env))), 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)) && IDENTP(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 (!IDENTP(proc)) wta(xorig, s_bindings, s_let); /* bad let */
  name = proc;			/* named let, build equiv letrec */
  x = CDR(x);
  ASSYNT(ilength(x) >= 2, xorig, s_body, s_let);
  proc = CAR(x);		/* bindings list */
  ASSYNT(ilength(proc) >= 0, xorig, s_bindings, s_let);
  while NIMP(proc) {		/* vars and inits both in order */
    arg1 = CAR(proc);
    ASSYNT(2==ilength(arg1), xorig, s_bindings, s_let);
    ASSYNT(NIMP(CAR(arg1)) && IDENTP(CAR(arg1)), xorig, s_variable, s_let);
    *varloc = cons(CAR(arg1), 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(TOPRENAME(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));
#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 IDENTP(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);
#ifndef INUMS_ONLY
    arg2 = (SCM)(IMP(t.arg1) || !NUMP(t.arg1));
#endif
    while(NIMP(x = CDR(x))) {
      proc = CAR(x);
      if (IM_ELSE==CAR(proc)) {
	x = CDR(proc);
	goto begin;
      }
      proc = CAR(proc);
      while NIMP(proc) {
	if (
#ifndef INUMS_ONLY
	    arg2 ? NFALSEP(eqv(CAR(proc), t.arg1)) :
#endif
	    (CAR(proc)==t.arg1)) {
	  x = CDR(CAR(x));
	  goto begin;
	}
	proc = CDR(proc);
      }
    }
    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 (IM_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:
      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;
    case 4:
      t.lloc = ilookup(proc, env);
      break;
    }
    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) = proc;
    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 = setjump(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;
    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;
    }
  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:
#ifdef MACRO
    if M_IDENTP(x) {
      x = cons(x, UNDEFINED);
      goto retval;
    }
#endif
    return x;
  case (127 & ILOC00):
    proc = *ilookup(CAR(x), env);
    ASRTGO(NIMP(proc), badfun);
#ifndef RECKLESS
# ifdef CAUTIOUS
    goto checkargs;
# endif
#endif
    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;
	}
      }
    }
    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(NIMP(args) && 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;
}
#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(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))) {
      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));
#ifdef MACRO
  proc = ident2sym(proc);
#endif
  return (ISYMP(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},
	{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},
#ifdef MACRO
	{s_identp, identp},
#endif
	{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};
#ifdef MACRO
static smobfuns idsmob = {markcdr, free0, prinid};
#endif

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, makmmacro, m_quasiquote);
  make_synt(s_define, makmmacro, m_define);
  make_synt(s_delay, makmmacro, m_delay);
  make_synt("defined?", makacro, definedp);
  /* end of acros */

  make_synt(s_and, makmmacro, m_and);
  make_synt(s_begin, makmmacro, m_begin);
  make_synt(s_case, makmmacro, m_case);
  make_synt(s_cond, makmmacro, m_cond);
  make_synt(s_do, makmmacro, m_do);
  make_synt(s_if, makmmacro, m_if);
  i_lambda = make_synt(s_lambda, makmmacro, m_lambda);
  i_let = make_synt(s_let, makmmacro, m_let);
  make_synt(s_letrec, makmmacro, m_letrec);
  make_synt(s_letstar, makmmacro, m_letstar);
  make_synt(s_or, makmmacro, m_or);
  i_quote = make_synt(s_quote, makmmacro, m_quote);
  make_synt(s_set, makmmacro, m_set);
  make_synt(s_atapply, makmmacro, m_apply);
  make_synt(s_atcall_cc, makmmacro, m_cont);

#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
}