/* 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))
#define ATOMP(x) (5==(5 & (int)CAR(x)))
#define EVALCELLCAR(x) (ATOMP(CAR(x))?evalatomcar(x):ceval_1(CAR(x)))

/* Environment frames are initially allocated in a small cache ("ecache").
  This cache is subject to copying gc, cells in it may be moved to the
  general purpose Scheme heap by a call to any routine that allocates cells
  in the cache.

  Global variables scm_env and scm_env_tmp are used as software
  registers: scm_env is the current lexical environment, scm_env_tmp
  is used for protecting environment frames under construction and not
  yet linked into the environment.

  In order to protect environments from garbage collection, a stack of
  environments (scm_estk) is maintained. scm_env and scm_env_tmp may
  be pushed on or popped off the stack using the macros ENV_PUSH and
  ENV_POP.

  It is not safe to pass objects that may allocated in the ecache as
  arguments to C functions, or to return them from C functions, since
  such objects may be moved by the ecache gc.  Ecache gc may happen
  anywhere interrupts are not deferred, because some interrupt
  handlers may evaluate Scheme code and then return. 

  Interrupts may be deferred with DEFER_INTS_EGC: This will prevent
  interrupts until an ALLOW_INTS or ALLOW_INTS_EGC, which may happen
  any time Scheme code is evaluated.  It is not necessary to strictly
  nest DEFER_INTS_EGC and ALLOW_INTS_EGC since ALLOW_INTS_EGC is
  called in ceval_1 before any subrs are called.

  Instead of using the C stack and deferring interrupts, objects which
  might have been allocated in the ecache may be passed using the
  global variables scm_env_tmp and scm_env.

  If the CDR of a cell that might be allocated in the regular heap is
  made to point to a cell allocated in the cache, then the first cell
  must be recorded as a gc root, using the macro EGC_ROOT.  There is
  no provision for allowing the CAR of a regular cell to point to a
  cache cell.  */

#ifdef NO_ENV_CACHE
# define scm_env_cons(a,b) {scm_env_tmp=cons((a),(b));}
# define scm_env_cons2(a,b,c) {scm_env_tmp=cons2((a),(b),(c));}
# define scm_env_cons_tmp(a) {scm_env_tmp=cons((a),scm_env_tmp);}
# define EXTEND_ENV(names) {scm_env=acons((names),scm_env_tmp,scm_env);}
#else
# define EXTEND_ENV scm_extend_env
#endif

SCM scm_env = EOL, scm_env_tmp = UNSPECIFIED;
long tc16_env;			/* Type code for environments passed to macro
				   transformers. */
SCM nconc2copy P((SCM x));
SCM copy_list P((SCM x));
SCM rename_ident P((SCM id, SCM env));
SCM eqv P((SCM x, SCM y));
void scm_dynthrow P((CONTINUATION *cont, SCM val));
void scm_egc P((void));
void scm_estk_grow P((sizet inc));
void scm_estk_shrink P((void));
int badargsp P((SCM proc, SCM args));

static SCM ceval_1 P((SCM x));
static SCM evalatomcar P((SCM x));
static SCM evalcar P((SCM x));
static SCM id2sym P((SCM id));
static SCM iqq P((SCM form));
static SCM m_body P((SCM op, SCM xorig, char *what));
static SCM m_iqq P((SCM form, int depth, SCM env));
static SCM m_letrec1 P((SCM op, SCM imm, SCM xorig, SCM env));
static SCM macroexp1 P((SCM x, int check));
static SCM unmemocar P((SCM x));
static SCM wrapenv P((void));
static SCM *id_denote P((SCM var));
static int prinenv P((SCM exp, SCM port, int writing));
static int prinid P((SCM exp, SCM port, int writing));
static int prinmacro P((SCM exp, SCM port, int writing));
static int prinprom P((SCM exp, SCM port, int writing));
static void bodycheck P((SCM xorig, SCM *bodyloc, char *what));
static void unpaint P((SCM *p));
#ifdef CAREFUL_INTS
static void debug_env_warn P((char *fnam, long line, char *what));
#endif

/* Flush global variable state to estk. */
#define ENV_SAVE {scm_estk_ptr[0]=scm_env; scm_estk_ptr[1]=scm_env_tmp;}

/* Make global variable state consistent with estk. */
#define ENV_RESTORE {scm_env=scm_estk_ptr[0]; scm_env_tmp=scm_estk_ptr[1];}

#define ENV_PUSH {DEFER_INTS_EGC; ENV_SAVE;\
                  if (INUM0==scm_estk_ptr[SCM_ESTK_FRLEN]) scm_estk_grow(20);\
		  else scm_estk_ptr += SCM_ESTK_FRLEN;}

#define ENV_POP {DEFER_INTS_EGC;\
                 if (INUM0==scm_estk_ptr[-SCM_ESTK_FRLEN]) scm_estk_shrink();\
                 else scm_estk_ptr -= SCM_ESTK_FRLEN; ENV_RESTORE;}

#ifdef NO_ENV_CACHE
# define EGC_ROOT(x) /**/
#else
# ifdef CAREFUL_INTS
#  define EGC_ROOT(x) {if (!ints_disabled) \
                          debug_env_warn(__FILE__,__LINE__,"EGC_ROOT"); \
                       scm_egc_roots[--scm_egc_root_index] = (x); \
                       if (0==scm_egc_root_index) scm_egc();}
# else
#  define EGC_ROOT(x) {scm_egc_roots[--scm_egc_root_index] = (x);\
                       if (0==scm_egc_root_index) scm_egc();}
# endif
#endif

#define ENV_MAY_POP(p, guard) if (p>0 && !(guard)) {ENV_POP; p=-1;}
#define ENV_MAY_PUSH(p) if (p<=0) {ENV_PUSH; p=1;}
#define SIDEVAL_1(x) if NIMP(x) ceval_1(x)
#ifdef CAUTIOUS
# define TRACE(x) scm_estk_ptr[2]=(x)
#else
# define TRACE(x) /**/
#endif

#define EVALIMP(x) (ILOCP(x)?*ilookup(x):x)
#define EVALCAR(x) (NCELLP(CAR(x))?(IMP(CAR(x))?EVALIMP(CAR(x)):\
					I_VAL(CAR(x))):EVALCELLCAR(x))
long tc16_macro;		/* Type code for macros */
#define MACROP(x) (tc16_macro==TYP16(x))

#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
# define M_IDENTP(x) (0)
#endif

/* #define SCM_PROFILE */
#ifdef SCM_PROFILE
long eval_cases[128];
long eval_cases_other[NUM_ISYMS];
long ilookup_cases[10][10][2];	/* frame, dist, icdrp */
long eval_clo_cases[5][4];	/* actual args, required args */
SCM scm_profile(resetp)
     SCM resetp;
{
  SCM ev = make_uve(sizeof(eval_cases)/sizeof(long), MAKINUM(-1));
  SCM evo = make_uve(sizeof(eval_cases_other)/sizeof(long), MAKINUM(-1));
  SCM il = dims2ura(cons2(MAKINUM(10), MAKINUM(10), cons(MAKINUM(2), EOL)),
		    MAKINUM(-1), EOL);
  SCM evc = dims2ura(cons2(MAKINUM(5), MAKINUM(4), EOL), MAKINUM(-1), EOL);
  long *v = (long *)VELTS(ev);
  int i;
  for (i = 0; i < sizeof(eval_cases)/sizeof(long); i++)
    v[i] = eval_cases[i];
  v = (long *)VELTS(evo);
  for (i = 0; i < sizeof(eval_cases_other)/sizeof(long); i++)
    v[i] = eval_cases_other[i];
  v = (long *)VELTS(ARRAY_V(il));
  for (i = 0; i < sizeof(ilookup_cases)/sizeof(long); i++)
    v[i] = ((long *)ilookup_cases)[i];
  v = (long *)VELTS(ARRAY_V(evc));
  for (i = 0; i < sizeof(eval_clo_cases)/sizeof(long); i++)
    v[i] = ((long *)eval_clo_cases)[i];
  if (! UNBNDP(resetp)) {
  for (i = 0; i < sizeof(eval_cases)/sizeof(long); i++)
    eval_cases[i] = 0;
  for (i = 0; i < sizeof(eval_cases_other)/sizeof(long); i++)
    eval_cases_other[i] = 0;
  for (i = 0; i < sizeof(ilookup_cases)/sizeof(long); i++)
    ((long *)ilookup_cases)[i] = 0;
  for (i = 0; i < sizeof(eval_clo_cases)/sizeof(long); i++)
    ((long *)eval_clo_cases)[i] = 0;
  }
  return cons2(ev, evo, cons2(il, evc, EOL));
}
#endif

#ifdef CAREFUL_INTS
# undef CAR
# define CAR(x) (*debug_env_car((x), __FILE__, __LINE__))
# undef CDR
# define CDR(x) (*debug_env_cdr((x), __FILE__, __LINE__))
/* Inhibit warnings for ARGC, is not changed by egc. */
# undef ARGC
# define ARGC(x) ((6L & (((cell *)(SCM2PTR(x)))->cdr))>>1)
#include <signal.h>
SCM test_ints(x)
     SCM x;
{
  static int cnt = 100;
  if (0==--cnt) {
    cnt = 100;
    DEFER_INTS;
    scm_egc();
    ALLOW_INTS;
    /*    l_raise(MAKINUM(SIGALRM)); */
  }
  return x;
}
int ecache_p(x)
     SCM x;
{
  register CELLPTR ptr;
  if NCELLP(x) return 0;
  ptr = (CELLPTR)SCM2PTR(x);
  if (PTR_LE(scm_ecache, ptr)
      && PTR_GT(scm_ecache+scm_ecache_len, ptr))
    return !0;
  return 0;
}
static void debug_env_warn(fnam, line, what)
     char *fnam;
     long line;
     char *what;
{
  lputs(fnam, cur_errp);
  lputc(':', cur_errp);
  intprint(line, 10, cur_errp);
  lputs(": unprotected ", cur_errp);
  lputs(what, cur_errp);
  lputs(" of ecache value\n", cur_errp);
}
SCM *debug_env_car(x, fnam, line)
     SCM x;
     char *fnam;
     long line;
{
  SCM *ret;
  if (!ints_disabled && ecache_p(x))
    debug_env_warn(fnam, line, "CAR");
  ret = &(((cell *)(SCM2PTR(x)))->car);
  if (!ints_disabled && NIMP(*ret) && ecache_p(*ret))
    debug_env_warn(fnam, line, "CAR");
  return ret;
}
SCM *debug_env_cdr(x, fnam, line)
     SCM x;
     char *fnam;
     long line;
{
  SCM *ret;
  if (!ints_disabled && ecache_p(x))
    debug_env_warn(fnam, line, "CDR");
  ret = &(((cell *)(SCM2PTR(x)))->cdr);
  if (!ints_disabled && NIMP(*ret) && ecache_p(*ret))
    debug_env_warn(fnam, line, "CAR");
  return ret;
}
#endif /* CAREFUL_INTS */

SCM *ilookup(iloc)
     SCM iloc;
{
  register int ir = IFRAME(iloc);
  register SCM er;
#ifdef SCM_PROFILE
  ilookup_cases[ir<10 ? ir : 9]
    [IDIST(iloc)<10 ? IDIST(iloc) : 9][ICDRP(iloc)?1:0]++;
#endif
  DEFER_INTS_EGC;
  er = scm_env;
  for(;0 != ir;--ir) er = CDR(er);
  er = CAR(er);
  for(ir = IDIST(iloc);0 != ir;--ir) er = CDR(er);
  if ICDRP(iloc) return &CDR(er);
  return &CAR(CDR(er));
}
SCM *farlookup(farloc)
     SCM farloc;
{
  register int ir;
  register SCM er;
  SCM x = CDR(farloc);
  DEFER_INTS_EGC;
  er = scm_env;
  for (ir = INUM(CAR(x)); 0 != ir; --ir) er = CDR(er);
  er = CAR(er);
  for (ir = INUM(CDR(x)); 0 != ir; --ir) er = CDR(er);
  if (IM_FARLOC_CDR==CAR(farloc)) return &CDR(er);
  return &CAR(CDR(er));
}

static char s_badkey[] = "Use of keyword as variable",
  s_unbnd[] = "unbound variable: ", s_wtap[] = "Wrong type to apply: ";
/* check is logical OR of LOOKUP_UNDEFP and LOOKUP_MACROP */
#define LOOKUP_UNDEFP 1
#define LOOKUP_MACROP 2
SCM *lookupcar(vloc, check)
     SCM vloc;
     int check;
{
  SCM env;
  register SCM *al, fl, var = CAR(vloc);
  register unsigned int idist, iframe = 0;
#ifdef MACRO
  SCM mark = IDENT_MARK(var);
#endif
  DEFER_INTS_EGC;
  env = scm_env;
  for(; NIMP(env); env = CDR(env)) {
    idist = 0;
    al = &CAR(env);
    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 RECKLESS
	    if ((check & LOOKUP_UNDEFP)
		&& UNBNDP(CDR(*al))) { env = EOL; goto errout; }
# ifdef MACRO
	    if ((check & LOOKUP_MACROP)
		&& (NIMP(CDR(*al)) && MACROP(CDR(*al)))) goto badkey;
# endif
#endif
#ifndef TEST_FARLOC
	  if (iframe < 4096 && idist < (1L<<(LONG_BIT-20)))
	    CAR(vloc) = MAKILOC(iframe, idist) + ICDR;
	  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 ((check & LOOKUP_UNDEFP)
	    && UNBNDP(CAR(*al))) {env = EOL; goto errout;}
# ifdef MACRO
	if ((check & LOOKUP_MACROP)
	    && NIMP(CAR(*al)) && MACROP(CAR(*al))) goto badkey;
# endif
#endif
#ifndef TEST_FARLOC
	if (iframe < 4096 && idist < (1L<<(LONG_BIT-20)))
	  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) || ((check & LOOKUP_UNDEFP) && UNBNDP(CDR(var)))) {
    var = CAR(var);
  errout:
    everr(vloc, wrapenv() /*scm_env*/, var,
# ifdef MACRO
	  M_IDENTP(var) ? s_escaped :
# endif
	  (NULLP(env) ? s_unbnd : "damaged environment"), "");
  }
# ifdef MACRO
  if ((check & LOOKUP_MACROP) && NIMP(CDR(var)) && MACROP(CDR(var))) {
    var = CAR(var);
  badkey: everr(vloc, wrapenv()/*scm_env*/, var, s_badkey, "");
  }
# endif
#endif
  CAR(vloc) = var + 1;
  return &CDR(var);
}

static SCM unmemocar(form)
     SCM form;
{
  SCM env;
  register int ir;
  DEFER_INTS_EGC;
  env = scm_env;
  if IMP(form) return form;
  if (1==TYP3(form))
    CAR(form) = I_SYM(CAR(form));
  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;
}

/* CAR(x) is known to be a cell but not a cons */
static SCM evalatomcar(x)
     SCM x;
{
  SCM r;
  switch TYP7(CAR(x)) {
  default:
    everr(x, wrapenv() /*scm_env*/, CAR(x), "Cannot evaluate: ", "");
  case tcs_symbols:
  lookup:
    return *lookupcar(x, LOOKUP_UNDEFP|LOOKUP_MACROP);
  case tc7_vector:
#ifndef RECKLESS
    if (2 <= verbose) warn("unquoted ", s_vector);
#endif
    r = cons2(IM_QUOTE, CAR(x), EOL);
    CAR(x) = r;
    return CAR(CDR(r));
  case tc7_smob:
#ifdef MACRO
    if M_IDENTP(CAR(x)) goto lookup;
#endif
	/* fall through */
  case tc7_string:
  case tc7_bvect: case tc7_ivect: case tc7_uvect:
  case tc7_fvect: case tc7_dvect: case tc7_cvect:
    return CAR(x);
  }
}

SCM eval_args(l)
     SCM l;
{
	SCM res = EOL, *lloc = &res;
	while NIMP(l) {
	  *lloc = cons(EVALCAR(l), 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_bad_else_clause[] = "bad ELSE clause";
static char s_clauses[] = "bad or missing clauses";
static char s_formals[] = "bad formals";
#define ASSYNT(_cond, _arg, _pos, _subr) if(!(_cond))wta(_arg, (char *)_pos, _subr);

SCM i_dot, i_quote, i_quasiquote, i_lambda, i_define,
  i_let, i_arrow, i_else, i_unquote, i_uq_splicing;

#define ASRTSYNTAX(cond_, msg_) if(!(cond_))wta(xorig, (msg_), what);
#ifdef MACRO
# define TOPDENOTE_EQ(sym, x, env) ((sym)==id2sym(x) && TOPLEVELP(x,env))
# define TOPLEVELP(x,env) (0==id_denote(x))
# define TOPRENAME(v) (renamed_ident(v, BOOL_F))

static SCM id2sym(id)
     SCM id;
{
  if NIMP(id)
    while M_IDENTP(id)
      id = IDENT_PARENT(id);
  return id;
}

static SCM *id_denote(var)
     SCM var;
{
  register SCM *al, fl;
  SCM env, mark = IDENT_MARK(var);
  DEFER_INTS_EGC;
  env = scm_env;
  for(;NIMP(env); env = CDR(env)) {
    al = &CAR(env);
    for(fl = CAR(*al);NIMP(fl);fl = CDR(fl)) {
      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 if VECTORP(x) {
      sizet i = LENGTH(x);
      if (0==i) return;
      while (i-- > 1) unpaint(&(VELTS(x)[i]));
      p = VELTS(x);
    }
    else {
      while M_IDENTP(x) *p = x = IDENT_PARENT(x);
      return;
    }
  }
}
#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);
}

static SCM m_body(op, xorig, what)
     SCM op, xorig;
     char *what;
{
  ASRTSYNTAX(ilength(xorig) >= 1, s_expression);  
			/* Don't add another ISYM if one is present already. */
  if ISYMP(CAR(xorig)) return xorig;
			/* Retain possible doc string. */
  if (IMP(CAR(xorig)) || NCONSP(CAR(xorig))) {
    if NNULLP(CDR(xorig))
      return cons(CAR(xorig), m_body(op, CDR(xorig), what));
    return xorig;
  }
  return cons2(op, CAR(xorig), CDR(xorig));
}

SCM m_quote(xorig, env)
     SCM xorig, env;
{
  SCM x = copytree(CDR(xorig));
  ASSYNT(ilength(CDR(xorig))==1, xorig, s_expression, s_quote);
#ifdef MACRO
  DEFER_INTS;
  unpaint(&CAR(x));
  ALLOW_INTS;
#endif
  return cons(IM_QUOTE, x);
}

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

#ifdef INUMS_ONLY
# define memv memq
#endif
SCM m_case(xorig, env)
     SCM xorig, env;
{
  SCM clause, cdrx = copy_list(CDR(xorig)), x = cdrx;
#ifndef RECKLESS
  SCM s, keys = EOL;
#endif
  ASSYNT(ilength(x) >= 2, xorig, s_clauses, s_case);
  while(NIMP(x = CDR(x))) {
    clause = CAR(x);
    ASSYNT(ilength(clause) >= 2, xorig, s_clauses, s_case);
    if TOPDENOTE_EQ(i_else, CAR(clause), env) {
      ASSYNT(NULLP(CDR(x)), xorig, s_bad_else_clause, s_case);
      CAR(x) = cons(IM_ELSE, CDR(clause));
    }
    else {
      ASSYNT(ilength(CAR(clause)) >= 0, xorig, s_clauses, s_case);
#ifdef MACRO
      clause = cons(copy_list(CAR(clause)), CDR(clause));
      DEFER_INTS;
      unpaint(&CAR(clause));
      ALLOW_INTS;
      CAR(x) = clause;
#endif
#ifndef RECKLESS
      for (s = CAR(clause); NIMP(s); s = CDR(s))
	ASSYNT(FALSEP(memv(CAR(s),keys)), xorig, "duplicate key value", s_case);
      keys = append(cons2(CAR(clause), keys, EOL));
#endif      
    }
  }
  return cons(IM_CASE, cdrx);
}

SCM m_cond(xorig, env)
     SCM xorig, env;
{
  SCM arg1, cdrx = copy_list(CDR(xorig)), x = cdrx;
  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, s_bad_else_clause, s_cond);
      CAR(x) = cons(BOOL_T, CDR(arg1));
    }
    else {
      arg1 = CDR(arg1);
      if (len >= 2 && TOPDENOTE_EQ(i_arrow, CAR(arg1), env)) {
	ASSYNT(3==len && NIMP(CAR(CDR(arg1))), xorig, "bad recipient", s_cond);
	CAR(x) = cons2(CAR(CAR(x)), IM_ARROW, CDR(arg1));
      }
    }
    x = CDR(x);
  }
  return cons(IM_COND, cdrx);
}

SCM m_lambda(xorig, env)
     SCM xorig, env;
{
  SCM proc, x = CDR(xorig);
  int argc = 0;		/* Number of required args */
  if (ilength(x) < 2) goto badforms;
  proc = CAR(x);
  if NULLP(proc) goto memlambda;
  if (IM_LET==proc) goto memlambda; /* named let */
  if IMP(proc) goto badforms;
  if IDENTP(proc) goto memlambda;
  if NCONSP(proc) goto badforms;
  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);
    argc++;
  }
  if (NNULLP(proc) && (IM_LET != proc)) /* IM_LET inserted by named let. */
  badforms: wta(xorig, s_formals, s_lambda);
 memlambda:
  return cons2(ISYMSETVAL(IM_LAMBDA, argc), CAR(x),
	       m_body(IM_LAMBDA, CDR(x), s_lambda));
}
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));
  return cons2(IM_LETSTAR, CAR(x), m_body(IM_LETSTAR, CDR(x), s_letstar));
}

/* 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 = IM_DO, inits = EOL, steps = EOL;
  SCM *initloc = &inits, *steploc = &steps;
  int len = ilength(x);
  ASSYNT(len >= 2, xorig, s_test, s_do);
  proc = CAR(x);
  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)
     SCM x;
{
  return EVALCAR(x);
}

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

static SCM iqq(form)
     SCM form;
{
  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));
  }
  if NCONSP(form) return form;
  tmp = CAR(form);
  if (IM_UNQUOTE==tmp) 
    return evalcar(CDR(form));
  if (NIMP(tmp) && IM_UQ_SPLICING==CAR(tmp))
    return append(cons2(evalcar(CDR(tmp)), iqq(CDR(form)), EOL));
  return cons(iqq(CAR(form)), iqq(CDR(form)));
}

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;
    for(;--i >= 0;) tmp = cons(data[i], tmp);
    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);
  x = m_iqq(copytree(x), 1, env);
  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));
}

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 (NIMP(env) && tc16_env==CAR(env)) {
    DEFER_INTS_EGC;
    env = CDR(env);
  }
  if NULLP(env) {
    x = evalcar(x);
#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 (2 <= verbose &&
	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, proc, x);
  /*  return cons2(IM_DEFINE, cons(proc,CAR(CAR(env))), x); */
}
/* end of acros */

static SCM m_letrec1(op, imm, xorig, env)
     SCM op, imm, xorig, env;
{
  SCM cdrx = CDR(xorig);	/* locally mutable version of form */
  char *what = CHARS(CAR(xorig));
  SCM x = cdrx, proc, arg1;	/* structure traversers */
  SCM vars = imm, inits = EOL, *initloc = &inits;

  /*  ASRTSYNTAX(ilength(x) >= 2, s_body); */
  proc = CAR(x);
#if 0
  if NULLP(proc)   /* null binding, let* faster */
    return m_letstar(cons2(CAR(xorig), EOL, m_body(imm, CDR(x), what)), env);
#endif
  ASRTSYNTAX(ilength(proc) >= 1, s_bindings);
  do {
    /* vars list reversed here, inits reversed at evaluation */
    arg1 = CAR(proc);
    ASRTSYNTAX(2==ilength(arg1), s_bindings);
    ASRTSYNTAX(NIMP(CAR(arg1)) && IDENTP(CAR(arg1)), s_variable);
    vars = cons(CAR(arg1), vars);
    *initloc = cons(CAR(CDR(arg1)), EOL);
    initloc = &CDR(*initloc);
  } while NIMP(proc = CDR(proc));
  return cons2(op, vars, cons(inits, m_body(imm, CDR(x), what)));
}

SCM m_letrec(xorig, env)
     SCM xorig, env;
{
  SCM x = CDR(xorig);
  ASSYNT(ilength(x) >= 2, xorig, s_body, s_letrec);
  if NULLP(CAR(x))   /* null binding, let* faster */
    return m_letstar(cons2(CAR(xorig), EOL,
			   m_body(IM_LETREC, CDR(x), s_letrec)),
		     env);
  return m_letrec1(IM_LETREC, IM_LETREC, xorig, env);
}

SCM m_let(xorig, env)
     SCM xorig, env;
{
  SCM cdrx = CDR(xorig);	/* locally mutable version of form */
  SCM x = cdrx, proc, arg1, name; /* structure traversers */
  SCM vars = IM_LET, inits = EOL, *varloc = &vars, *initloc = &inits;

  ASSYNT(ilength(x) >= 2, xorig, s_body, s_let);
  proc = CAR(x);
  if (NULLP(proc)		/* null or single binding, let* is faster */
      || (NIMP(proc) && CONSP(proc)
	  && NIMP(CAR(proc)) && CONSP(CAR(proc)) && NULLP(CDR(proc))))
    return m_letstar(cons2(CAR(xorig), proc, m_body(IM_LET, CDR(x), s_let)),
		     env);
  ASSYNT(NIMP(proc), xorig, s_bindings, s_let);
  if CONSP(proc)		/* plain let, proc is <bindings> */
    return m_letrec1(IM_LET, IM_LET, xorig, env);
  if (!IDENTP(proc)) wta(xorig, s_bindings, s_let); /* bad let */
  name = proc;			/* named let, build equiv letrec */
  x = CDR(x);
  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), IM_LET);
    varloc = &CDR(*varloc);
    *initloc = cons(CAR(CDR(arg1)), EOL);
    initloc = &CDR(*initloc);
    proc = CDR(proc);
  }
  proc = cons2(TOPRENAME(i_lambda), vars, m_body(IM_LET, CDR(x), s_let));
  proc = cons2(i_let, cons(cons2(name, proc, EOL), EOL),
	       acons(name, inits, EOL));
  return m_letrec1(IM_LETREC, IM_LET, proc, env);
}

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

SCM m_expand_body(xorig)
     SCM xorig;
{
  SCM form, x = CDR(xorig), defs = EOL;
  char *what = ISYMCHARS(CAR(xorig)) + 2;
  while NIMP(x) {
    form = CAR(x);
    if (IMP(form) || NCONSP(form)) break;
    if IMP(CAR(form)) break;
    if (! IDENTP(CAR(form))) break;
    form = macroexp1(cons(CAR(form), CDR(form)), 0);
    if (IM_DEFINE==CAR(form)) {
      defs = cons(CDR(form), defs);
      x = CDR(x);
    }
    else if NIMP(defs) {
      break;
    }
    else if (IM_BEGIN==CAR(form)) {
      x = append(cons2(CDR(form), CDR(x), EOL));
    }
    else {
      x = cons(form, CDR(x));
      break;
    }
  }
  ASSYNT(NIMP(x), CDR(xorig), s_body, what);
  if NIMP(defs)
    x = cons(m_letrec1(IM_LETREC, IM_DEFINE, cons2(i_define, defs, x),
		       wrapenv())
	     , EOL);
  DEFER_INTS;
  CAR(xorig) = CAR(x);
  CDR(xorig) = CDR(x);
  ALLOW_INTS;
  return xorig;
}

static SCM macroexp1(x, check)
     SCM x;
     int check;
{
  SCM res, proc;
  int argc;
  ASRTGO(IDENTP(CAR(x)), badfun);
 macro_tail:
  proc = *lookupcar(x, 0);
  if (NIMP(proc) && MACROP(proc)) {
    unmemocar(x);
    res = apply(CDR(proc), cons2(x, wrapenv(), EOL), EOL);
    switch ((int)(CAR(proc)>>16) & 0x7f) {
    case 2:			/* mmacro */
      if (ilength(res) <= 0)
	res = cons2(IM_BEGIN, res, EOL);
      DEFER_INTS;
      CAR(x) = CAR(res);
      CDR(x) = CDR(res);
      ALLOW_INTS;
      break;
    case 1:			/* macro */
      x =  NIMP(res) ? res : cons2(IM_BEGIN, res, EOL);
      break;
    case 0:			/* acro */
      return cons2(IM_QUOTE, res, EOL);
    }
    if (NIMP(CAR(x)) && IDENTP(CAR(x))) goto macro_tail;
#ifndef RECKLESS
    if (check && IM_DEFINE==CAR(x))
      everr(x, wrapenv() /*scm_env*/, i_define, "Bad placement", "");
#endif
    return x;
  }
  else if (!check) {
    unmemocar(x);
    return x;
  }
#ifdef RECKLESS
  return x;
#else
  ASRTGO(NIMP(proc), badfun);
  argc = ilength(CDR(x));
# ifdef CCLO
 cclo_tail:
# endif
  switch TYP7(proc) {
  default:
  badfun:
    unmemocar(x);
    everr(x, wrapenv(), UNBNDP(proc) ? CAR(x) : proc,
	  UNBNDP(proc) ? s_unbnd : s_wtap, "");
  case tc7_lsubr:
  case tc7_rpsubr:
  case tc7_asubr:
    return x;
  case tc7_subr_0:
    ASRTGO(0==argc, wrongnumargs);
    return x;
  case tc7_contin:
  case tc7_subr_1:
  case tc7_cxr:
    ASRTGO(1==argc, wrongnumargs);
    return x;
  case tc7_subr_2:
    ASRTGO(2==argc, wrongnumargs);
    return x;
  case tc7_subr_3:
    ASRTGO(3==argc, wrongnumargs);
    return x;
  case tc7_subr_1o:
    ASRTGO(0==argc || 1==argc, wrongnumargs);
    return x;
  case tc7_subr_2o:
    ASRTGO(1==argc || 2==argc, wrongnumargs);
    return x;
  case tc7_lsubr_2:
    ASRTGO(2<=argc, wrongnumargs);
    return x;
  case tc7_specfun:
    switch TYP16(proc) {
    case tc16_apply:
      ASRTGO(2<=argc, wrongnumargs);
      return x;
    case tc16_call_cc:
      ASRTGO(1==argc, wrongnumargs);
      return x;
# ifdef CCLO
    case tc16_cclo:
      proc = CCLO_SUBR(proc);
      argc++;
      goto cclo_tail;
# endif
    }
  case tcs_closures:
    if (badargsp(proc, CDR(x))) {
    wrongnumargs:
      unmemocar(x);      
      everr(x, wrapenv()/*scm_env*/, proc, (char *)WNA, "");
    }      
    return x;
  }
#endif /* ndef RECKLESS */
}

#ifndef RECKLESS
int badargsp(proc, args)
     SCM proc, args;
{
  SCM formals = CAR(CODE(proc));
  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";
char s_call_cc[] = "call-with-current-continuation"; /* s_apply[] = "apply"; */

static SCM wrapenv()
{
  register SCM z;
  NEWCELL(z);
  DEFER_INTS_EGC;
  CDR(z) = scm_env;
  CAR(z) = tc16_env;
  EGC_ROOT(z);	
  return z;
}

SCM ceval(x, env)
     SCM x, env;
{
  DEFER_INTS_EGC;
  ENV_PUSH;
  scm_env = env;
  TRACE(x);
  x = ceval_1(x);
  ENV_POP;
  ALLOW_INTS_EGC;
  return x;
}

static SCM ceval_1(x)
     SCM x;
{
  union {SCM *lloc; SCM arg1;} t;
  SCM proc, arg2, arg3;
  int envpp = 0;	/* 1 means an environment has been pushed in this
		   invocation of ceval_1, -1 means pushed and then popped. */
  CHECK_STACK;
 loop: POLL;
  TRACE(x);
#ifdef SCM_PROFILE
  eval_cases[TYP7(x)]++;
#endif
  switch TYP7(x) {
  case tcs_symbols:
    /* only happens when called at top level */
    x = *lookupcar(cons(x, UNDEFINED), LOOKUP_UNDEFP);
    goto retx;
  case (127 & IM_AND):
    x = CDR(x);
    t.arg1 = x;
    while(NNULLP(t.arg1 = CDR(t.arg1)))
      if (FALSEP(EVALCAR(x))) {x = BOOL_F; goto retx;}
      else x = t.arg1;
    goto carloop;
 cdrxbegin:
  case (127 & IM_BEGIN):
    x = CDR(x);
 begin:
    t.arg1 = x;
    while(NNULLP(t.arg1 = CDR(t.arg1))) {
      if IMP(CAR(x)) {
	if ISYMP(CAR(x)) {
	  x = m_expand_body(x);
	  goto begin;
	}
      }
      else
	ceval_1(CAR(x));
      x = t.arg1;
    }
 carloop:			/* eval car of last form in list */
    if NCELLP(CAR(x)) {
      x = CAR(x);
      x = IMP(x) ? EVALIMP(x) : I_VAL(x);
      goto retx;
    }

    if ATOMP(CAR(x)) {
      x = evalatomcar(x);
 retx:
      ENV_MAY_POP(envpp, 0);
      ALLOW_INTS_EGC;
      return x;
    }
    x = CAR(x);
    goto loop;			/* tail recurse */

  case (127 & IM_CASE):
    x = CDR(x);
    t.arg1 = EVALCAR(x);
#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);
      }
    }
  retunspec:
    ENV_MAY_POP(envpp, 0);
    ALLOW_INTS_EGC;
    return UNSPECIFIED;
  case (127 & IM_COND):
    while(NIMP(x = CDR(x))) {
      proc = CAR(x);
      t.arg1 = EVALCAR(proc);
      if NFALSEP(t.arg1) {
	x = CDR(proc);
	if NULLP(x) {
	  x = t.arg1;
	  goto retx;
	}
	if (IM_ARROW != CAR(x)) goto begin;
	proc = CDR(x);
	proc = EVALCAR(proc);
	ASRTGO(NIMP(proc), badfun);
	goto evap1;
      }
    }
    goto retunspec;
  case (127 & IM_DO):
    ENV_MAY_PUSH(envpp);
    x = CDR(x);
    proc = CAR(CDR(x)); /* inits */
    scm_env_tmp = EOL;	/* values */
    while NIMP(proc) {
      scm_env_cons_tmp(EVALCAR(proc));
      proc = CDR(proc);
    }
    EXTEND_ENV(CAR(x));
    x = CDR(CDR(x));
    while (proc = CAR(x), FALSEP(EVALCAR(proc))) {
      for(proc = CAR(CDR(x));NIMP(proc);proc = CDR(proc)) {
	t.arg1 = CAR(proc);	/* body */
	SIDEVAL_1(t.arg1);
      }
      scm_env_tmp = EOL; 
      for(proc = CDR(CDR(x)); NIMP(proc); proc = CDR(proc)) {
	scm_env_cons_tmp(EVALCAR(proc)); /* steps */
      }
      DEFER_INTS_EGC;
      t.arg1 = CAR(CAR(scm_env));
      scm_env = CDR(scm_env);
      EXTEND_ENV(t.arg1);
    }
    x = CDR(proc);
    if NULLP(x) goto retunspec;
    goto begin;
  case (127 & IM_IF):
    x = CDR(x);
    if NFALSEP(EVALCAR(x)) x = CDR(x);
    else if IMP(x = CDR(CDR(x))) goto retunspec;
    goto carloop;
  case (127 & IM_LET):
    ENV_MAY_PUSH(envpp);
    x = CDR(x);
    proc = CAR(CDR(x));
    scm_env_tmp = EOL;
    do {
      scm_env_cons_tmp(EVALCAR(proc));
    } while NIMP(proc = CDR(proc));
    EXTEND_ENV(CAR(x));
    x = CDR(x);
    goto cdrxbegin;
  case (127 & IM_LETREC):
    ENV_MAY_PUSH(envpp);
    x = CDR(x);
    scm_env_tmp = undefineds;
    EXTEND_ENV(CAR(x));
    x = CDR(x);
    proc = CAR(x);
    scm_env_tmp = EOL;
    do {
      scm_env_cons_tmp(EVALCAR(proc));
    } while NIMP(proc = CDR(proc));
    EGC_ROOT(CAR(scm_env));
    CDR(CAR(scm_env)) = scm_env_tmp;
    scm_env_tmp = EOL;
    goto cdrxbegin;
  case (127 & IM_LETSTAR):
    ENV_MAY_PUSH(envpp);
    x = CDR(x);
    proc = CAR(x);
    if IMP(proc) {
      scm_env_tmp = EOL;
      EXTEND_ENV(EOL);
      goto cdrxbegin;
    }
    do {
      t.arg1 = CAR(proc);
      proc = CDR(proc);
      scm_env_tmp = EVALCAR(proc);
      EXTEND_ENV(t.arg1);
    } while NIMP(proc = CDR(proc));
    goto cdrxbegin;
  case (127 & IM_OR):
    x = CDR(x);
    t.arg1 = x;
    while(NNULLP(t.arg1 = CDR(t.arg1))) {
      x = EVALCAR(x);
      if NFALSEP(x) goto retx;
      x = t.arg1;
    }
    goto carloop;
  case (127 & IM_LAMBDA):
    x = closure(CDR(x), ISYMVAL(CAR(x)));
    goto retx;
  case (127 & IM_QUOTE):
    x = CAR(CDR(x));
    goto retx;
  case (127 & IM_SET):
    x = CDR(x);
    arg2 = EVALCAR(CDR(x));
    proc = CAR(x);
    switch (7 & (int)proc) {
    case 0:
      if CONSP(proc)
	*farlookup(proc) = arg2;
      else
	*lookupcar(x, LOOKUP_UNDEFP|LOOKUP_MACROP) = arg2;
      break;
    case 1:
      I_VAL(proc) = arg2;
      break;
    case 4:
      *ilookup(proc) = arg2;
      break;
    }
#ifdef SICP
    x = arg2;
    goto retx;
#endif
    goto retunspec;
  case (127 & IM_DEFINE):	/* only for internal defines */
    goto badfun;
#if 0
    x = CDR(x);
    proc = CAR(x);
    x = CDR(x);
    x = evalcar(x);
    DEFER_INTS_EGC;
    scm_env_tmp = CDR(CAR(scm_env));
    scm_env_cons_tmp(x);
    EGC_ROOT(CAR(scm_env));
    /*    DEFER_INTS; */
    CAR(CAR(scm_env)) = proc;
    CDR(CAR(scm_env)) = scm_env_tmp;
    /*    ALLOW_INTS; */
    goto retunspec;
#endif
	/* new syntactic forms go here. */
  case (127 & MAKISYM(0)):
    proc = CAR(x);
    ASRTGO(ISYMP(proc), badfun);
#ifdef SCM_PROFILE
    eval_cases_other[ISYMNUM(proc)]++;
#endif
    switch ISYMNUM(proc) {
    case (ISYMNUM(IM_APPLY)):
      proc = CDR(x);
      proc = EVALCAR(proc);
      ASRTGO(NIMP(proc), badfun);
      t.arg1 = CDR(CDR(x));
      t.arg1 = EVALCAR(t.arg1);
      if (CLOSUREP(proc)) {
	ENV_MAY_PUSH(envpp);
	scm_env_tmp = t.arg1;
#ifndef RECKLESS
	goto clo_checked;
#else
	goto clo_unchecked;
#endif
      }
      x = apply(proc, t.arg1, EOL);
      goto retx;                
    case (ISYMNUM(IM_DELAY)):
      x = makprom(closure(CDR(x), 0));
      goto retx;
    case (ISYMNUM(IM_QUASIQUOTE)):
      ALLOW_INTS_EGC;
      x = iqq(CAR(CDR(x)));
      goto retx;
    case (ISYMNUM(IM_FARLOC_CAR)):
    case (ISYMNUM(IM_FARLOC_CDR)):
      x = *farlookup(x);
      goto retx;
    default:
      goto badfun;
    }
  default:
    proc = x;
  badfun:
    everr(x, wrapenv() /*scm_env*/, proc, s_wtap, "");
  case tc7_vector:
  case tc7_bvect: case tc7_ivect: case tc7_uvect:
  case tc7_fvect: case tc7_dvect: case tc7_cvect:
  case tc7_string:
  case tc7_smob:
    goto retx;
  case (127 & ILOC00):
    proc = *ilookup(CAR(x));
    break;
  case tcs_cons_gloc:
    proc = I_VAL(CAR(x));
    break;
  case tcs_cons_nimcar:
    if ATOMP(CAR(x)) {
      x = macroexp1(x, !0);
      goto loop;
    }
    proc = ceval_1(CAR(x));
    /* At this point proc is the evaluated procedure from the function
       position and x has the form which is being evaluated. */
  }
  ASRTGO(NIMP(proc), badfun);
  *scm_estk_ptr = scm_env; /* For error reporting at wrongnumargs. */
  if NULLP(CDR(x)) {
  evap0:
    ENV_MAY_POP(envpp, CLOSUREP(proc));
    ALLOW_INTS_EGC;
    switch TYP7(proc) { /* no arguments given */
    case tc7_subr_0:
      return SUBRF(proc)();
    case tc7_subr_1o:
      return SUBRF(proc) (UNDEFINED);
    case tc7_lsubr:
      return SUBRF(proc)(EOL);
    case tc7_rpsubr:
      return BOOL_T;
    case tc7_asubr:
      return SUBRF(proc)(UNDEFINED, UNDEFINED);
    case tcs_closures:
      DEFER_INTS_EGC;
      ENV_MAY_PUSH(envpp);
      scm_env_tmp = EOL;
#ifdef SCM_PROFILE
      eval_clo_cases[0][0]++;
#endif
#ifdef CAUTIOUS
      if (0!=ARGC(proc)) {
      clo_checked:
	DEFER_INTS_EGC;
	t.arg1 = CAR(CODE(proc));
	arg2 = scm_env_tmp;
	while NIMP(t.arg1) {
	  if NCONSP(t.arg1) goto clo_unchecked;
	  if IMP(arg2) goto umwrongnumargs;
	  t.arg1 = CDR(t.arg1);
	  arg2 = CDR(arg2);
	}
	if NNULLP(arg2) goto umwrongnumargs;
      }
#else /* def CAUTIOUS */
    clo_checked:
#endif
    clo_unchecked:
      x = CODE(proc);
      scm_env = ENV(proc);
      EXTEND_ENV(CAR(x));
      goto cdrxbegin;
    case tc7_specfun:
#ifdef CCLO
      if (tc16_cclo==TYP16(proc)) {
	t.arg1 = proc;
	proc = CCLO_SUBR(proc);
	goto evap1;
      }
#endif
    case tc7_contin:
    case tc7_subr_1:
    case tc7_subr_2:
    case tc7_subr_2o:
    case tc7_cxr:
    case tc7_subr_3:
    case tc7_lsubr_2:
    umwrongnumargs:
      unmemocar(x);
    wrongnumargs:
      if (envpp < 0) {
	scm_estk_ptr += SCM_ESTK_FRLEN;
	scm_env = *scm_estk_ptr;
      }
      everr(x, wrapenv()/*scm_env*/, proc, (char *)WNA, "");
    default:
      goto badfun;
    }
  }
  x = CDR(x);
#ifdef CAUTIOUS
  if (IMP(x)) goto wrongnumargs;
#endif
  t.arg1 = EVALCAR(x);
  x = CDR(x);
  if NULLP(x) {
evap1:
    ENV_MAY_POP(envpp, CLOSUREP(proc));
    ALLOW_INTS_EGC;
    switch TYP7(proc) { /* have one argument in t.arg1 */
    case tc7_subr_2o:
      return SUBRF(proc)(t.arg1, UNDEFINED);
    case tc7_subr_1:
    case tc7_subr_1o:
      return SUBRF(proc)(t.arg1);
    case tc7_cxr:
#ifdef FLOATS
    if SUBRF(proc) {
      if INUMP(t.arg1)
	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));
    case tcs_closures:
      ENV_MAY_PUSH(envpp);
#ifdef SCM_PROFILE
      eval_clo_cases[1][ARGC(proc)]++;
#endif
      if (1==ARGC(proc)) {
	scm_env_cons(t.arg1, EOL);
	goto clo_unchecked;
      }
      else {
	scm_env_tmp = cons(t.arg1, EOL);
	goto clo_checked;
      }
    case tc7_contin:
      scm_dynthrow(CONT(proc), t.arg1);
    case tc7_specfun:
      switch TYP16(proc) {
      case tc16_call_cc:
	proc = t.arg1;
	DEFER_INTS_EGC;
	t.arg1 = scm_make_cont();
	EGC_ROOT(t.arg1);
	if ((x = setjump(CONT(t.arg1)->jmpbuf))) {
#ifdef SHORT_INT
	  x = (SCM)thrown_value;
#endif
	  goto retx;
	}
	ASRTGO(NIMP(proc), badfun);
	goto evap1;
#ifdef CCLO
      case tc16_cclo:
	arg2 = t.arg1;
	t.arg1 = proc;
	proc = CCLO_SUBR(proc);
	goto evap2;
#endif
      }
    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);
    x = CDR(x);
    if NULLP(x) {		/* have two arguments */
  evap2:
      ENV_MAY_POP(envpp, CLOSUREP(proc));
      ALLOW_INTS_EGC;
      switch TYP7(proc) {
      case tc7_subr_2:
      case tc7_subr_2o:
	return SUBRF(proc)(t.arg1, arg2);
      case tc7_lsubr:
	return SUBRF(proc)(cons2(t.arg1, arg2, EOL));
      case tc7_lsubr_2:
	return SUBRF(proc)(t.arg1, arg2, EOL);
      case tc7_rpsubr:
      case tc7_asubr:
	return SUBRF(proc)(t.arg1, arg2);
      case tc7_specfun:
	switch TYP16(proc) {
	case tc16_apply:
	  proc = t.arg1;
	  if NULLP(arg2) goto evap0;
	  if (IMP(arg2) || NCONSP(arg2)) {
	    x = arg2;
	  badlst: wta(x, (char *)ARGn, s_apply);
	  }
	  t.arg1 = CAR(arg2);
	  x = CDR(arg2);
	apply3:
	  if NULLP(x) goto evap1;
	  ASRTGO(NIMP(x) && CONSP(x), badlst);
	  arg2 = CAR(x);
	  x = CDR(x);
	apply4:
	  if NULLP(x) goto evap2;
	  ASRTGO(NIMP(x) && CONSP(x), badlst);
	  arg3 = CAR(x);
	  ASRTGO(0 <= ilength(x), badlst);
	  x = copy_list(CDR(x));
	  goto evap3;
#ifdef CCLO
	case tc16_cclo: cclon:
	  return apply(CCLO_SUBR(proc),
		       cons2(proc, t.arg1, cons(arg2, x)), EOL);
       /* arg3 = arg2;
	  arg2 = t.arg1;
	  t.arg1 = proc;
	  proc = CCLO_SUBR(proc);
	  goto evap3; */
#endif
	}
      case tc7_subr_0:
      case tc7_cxr:
      case tc7_subr_1o:
      case tc7_subr_1:
      case tc7_subr_3:
      case tc7_contin:
	goto wrongnumargs;
      default:
	goto badfun;
      case tcs_closures:
	ENV_MAY_PUSH(envpp);
#ifdef SCM_PROFILE
	eval_clo_cases[2][ARGC(proc)]++;
#endif
	switch ARGC(proc) {
	case 2: 
	  scm_env_cons2(t.arg1, arg2, EOL);
	  goto clo_unchecked;
	case 1:
	  scm_env_cons(t.arg1, cons(arg2, EOL));
	  goto clo_checked;
	case 0:	
	case 3:		/* Error, will be caught at clo_checked: */
	  scm_env_tmp = cons2(t.arg1, arg2, EOL); 
	  goto clo_checked;
	}
      }
    }
    {				/* have 3 or more arguments */
      arg3 = EVALCAR(x);
      x = CDR(x);
      if NIMP(x) x = eval_args(x);
    evap3:
      ENV_MAY_POP(envpp, CLOSUREP(proc));      
      ALLOW_INTS_EGC;
      switch TYP7(proc) {
      case tc7_subr_3:
	ASRTGO(NULLP(x), wrongnumargs);
	return SUBRF(proc)(t.arg1, arg2, arg3);
      case tc7_asubr:
	/*      t.arg1 = SUBRF(proc)(t.arg1, arg2);
		while NIMP(x) {
		t.arg1 = SUBRF(proc)(t.arg1, EVALCAR(x, env));
		x = CDR(x);
		}
		return t.arg1; */
      case tc7_rpsubr:
	return apply(proc, cons2(t.arg1, arg2, cons(arg3, x)), EOL);
      case tc7_lsubr_2:
	return SUBRF(proc)(t.arg1, arg2, cons(arg3, x));
      case tc7_lsubr:
	return SUBRF(proc)(cons2(t.arg1, arg2, cons(arg3, x)));
      case tcs_closures:
	ENV_MAY_PUSH(envpp);
#ifdef SCM_PROFILE
	eval_clo_cases[IMP(x)?3:4][ARGC(proc)]++;
#endif
	switch ARGC(proc) {
	case 3:
	  scm_env_cons2(arg2, arg3, x);
	  scm_env_cons_tmp(t.arg1);
	  goto clo_checked;
	case 2:
	  scm_env_cons2(t.arg1, arg2, cons(arg3, x));
	  goto clo_checked;
	case 1:
	  scm_env_cons(t.arg1, cons2(arg2, arg3, x));
	  goto clo_checked;
	case 0:
	  scm_env_tmp = cons2(t.arg1, arg2, cons(arg3, x));
	  goto clo_checked;
	}
      case tc7_specfun:
	switch TYP16(proc) {
	case tc16_apply:
	  proc = t.arg1;
	  t.arg1 = arg2;
	  if IMP(x) {
	    x = arg3;
	    goto apply3;
	  }
	  arg2 = arg3;
	  if IMP(CDR(x)) {
	    x = CAR(x);
	    goto apply4;
	  }
	  arg3 = CAR(x);
	  x = nconc2copy(CDR(x));
	  goto evap3;
#ifdef CCLO
	case tc16_cclo:
	  x = cons(arg3, x);
	  goto cclon;
#endif
	}
      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:
	case tc7_specfun:
	  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:
  case tc7_specfun:
*/
  }
}

/* This code is for apply. it is destructive on multiple args.
   This will only screw you if you do (apply apply '( ... )) */
/* Copy last (list) argument, so SET! in a closure can't mutate it. */
SCM nconc2copy(lst)
     SCM lst;
{
  SCM last, *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
  last = CAR(*lloc);
  *lloc = EOL;
  for(; NIMP(last); last=CDR(last)) {
    *lloc = cons(CAR(last), EOL);
    lloc = &CDR(*lloc);
  }
  return lst;
}
/* Shallow copy */
SCM copy_list(lst)
     SCM lst;
{
  SCM res, *lloc = &res;
  res = EOL;
  for(; NIMP(lst); lst = CDR(lst)) {
    *lloc = cons(CAR(lst), EOL);
    lloc = &CDR(*lloc);
  }
  return res;
}
SCM apply(proc, arg1, args)
     SCM proc, arg1, args;
{
 apply_tail:
  ASRTGO(NIMP(proc), badproc);
  if NULLP(args)
    if NULLP(arg1) arg1 = UNDEFINED;
    else {
      args = CDR(arg1);
      arg1 = CAR(arg1);
    }
  else {
    /*		ASRTGO(NIMP(args) && CONSP(args), wrongnumargs); */
    args = nconc2copy(args);
  }
 cc_tail:
  ALLOW_INTS_EGC;
  switch TYP7(proc) {
  case tc7_subr_2o:
    if NULLP(args) {
      args = UNDEFINED;
      return SUBRF(proc)(arg1, args);
    }
    /* Fall through */
  case tc7_subr_2:
    ASRTGO(NIMP(args) && NULLP(CDR(args)), wrongnumargs);
    args = CAR(args);
    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:
    ASRTGO(NIMP(args) && NIMP(CDR(args)) && NULLP(CDR(CDR(args))),
	   wrongnumargs);
    return SUBRF(proc)(arg1, CAR(args), CAR(CDR(args)));
  case tc7_lsubr:
    return SUBRF(proc)(UNBNDP(arg1) ? EOL : cons(arg1, args));
  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(proc, arg1)) goto wrongnumargs;
#endif
    DEFER_INTS_EGC;
    ENV_PUSH;
    TRACE(proc);
    scm_env_tmp = arg1;
    scm_env = ENV(proc);
    EXTEND_ENV(CAR(CODE(proc)));
    proc = CODE(proc);
    arg1 = ceval_1(cons(IM_BEGIN, CDR(proc)));
    /*    while NNULLP(proc = CDR(proc)) arg1 = EVALCAR(proc); */
    ENV_POP;
    return arg1;
  case tc7_contin:
    ASRTGO(NULLP(args), wrongnumargs);
    scm_dynthrow(CONT(proc), arg1);
  case tc7_specfun:
    switch TYP16(proc) {
    case tc16_apply:
      ASRTGO(!UNBNDP(arg1), wrongnumargs);
      proc = arg1;
      arg1 = args;
      args = EOL;
      goto apply_tail;
    case tc16_call_cc:
      ASRTGO(NULLP(args), wrongnumargs);
      proc = arg1;
      ASRTGO(NIMP(proc), badproc);
      DEFER_INTS_EGC;
      arg1 = scm_make_cont();
      EGC_ROOT(arg1);
      if ((args = setjump(CONT(arg1)->jmpbuf))) {
#ifdef SHORT_INT
	args = (SCM)thrown_value;
#endif
	return args;
      }
      args = EOL;
      goto cc_tail;
#ifdef CCLO
    case tc16_cclo:
      args = (UNBNDP(arg1) ? EOL : cons(arg1, args));
      arg1 = proc;
      proc = CCLO_SUBR(proc);
      goto cc_tail;
#endif
    }
    goto badproc;
  wrongnumargs:
    wta(proc, (char *)WNA, s_apply);
  default:
  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;
	scm_protect_temp(&args);  /* Keep args from being optimized away. */
	if NULLP(arg1) return res;
	ASSERT(NIMP(arg1), arg1, ARG2, s_map);
	if NULLP(args) {
		while NIMP(arg1) {
			ASSERT(CONSP(arg1), arg1, ARG2, s_map);
			*pres = cons(apply(proc, CAR(arg1), listofnull), EOL);
			pres = &CDR(*pres);
			arg1 = CDR(arg1);
		}
		return res;
	}
	args = vector(cons(arg1, args));
	ve = VELTS(args);
#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;
	long i;
	scm_protect_temp(&args); /* Keep args from being optimized away. */
	if NULLP(arg1) return UNSPECIFIED;
	ASSERT(NIMP(arg1), arg1, ARG2, s_for_each);
	if NULLP(args) {
		while NIMP(arg1) {
			ASSERT(CONSP(arg1), arg1, ARG2, s_for_each);
			apply(proc, CAR(arg1), listofnull);
			arg1 = CDR(arg1);
		}
		return UNSPECIFIED;
	}
	args = vector(cons(arg1, args));
	ve = VELTS(args);
	while (1) {
		arg1 = EOL;
		for (i = LENGTH(args)-1;i >= 0;i--) {
			if IMP(ve[i]) return UNSPECIFIED;
			arg1 = cons(CAR(ve[i]), arg1);
			ve[i] = CDR(ve[i]);
		}
		apply(proc, arg1, EOL);
	}
}

/* The number of required arguments up to 3 is encoded in the cdr of the
   closure.  This information is used to make sure that rest args are not
   allocated in the environment cache. */
SCM closure(code, argc)
     SCM code;
     int argc;
{
	register SCM z;
	if (argc > 3) argc = 3;
	NEWCELL(z);
	SETCODE(z, code);
	DEFER_INTS_EGC;
	if (IMP(scm_env))
	  CDR(z) = argc<<1;
	else {
	  CDR(z) = scm_env | (argc<<1);
	  EGC_ROOT(z);
	}
	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;
}
static int prinenv(exp, port, writing)
     SCM exp;
     SCM port;
     int writing;
{
  lputs("#<environment ", port);
  intprint((long)exp, -16, port);
  /* iprin1(CDR(exp), port, writing); */
  lputc('>', port);
  return !0;
}
#ifdef MACRO
static int prinid(exp, port, writing)
     SCM exp;
     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 = id2sym(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, ret;
  
# 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;
  DEFER_INTS_EGC;
  ENV_PUSH;
  scm_env = (NIMP(env) && tc16_env==CAR(env)) ? CDR(env) : env;
  ret =  (id_denote(id1)==id_denote(id2)) ? BOOL_T : BOOL_F;
  ENV_POP;
  return ret;
}

static char s_ident2sym[] = "identifier->symbol";
SCM ident2sym(id)
     SCM id;
{
  id = id2sym(id);
  ASSERT(NIMP(id) && SYMBOLP(id), id, ARG1, s_ident2sym);
  return id;
}

static char s_renamed_ident[] = "renamed-identifier";
SCM renamed_ident(id, env)
     SCM id, env;
{
  SCM z;
  ASSERT(NIMP(id) && IDENTP(id), id, ARG1, s_renamed_ident);
  if NIMP(env) {
    ASSERT(tc16_env==CAR(env), env, ARG2, s_renamed_ident);
    DEFER_INTS_EGC;
    env = CDR(env);
  }
  NEWCELL(z);
  if IMP(env) {
    CAR(z) = tc16_ident;
    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;
{
  SCM mark;
  DEFER_INTS_EGC;
  if (tc16_env==CAR(env))
    env = CDR(env);
  if NULLP(env) return m_let(xorig, env);
  mark = CAR(CAR(env));
  if (NIMP(mark) && CONSP(mark)) return m_let(xorig, env);
  mark = renamed_ident(i_mark, BOOL_F);
  return m_letstar(cons2(i_let,
			 cons(cons2(mark, BOOL_F, EOL), EOL),
			 acons(TOPRENAME(i_let), CDR(xorig), EOL)),
		   env);
}

static char s_the_macro[] = "the-macro";
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, LOOKUP_UNDEFP);
  else
    x = evalcar(x);
  ASSYNT(NIMP(x) && MACROP(x), xorig, ARG1, s_the_macro);
  return cons2(IM_QUOTE, x, EOL);
}
#endif

static char s_env2tree[] = "environment->tree";
SCM env2tree(env)
     SCM env;
{
  SCM ans, a, *lloc;
  if NULLP(env) return env;
  ASSERT(NIMP(env) && tc16_env==CAR(env), env, ARG1, s_env2tree);
  DEFER_INTS_EGC;
  if IMP(CDR(env)) return env;
  ENV_PUSH;
  scm_env = CDR(env);
  ans = a = cons(UNSPECIFIED, UNSPECIFIED);
  while (!0) {
    scm_env_tmp = CAR(scm_env);
    lloc = &CAR(a);
    while (NIMP(scm_env_tmp) && CONSP(scm_env_tmp)) {
      *lloc = cons(CAR(scm_env_tmp), CDR(scm_env_tmp));
      lloc = &CDR(*lloc);
      DEFER_INTS_EGC;
      scm_env_tmp = CDR(scm_env_tmp);
    }
    scm_env = CDR(scm_env);
    if IMP(scm_env) {
      CDR(a) = scm_env;
      break;
    }
    a = (CDR(a) = cons(UNSPECIFIED, UNSPECIFIED));
  }
  ENV_POP;
  ALLOW_INTS_EGC;
  return ans;
}

static iproc subr1s[] = {
	{"@copy-tree", copytree},
	{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", nconc2copy},
	{s_env2tree, env2tree},
#ifdef MACRO
	{s_identp, identp},
	{s_ident2sym, ident2sym},
#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};
static smobfuns envsmob = {markcdr, free0, prinenv};
#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);
}
SCM make_specfun(name, typ)
     char *name;
     int typ;
{
  SCM symcell = sysintern(name, UNDEFINED);
  register SCM z;
  NEWCELL(z);
  CAR(z) = (long)typ;
  CDR(z) = CAR(symcell);
  CDR(symcell) = z;
  return z;
}
void init_eval()
{
  tc16_promise = newsmob(&promsmob);
  tc16_macro = newsmob(&macrosmob);
  tc16_env = newsmob(&envsmob);
  init_iprocs(subr1s, tc7_subr_1);
  init_iprocs(lsubr2s, tc7_lsubr_2);
#ifdef SCM_PROFILE
  make_subr("scm:profile", tc7_subr_1o, scm_profile);
#endif
  make_specfun(s_apply, tc16_apply);
  make_specfun(s_call_cc, tc16_call_cc);

  i_dot = CAR(sysintern(".", UNDEFINED));
  i_arrow = CAR(sysintern("=>", UNDEFINED));
  i_else = CAR(sysintern("else", UNDEFINED));
  i_unquote = CAR(sysintern("unquote", UNDEFINED));
  i_uq_splicing = CAR(sysintern("unquote-splicing", UNDEFINED));

  /* acros */
  i_quasiquote = make_synt(s_quasiquote, makmmacro, m_quasiquote);
  i_define = 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
}