path: root/eval.c

/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1997, 1998, 1999 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, 59 Temple Place, Suite 330, Boston, MA 02111, 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, int minlen));
SCM scm_v2lst P((long argc, SCM *argv));
SCM rename_ident P((SCM id, SCM env));
SCM *lookupcar P((SCM vloc, int check));
SCM eqv P((SCM x, SCM y));
SCM scm_multi_set P((SCM syms, SCM vals));
SCM eval_args P((SCM x));
void scm_dynthrow P((SCM cont, SCM val));
void scm_egc P((void));
void scm_estk_grow P((void));
void scm_estk_shrink P((void));
int badargsp P((SCM proc, SCM args));

static SCM asubr_apply P((SCM proc, SCM arg1, SCM arg2, SCM arg3, 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_expand_body P((SCM xorig));
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, SCM defs));
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 unpaint P((SCM *p));
static void ecache_evalx P((SCM x));
static int ecache_eval_args P((SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM x));
static int varcheck P((SCM xorig, SCM vars, char *op, char *what));
#ifdef CAREFUL_INTS
static void debug_env_warn P((char *fnam, long line, char *what));
static void debug_env_save P((char *fnam, long line));
#endif

/* Flush global variable state to estk. */
#ifdef CAREFUL_INTS
# define ENV_SAVE debug_env_save(__FILE__, __LINE__)
#else
# define ENV_SAVE {scm_estk_ptr[0]=scm_env; scm_estk_ptr[1]=scm_env_tmp;}
#endif

/* 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 (UNDEFINED==scm_estk_ptr[SCM_ESTK_FRLEN]) scm_estk_grow();\
		  else scm_estk_ptr += SCM_ESTK_FRLEN;}

#define ENV_POP {DEFER_INTS_EGC;\
                 if (UNDEFINED==scm_estk_ptr[-1]) 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

#ifdef CAUTIOUS
SCM scm_trace = UNDEFINED;
#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);}
# define TOP_TRACE(x) {scm_trace=(x);}
# define PUSH_TRACE TRACE(scm_trace)
#else
# define TRACE(x) /**/
# define TOP_TRACE(x) /**/
# define PUSH_TRACE /**/
#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_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;
}
static void debug_env_save(fnam, line)
     char *fnam;
     long line;
{
  if (NIMP(scm_env) && (!scm_cell_p(scm_env)))
    debug_env_warn(fnam, line, "ENV_SAVE (env)");
  if (NIMP(scm_env_tmp) && (!scm_cell_p(scm_env_tmp)))
    debug_env_warn(fnam, line, "ENV_SAVE (tmp)");
  scm_estk_ptr[0]=scm_env;
  scm_estk_ptr[1]=scm_env_tmp;
}

#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_MEMOIZE, LOOKUP_UNDEFP, and LOOKUP_MACROP,
   if check is zero then memoization will not be done. */
#define LOOKUP_MEMOIZE 1
#define LOOKUP_UNDEFP 2
#define LOOKUP_MACROP 4
SCM *lookupcar(vloc, check)
     SCM vloc;
     int check;
{
  SCM env;
  long icdr = 0L;
  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;
  if (NIMP(env) && ENVP(env))
    env = CDR(env);
  for(; NIMP(env); env = CDR(env)) {
    idist = 0;
    al = &CAR(env);
    fl = CAR(*al);
#ifdef MACRO
    if (fl==mark) {
      var = IDENT_PARENT(var);
      mark = IDENT_MARK(var);
    }
#endif
/*     constant environment section -- not used as yet.
    if (BOOL_T==fl) {
      fl = assq(var, CDR(fl));
      if FALSEP(fl) break;
      var = fl;
      goto gloc_out;
    }
*/
    for(;NIMP(fl);fl = CDR(fl)) {
      if NCONSP(fl)
	if (fl==var) {
	  icdr = ICDR;
#ifndef RECKLESS
	  fl = CDR(*al);
#endif
	  goto local_out;
	}
	else break;
      al = &CDR(*al);
      if (CAR(fl)==var) {
#ifndef RECKLESS		/* letrec inits to UNDEFINED */
	fl = CAR(*al);
      local_out:
	if ((check & LOOKUP_UNDEFP)
	    && UNBNDP(fl)) {env = EOL; goto errout;}
# ifdef MACRO
	if ((check & LOOKUP_MACROP)
	    && NIMP(fl) && MACROP(fl)) goto badkey;
# endif
	if ((check) && NIMP(scm_env) && ENVP(scm_env))
	  everr(vloc, scm_env, var,
		"run-time reference", "");
#else  /* ndef RECKLESS */
      local_out:
#endif
#ifdef MEMOIZE_LOCALS
	if (check) {
# ifndef TEST_FARLOC
	  if (iframe < 4096 && idist < (1L<<(LONG_BIT-20)))
	    CAR(vloc) = MAKILOC(iframe, idist) + icdr;
	  else
# endif
	    CAR(vloc) = cons2(icdr ? IM_FARLOC_CDR : IM_FARLOC_CAR,
			      MAKINUM(iframe), MAKINUM(idist));
	}
#endif
	return icdr ? &CDR(*al) : &CAR(*al);
      }
      idist++;
    }
    iframe++;
  }
#ifdef MACRO
  while M_IDENTP(var) {
    ASRTGO(IMP(IDENT_MARK(var)), errout);
    var = IDENT_PARENT(var);
  }
#endif
  var = sym2vcell(var);
 gloc_out:
#ifndef RECKLESS
  if (NNULLP(env) || ((check & LOOKUP_UNDEFP) && UNBNDP(CDR(var)))) {
    var = CAR(var);
  errout:
    everr(vloc, wrapenv(), 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(), var, s_badkey, "");
  }
# endif
#endif
  if (check) 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 (NIMP(env) && ENVP(env)) env = CDR(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(), CAR(x), "Cannot evaluate: ", "");
  case tcs_symbols:
  lookup:
    return *lookupcar(x, LOOKUP_UNDEFP|LOOKUP_MACROP);
  case tc7_vector:
#ifndef RECKLESS
    if (2 <= verbose) scm_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 tcs_uves:
    return CAR(x);
  }
}

SCM scm_multi_set(syms, vals)
     SCM syms, vals;
{
  SCM res = EOL, *pres = &res;
  SCM *loc;
  do {
    ASSERT(NIMP(vals) && CONSP(vals), vals, WNA, s_set);
    switch (7 & (int)(CAR(syms))) {
    case 0:
      loc = lookupcar(syms, LOOKUP_UNDEFP|LOOKUP_MACROP);
      break;
    case 1:
      loc = &(I_VAL(CAR(syms)));
      break;
    case 4:
      loc = ilookup(CAR(syms));
      break;
    }
    *pres = cons(*loc, EOL);
    pres = &CDR(*pres);
    *loc = CAR(vals);
    syms = CDR(syms);
    vals = CDR(vals);
  } while (NIMP(syms));
  ASSERT(NULLP(vals) && NULLP(syms), vals, WNA, s_set);
  return res;
}

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

static void ecache_evalx(x)
     SCM x;
{
  SCM argv[10];
  int i = 0, imax = sizeof(argv)/sizeof(SCM);
  scm_env_tmp = EOL;
  while NIMP(x) {
    if (imax==i) {
      ecache_evalx(x);
      break;
    }
    argv[i++] = EVALCAR(x);
    x = CDR(x);
  }
  scm_env_v2lst(i, argv);
}

/* result is 1 if right number of arguments, 0 otherwise,
   environment frame is put in scm_env_tmp */
static int ecache_eval_args(proc, arg1, arg2, arg3, x)
     SCM proc, arg1, arg2, arg3, x;
{
  SCM argv[3];
  argv[0] = arg1;
  argv[1] = arg2;
  argv[2] = arg3;
  if (NIMP(x))
    ecache_evalx(x);
  else
    scm_env_tmp = EOL;
  scm_env_v2lst(3, argv);
#ifndef RECKLESS
  proc = CAR(CODE(proc));
  proc = CDR(proc);
  proc = CDR(proc);
  proc = CDR(proc);  
  for (; NIMP(proc); proc=CDR(proc)) {
    if IMP(x) return 0;
    x = CDR(x);
  }
  if NIMP(x) return 0;
#endif
  return 1;
}

static SCM asubr_apply(proc, arg1, arg2, arg3, args)
     SCM proc, arg1, arg2, arg3, args;
{
  switch TYP7(proc) {
  case tc7_asubr:
    arg1 = SUBRF(proc)(arg1, arg2);
    arg1 = SUBRF(proc)(arg1, arg3);
    while NIMP(args) {
      arg1 = SUBRF(proc)(arg1, CAR(args));
      args = CDR(args);
    }
    return arg1;
  case tc7_rpsubr:
    if FALSEP(SUBRF(proc)(arg1, arg2)) return BOOL_F;
    while (!0) {
      if FALSEP(SUBRF(proc)(arg2, arg3)) return BOOL_F;
      if IMP(args) return BOOL_T;
      arg2 = arg3;
      arg3 = CAR(args);
      args = CDR(args);
    }
  }
}

    /* 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;
  if (NIMP(env) && ENVP(env)) env = CDR(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);
    }
  }
# ifndef RECKLESS
  while M_IDENTP(var) {
    ASSERT(IMP(IDENT_MARK(var)), var, s_escaped, "");
    var = IDENT_PARENT(var);
  }
# endif
  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 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);
  varcheck(xorig,
	   (NIMP(CAR(x)) && IDENTP(CAR(x))) ? CAR(x) :
	   (ilength(CAR(x)) > 0) ? CAR(x) : UNDEFINED,
	   s_set, s_variable);
  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);
  switch (len) {
  default: return cons(IM_AND, CDR(xorig));
  case 1: return CAR(CDR(xorig));
  case 0: return BOOL_T;
  }
}

SCM m_or(xorig, env)
     SCM xorig, env;
{
  int len = ilength(CDR(xorig));
  ASSYNT(len >= 0, xorig, s_test, s_or);
  switch (len) {
  default: return cons(IM_OR, CDR(xorig));
  case 1: return CAR(CDR(xorig));
  case 0: 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), 2), x = cdrx;
#ifndef RECKLESS
  SCM s, keys = EOL;
#endif
  ASSYNT(!UNBNDP(cdrx), 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 {
#ifdef MACRO
      SCM c = copy_list(CAR(clause), 0);
      ASSYNT(!UNBNDP(c), xorig, s_clauses, s_case);
      clause = cons(c, CDR(clause));
      DEFER_INTS;
      unpaint(&CAR(clause));
      ALLOW_INTS;
      CAR(x) = clause;
#else
      ASSYNT(ilength(CAR(clause)) >= 0, xorig, s_clauses, s_case);
#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), 1), x = cdrx;
  int len = ilength(x);
  ASSYNT(!UNBNDP(cdrx), 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);
}

static int varcheck(xorig, vars, op, what)
     SCM xorig, vars;
     char *op, *what;
{
  SCM v1, vs;
  int argc = 0;
  for (; NIMP(vars) && CONSP(vars); vars = CDR(vars)) {
    argc++;
#ifndef RECKLESS
    v1 = CAR(vars);
    if (IMP(v1) || !IDENTP(v1))
      badvar: wta(xorig, what, op);
    for (vs = CDR(vars); NIMP(vs) && CONSP(vs); vs = CDR(vs)) {
      if (v1==CAR(vs))
	nonuniq: wta(xorig, "non-unique bindings", op);
    }
    if (v1==vs) goto nonuniq;
#endif
  }
		/* argc of 3 means no rest argument, 3+ required arguments */
  if (NULLP(vars) || ISYMP(vars)) return argc > 3 ? 3 : argc;
  ASRTGO(NIMP(vars) && IDENTP(vars), badvar);
  return argc > 2 ? 2 : argc;
}
SCM m_lambda(xorig, env)
     SCM xorig, env;
{
  SCM x = CDR(xorig);
  int argc;
  ASSERT(ilength(x) > 1, xorig, s_formals, s_lambda);
  argc = varcheck(xorig, CAR(x), s_lambda, s_formals);
  if (argc > 3) argc = 3;
  return cons2(MAKISYMVAL(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)
   (<initn> ... <init2> <init1>)
   (<test> <return>)
   (<body>)
   <stepn> ... <step2> <step1>) ;; 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;
  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);
    /* vars reversed here, inits and steps reversed at evaluation */
    vars = cons(CAR(arg1), vars); /* variable */
    arg1 = CDR(arg1);
    inits = cons(CAR(arg1), inits);
    arg1 = CDR(arg1);
    steps = cons(IMP(arg1)?CAR(vars):CAR(arg1), steps);
    proc = CDR(proc);
  }
  x = CDR(x);
  ASSYNT(ilength(CAR(x)) >= 1, xorig, s_test, s_do);
  ASSYNT(ilength(CDR(x))>=0, xorig, s_expression, s_do);
  varcheck(xorig, vars, s_do, s_variable);
  x = cons2(CAR(x), CDR(x), steps);
  x = cons2(vars, inits, x);
  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));
}

static int built_inp(name, x)
     SCM name, x;
{
  if NIMP(x) {
 tail:
    switch TYP7(x) {
    case tcs_subrs: return CHARS(name)==SNAME(x);
    case tc7_smob: if MACROP(x) {x = CDR(x); goto tail;}
		/* else fall through */
    }
  }
  return 0;
}

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) && ENVP(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 &&
	built_inp(proc, CDR(arg1))
	&& (CDR(arg1) != x))
      scm_warn("redefining built-in ", CHARS(proc));
    else
#endif
    if (5 <= verbose && UNDEFINED != CDR(arg1))
      scm_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);
}
/* 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;
  /*  ASRTSYNTAX(ilength(x) >= 2, s_body); */
  proc = CAR(x);
  ASRTSYNTAX(ilength(proc) >= 1, s_bindings);
  do {
    arg1 = CAR(proc);
    ASRTSYNTAX(2==ilength(arg1), s_bindings);
    vars = cons(CAR(arg1), vars);
    inits = cons(CAR(CDR(arg1)), inits);
  } while NIMP(proc = CDR(proc));
  varcheck(xorig, vars, what, s_variable);
  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), cons(name, EOL));
  return cons(m_letrec1(IM_LETREC, IM_LET, proc, env), inits);
}

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

static 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(form, defs);
    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, defs)
     SCM x, defs;
{
  SCM res = UNDEFINED, proc = CAR(x);
  int argc;
  ASRTGO(IDENTP(proc), badfun);
 macro_tail:
  res = CAR(x);
  proc = *lookupcar(x, IMP(defs) ? LOOKUP_UNDEFP : 0);
  if (NIMP(proc) && MACROP(proc)) {
    CAR(x) = res;
    res = cons2(x, wrapenv(), EOL);
    switch ((int)(CAR(proc)>>16) & 0x7f) {
    case 2: case 6:		/* mmacro */
      if (IMP(defs)) {
	res = apply(CDR(proc), res, EOL);
	if (ilength(res) <= 0)
	  res = cons2(IM_BEGIN, res, EOL);
	DEFER_INTS;
	CAR(x) = CAR(res);
	CDR(x) = CDR(res);
	ALLOW_INTS;
	break;
      }
     /* else fall through */
    case 1: case 5:		/* macro */
      res = apply(CDR(proc), res, EOL);
      x =  NIMP(res) ? res : cons2(IM_BEGIN, res, EOL);
      break;
    case 0: case 4:		/* acro */
      res = IMP(defs) ? apply(CDR(proc), res, EOL) : UNSPECIFIED;
      return cons2(IM_QUOTE, res, EOL);
    }
    if (NIMP(CAR(x)) && IDENTP(CAR(x))) goto macro_tail;
#ifndef RECKLESS
    if (UNBNDP(defs) && IM_DEFINE==CAR(x))
      everr(x, wrapenv(), i_define, "Bad placement", "");
#endif
    return x;
  }
#ifndef RECKLESS
  if (IMP(defs)) {
    if (! scm_arity_check(proc, ilength(CDR(x)), (char *)0)) {
    badfun:
      if (!UNBNDP(res)) CAR(x) = res;
      everr(x, wrapenv(), UNBNDP(proc) ? CAR(x) : proc,
	    UNBNDP(proc) ? s_unbnd :
	          (FALSEP(procedurep(proc)) ? s_wtap : (char *)WNA),
	    "");
    }
  }
#endif /* ndef RECKLESS */
  return x;
}

#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;
}
/* If what is null, signals error instead of returning false. */
int scm_arity_check(proc, argc, what)
     SCM proc;
     long argc;
     char *what;
{
  SCM p = proc;
  if (IMP(p))
    return 0;
 cclo_tail:
  switch TYP7(p) {
  default:
  badproc:
    if (what) wta(proc, (char *)ARG1, what);
    return 0;
 wrongnumargs:
  if (what) wta(proc, (char *)WNA, what);
  return 0;
  case tc7_subr_0: ASRTGO(0==argc, wrongnumargs) return !0;
  case tc7_cxr:
  case tc7_contin:
  case tc7_subr_1: ASRTGO(1==argc, wrongnumargs) return !0;
  case tc7_subr_1o: ASRTGO(0==argc || 1==argc, wrongnumargs) return !0;
  case tc7_subr_2: ASRTGO(2==argc, wrongnumargs) return !0;
  case tc7_subr_2o: ASRTGO( 1==argc || 2==argc, wrongnumargs) return !0;
  case tc7_subr_3: ASRTGO(3==argc, wrongnumargs) return !0;
  case tc7_rpsubr:
  case tc7_asubr:
  case tc7_lsubr: return !0;
  case tc7_lsubr_2: ASRTGO(2<=argc, wrongnumargs) return !0;
  case tc7_specfun:
    switch TYP16(proc) {
    case tc16_apply: ASRTGO(2<=argc, wrongnumargs) return !0;
    case tc16_call_cc:
    case tc16_eval: ASRTGO(1==argc, wrongnumargs) return !0;
# ifdef CCLO
    case tc16_cclo:
      p = CCLO_SUBR(p);
      argc++;
      goto cclo_tail;
# endif
    }
  case tcs_closures:
    {
      SCM formals = CAR(CODE(p));
      while (argc--) {
	if IMP(formals) goto wrongnumargs;
	if (CONSP(formals))
	  formals = CDR(formals);
	else
	  return !0;
      }
      ASRTGO(IMP(formals) || NCONSP(formals), wrongnumargs);
    }
  }
}
#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;
  if (NIMP(scm_env) && ENVP(scm_env))
    return scm_env;
  CDR(z) = scm_env;
  CAR(z) = tc16_env;
  EGC_ROOT(z);
  return z;
}

SCM ceval(x, env)
     SCM x, env;
{
  ENV_PUSH;
#ifdef CAUTIOUS
  scm_trace = UNSPECIFIED;
#endif
  TRACE(x);
  scm_env = env;
  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. */
#ifdef CAUTIOUS
  SCM xorig;
#endif
  CHECK_STACK;
 loop: POLL;
#ifdef CAUTIOUS
  xorig = x;
#endif
#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);
    }
    else if ATOMP(CAR(x))
      x = evalatomcar(x);
    else {
      x = CAR(x);
      goto loop;			/* tail recurse */
    }
 retx:
    ENV_MAY_POP(envpp, 0);
    ALLOW_INTS_EGC;
    return x;

  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);
      }
    }
    x = UNSPECIFIED;
    goto retx;
  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;
      }
    }
    x = UNSPECIFIED;
    goto retx;
  case (127 & IM_DO):
    ENV_MAY_PUSH(envpp);
    TRACE(x);
    x = CDR(x);
    ecache_evalx(CAR(CDR(x)));	/* inits */
    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);
      }
      ecache_evalx(CDR(CDR(x))); /* steps */
      t.arg1 = CAR(CAR(scm_env));
      scm_env = CDR(scm_env);
      EXTEND_ENV(t.arg1);
    }
    x = CDR(proc);
    if NULLP(x) {x = UNSPECIFIED; goto retx;}
    goto begin;
  case (127 & IM_IF):
    x = CDR(x);
    if NFALSEP(EVALCAR(x)) x = CDR(x);
    else if IMP(x = CDR(CDR(x))) {x = UNSPECIFIED; goto retx;}
    goto carloop;
  case (127 & IM_LET):
    ENV_MAY_PUSH(envpp);
    TRACE(x);
    x = CDR(x);
    ecache_evalx(CAR(CDR(x)));
    EXTEND_ENV(CAR(x));
    x = CDR(x);
    goto cdrxbegin;
  case (127 & IM_LETREC):
    ENV_MAY_PUSH(envpp);
    TRACE(x);
    x = CDR(x);
    scm_env_tmp = undefineds;
    EXTEND_ENV(CAR(x));
    x = CDR(x);
    ecache_evalx(CAR(x));
    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);
    TRACE(x);
    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 ECONSP(proc)
	if ISYMP(CAR(proc)) *farlookup(proc) = arg2;
	else {
	  x = scm_multi_set(proc, arg2);
	  goto retx;
	}
      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;
#else
    x = UNSPECIFIED;
#endif
    goto retx;
  case (127 & IM_DEFINE):	/* only for internal defines */
    goto badfun;
	/* 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)):
      x = CDR(x);
      proc = evalcar(x);
      ASRTGO(NIMP(proc), badfun);
      t.arg1 = evalcar(CDR(x));
      if (CLOSUREP(proc)) {
	ENV_MAY_PUSH(envpp);
	TRACE(x);
	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:
#ifdef CAUTIOUS
    scm_trace = UNDEFINED;
#endif
    everr(x, wrapenv(), proc, s_wtap, "");
  case tc7_vector:
  case tcs_uves:
  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)) {
      TOP_TRACE(x);
#ifdef MEMOIZE_LOCALS
      x = macroexp1(x, UNDEFINED);
      goto loop;
#else
      proc = *lookupcar(x, 0);
      if (NIMP(proc) && MACROP(proc)) {
	x = macroexp1(x, UNDEFINED);
	goto loop;
      }
#endif
    }
    else 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[0] = scm_env; /* For error reporting at wrongnumargs. */
  if NULLP(CDR(x)) {
  evap0:
    ENV_MAY_POP(envpp, CLOSUREP(proc));
    TOP_TRACE(xorig);
    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));
      TRACE(CDR(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[0];
      }
      TOP_TRACE(UNDEFINED);
      everr(x, wrapenv(), 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));
    TOP_TRACE(xorig);
    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, SNAME(proc));
    }
#endif
    {
      int op = CXR_OP(proc);
#ifndef RECKLESS
      x = t.arg1;
#endif
      while (op) {
	ASSERT(NIMP(t.arg1) && CONSP(t.arg1),
	       x, ARG1, SNAME(proc));
	t.arg1 = (1 & op ? CAR(t.arg1) : CDR(t.arg1));
	op >>= 2;
      }
      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(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
#ifdef CHEAP_CONTINUATIONS
	  envpp = 0;
#endif
	  goto retx;
	}
	ASRTGO(NIMP(proc), badfun);
	goto evap1;
      case tc16_eval:
	ENV_MAY_PUSH(envpp);
	TRACE(x);
	scm_env = EOL;
	x = cons(copytree(t.arg1), EOL);
	goto begin;
#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));
      TOP_TRACE(xorig);
      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 = x;
	  x = copy_list(CDR(x), 0);
#ifndef RECKLESS
	  if UNBNDP(x) {x = arg3; goto badlst;}
#endif
	  arg3 = CAR(arg3);
	  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) {
	if (CLOSUREP(proc) && 3==ARGC(proc)) {
	  ENV_MAY_PUSH(envpp);
	  if (ecache_eval_args(proc, t.arg1, arg2, arg3, x))
	    goto clo_unchecked;
	  goto umwrongnumargs;
	}
	x = eval_args(x);
      }
    evap3:
      ENV_MAY_POP(envpp, CLOSUREP(proc));
      TOP_TRACE(xorig);
      ALLOW_INTS_EGC;
      switch TYP7(proc) {
      case tc7_subr_3:
	ASRTGO(NULLP(x), wrongnumargs);
	return SUBRF(proc)(t.arg1, arg2, arg3);
      case tc7_asubr:
      case tc7_rpsubr:
	return asubr_apply(proc, t.arg1, arg2, arg3, x);
	/* 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.  If LST is not a proper list of length at least
   MINLEN, returns UNDEFINED */
SCM copy_list(lst, minlen)
     SCM lst;
     int minlen;
{
  SCM res, *lloc = &res;
  res = EOL;
  for(; NIMP(lst) && CONSP(lst); lst = CDR(lst)) {
    *lloc = cons(CAR(lst), EOL);
    lloc = &CDR(*lloc);
    minlen--;
  }
  if (NULLP(lst) && minlen <= 0)
    return res;
  return UNDEFINED;
}
SCM scm_v2lst(n, v)
     long n;
     SCM *v;
{
  SCM res = EOL;
  for(n--; n >= 0; n--) res = cons(v[n], res);
  return res;
}
static SCM f_apply_closure;
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
    args = nconc2copy(args);
 cc_tail:
  ALLOW_INTS_EGC;
  switch TYP7(proc) {
  default:
  badproc:
    wta(proc, (char *)ARG1, s_apply);
  wrongnumargs:
    wta(proc, (char *)WNA, s_apply);
  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
    {
      int op = CXR_OP(proc);
#ifndef RECKLESS
      args = arg1;
#endif
      while (op) {
	ASSERT(NIMP(arg1) && CONSP(arg1),
	       args, ARG1, SNAME(proc));
	arg1 = (1 & op ? CAR(arg1) : CDR(arg1));
	op >>= 2;
      }
      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
    ENV_PUSH;
    PUSH_TRACE;
    scm_env_tmp = arg1;
    scm_env = ENV(proc);
    proc = CODE(proc);
    EXTEND_ENV(CAR(proc));
    proc = CDR(proc);
    while NNULLP(proc) {
      if (IMP(CAR(proc)) && ISYMP(CAR(proc))) {
        proc = m_expand_body(proc);
        continue;
      }
      arg1 = EVALCAR(proc);
      proc = CDR(proc);
    }
    ENV_POP;
    ALLOW_INTS_EGC;
    return arg1;
  case tc7_contin:
    ASRTGO(NULLP(args), wrongnumargs);
    scm_dynthrow(proc, arg1);
  case tc7_specfun:
    args = UNBNDP(arg1) ? EOL : cons(arg1, args);
    arg1 = proc;
#ifdef CCLO
    proc = (TYP16(proc)==tc16_cclo ? CCLO_SUBR(proc) : f_apply_closure);
#else
    proc = f_apply_closure;
#endif
    goto cc_tail;
  }
}

/* This function does not check that proc is a procedure, nor the
   number of arguments, call scm_arity_check to do that. */
SCM scm_cvapply(proc, n, argv)
     SCM proc, *argv;
     long n;
{
  SCM res;
  long i;
 tail:
  ALLOW_INTS_EGC;
  switch TYP7(proc) {
  default: return UNSPECIFIED;
  case tc7_subr_2o:
    if (1==n) return SUBRF(proc)(argv[0], UNDEFINED);
    /* Fall through */
  case tc7_subr_2:
    return SUBRF(proc)(argv[0], argv[1]);
  case tc7_subr_0:
  subr0:
    return SUBRF(proc)();
  case tc7_subr_1o:
    if (0==n) return SUBRF(proc)(UNDEFINED);
    /* Fall through */
  case tc7_subr_1:
    return SUBRF(proc)(argv[0]);
  case tc7_cxr:
#ifdef FLOATS
    if SUBRF(proc) {
      if INUMP(argv[0])
	return makdbl(DSUBRF(proc)((double) INUM(argv[0])), 0.0);
      ASRTGO(NIMP(argv[0]), floerr);
      if REALP(argv[0])
	return makdbl(DSUBRF(proc)(REALPART(argv[0])), 0.0);
# ifdef BIGDIG
      if BIGP(argv[0])
	return makdbl(DSUBRF(proc)(big2dbl(argv[0])), 0.0);
# endif
    floerr:
      wta(argv[0], (char *)ARG1, CHARS(SNAME(proc)));
    }
#endif
    {
      int op = CXR_OP(proc);
      res = argv[0];
      while (op) {
	ASSERT(NIMP(res) && CONSP(res),
	       argv[0], ARG1, SNAME(proc));
	res = (1 & op ? CAR(res) : CDR(res));
	op >>= 2;
      }
      return res;
    }
  case tc7_subr_3:
    return SUBRF(proc)(argv[0], argv[1], argv[2]);
  case tc7_lsubr:
    return SUBRF(proc)(0==n ? EOL : scm_v2lst(n, argv));
  case tc7_lsubr_2:
    return SUBRF(proc)(argv[0], argv[1],
		       2==n ? EOL : scm_v2lst(n-2, &argv[2]));
  case tc7_asubr:
    if (1 >= n) return SUBRF(proc)(0==n ? UNDEFINED : argv[0], UNDEFINED);
    res = argv[0];
    for (i = 1; i < n; i++)
      res = SUBRF(proc)(res, argv[i]);
    return res;
  case tc7_rpsubr:
    if (1 >= n) return BOOL_T;
    for (i = 0; i < n-1; i++)
      if FALSEP(SUBRF(proc)(argv[i], argv[i+1])) return BOOL_F;
    return BOOL_T;
  case tcs_closures:
    ENV_PUSH;
    PUSH_TRACE;
    i = ARGC(proc);
    if (3==i) {
      scm_env_tmp = EOL;
      scm_env_v2lst((int)n, argv);
    }
    else {
      scm_env_tmp = (i < n) ? scm_v2lst(n-i, &argv[i]) : EOL;
      if (i>0)
	scm_env_v2lst((int)i, argv);
    }
    scm_env = ENV(proc);
    proc = CODE(proc);
    EXTEND_ENV(CAR(proc));
    proc = CDR(proc);
    while NNULLP(proc) {
      if (IMP(CAR(proc)) && ISYMP(CAR(proc))) {
        proc = m_expand_body(proc);
        continue;
      }
      res = EVALCAR(proc);
      proc = CDR(proc);
    }
    ENV_POP;
    ALLOW_INTS_EGC;
    return res;
  case tc7_contin:
    scm_dynthrow(proc, argv[0]);
  case tc7_specfun:
    if (tc16_apply==TYP16(proc)) {
      proc = argv[0];
      argv++;
      n--;
#ifndef RECKLESS
      scm_arity_check(proc, n, s_apply);
#endif
      goto tail;
    }
    res = cons(proc, 0==n ? EOL : scm_v2lst(n, argv));
#ifdef CCLO
    proc = (TYP16(proc)==tc16_cclo ? CCLO_SUBR(proc) : f_apply_closure);
#else
    proc = f_apply_closure;
#endif
    return apply(proc, res, EOL);
  }
}

SCM map(proc, arg1, args)
     SCM proc, arg1, args;
{
  SCM res = EOL, *pres = &res;
  SCM heap_ve, auto_ve[5], auto_ave[5];
  SCM *ve = auto_ve, *ave = auto_ave;
  long i, n = ilength(args) + 1;
  scm_protect_temp(&heap_ve);  /* Keep heap_ve from being optimized away. */
  if NULLP(arg1) return res;
#ifdef CAUTIOUS
  ENV_PUSH;
  PUSH_TRACE;
#endif
#ifndef RECKLESS
  scm_arity_check(proc, n, s_map);
#endif
  ASSERT(NIMP(arg1), arg1, ARG2, s_map);
#ifdef CCLO
  if (tc16_cclo==TYP16(proc)) {
    args = cons(arg1, args);
    arg1 = cons(proc, EOL);
    SETCDR(arg1, arg1);		/* circular list */
    proc = CCLO_SUBR(proc);
    n++;
  }
#endif
  if (n > 5) {
    heap_ve = make_vector(MAKINUM(2*n), BOOL_F);
    ve = VELTS(heap_ve);
    ave = &(ve[n]);
  }
  ve[0] = arg1;
  ASSERT(NIMP(ve[0]) && CONSP(ve[0]), arg1, ARG2, s_map);
  for (i = 1; i < n; i++) {
    ve[i] = CAR(args);
    ASSERT(NIMP(ve[i]) && CONSP(ve[i]), args, ARGn, s_map);
    args = CDR(args);
  }
  while (1) {
    arg1 = EOL;
    for (i = n-1;i >= 0;i--) {
      if IMP(ve[i]) {
#ifdef CAUTIOUS
	ENV_POP;
#endif
	return res;
      }
      ave[i] = CAR(ve[i]);
      ve[i] = CDR(ve[i]);
    }
    *pres = cons(scm_cvapply(proc, n, ave), EOL);
    pres = &CDR(*pres);
  }
}
SCM for_each(proc, arg1, args)
     SCM proc, arg1, args;
{
  SCM heap_ve, auto_ve[5], auto_ave[5];
  SCM *ve = auto_ve, *ave = auto_ave;
  long i, n = ilength(args) + 1;
  scm_protect_temp(&heap_ve);  /* Keep heap_ve from being optimized away. */
  if NULLP(arg1) return UNSPECIFIED;
#ifdef CAUTIOUS
  ENV_PUSH;
  PUSH_TRACE;
#endif
#ifndef RECKLESS
  scm_arity_check(proc, n, s_map);
#endif
  ASSERT(NIMP(arg1), arg1, ARG2, s_for_each);
#ifdef CCLO
  if (tc16_cclo==TYP16(proc)) {
    args = cons(arg1, args);
    arg1 = cons(proc, EOL);
    SETCDR(arg1, arg1);		/* circular list */
    proc = CCLO_SUBR(proc);
    n++;
  }
#endif
  if (n > 5) {
    heap_ve = make_vector(MAKINUM(2*n), BOOL_F);
    ve = VELTS(heap_ve);
    ave = &(ve[n]);
  }
  ve[0] = arg1;
  ASSERT(NIMP(ve[0]) && CONSP(ve[0]), arg1, ARG2, s_for_each);
  for (i = 1; i < n; i++) {
    ve[i] = CAR(args);
    ASSERT(NIMP(ve[i]) && CONSP(ve[i]), args, ARGn, s_for_each);
    args = CDR(args);
  }
  while (1) {
    arg1 = EOL;
    for (i = n-1;i >= 0;i--) {
      if IMP(ve[i]) {
#ifdef CAUTIOUS
	ENV_POP;
#endif
	return UNSPECIFIED;
      }
      ave[i] = CAR(ve[i]);
      ve[i] = CDR(ve[i]);
    }
    scm_cvapply(proc, n, ave);
  }
}

/* The number of required arguments up to 3 is encoded in the cdr of the
   closure.  A value 3 means no rest argument, 3 or more required arguments.
   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;
	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;
}

static char s_makacro[] = "procedure->syntax";
SCM makacro(code)
     SCM code;
{
	register SCM z;
	ASSERT(scm_arity_check(code, 2L, (char *)0), code, ARG1, s_makacro);
	NEWCELL(z);
	CDR(z) = code;
	CAR(z) = tc16_macro;
	return z;
}
static char s_makmacro[] = "procedure->macro";
SCM makmacro(code)
     SCM code;
{
	register SCM z;
	ASSERT(scm_arity_check(code, 2L, (char *)0), code, ARG1, s_makmacro);
	NEWCELL(z);
	CDR(z) = code;
	CAR(z) = tc16_macro | (1L<<16);
	return z;
}
static char s_makmmacro[] = "procedure->memoizing-macro";
SCM makmmacro(code)
     SCM code;
{
	register SCM z;
	ASSERT(scm_arity_check(code, 2L, (char *)0), code, ARG1, s_makmmacro);
	NEWCELL(z);
	CDR(z) = code;
	CAR(z) = tc16_macro | (2L<<16);
	return z;
}
#ifdef MACRO
/* Functions for (eventual) smart expansion */
static char s_macroexpand1[] = "@macroexpand1";
SCM scm_macroexpand1(x, env)
     SCM x, env;
{
  SCM res, proc;
  if (IMP(x) || NCONSP(x)) return x;
  res = CAR(x);
  if (IMP(res) || !IDENTP(res)) return x;
  ENV_PUSH;
  PUSH_TRACE;
  if (NULLP(env))
    scm_env = env;
  else {
    ASSERT(NIMP(env) && ENVP(env), env, ARG2, s_macroexpand1);
    scm_env = CDR(env);
  }
  proc = *lookupcar(x, 0);
  ENV_POP;
  ALLOW_INTS_EGC;
  if (NIMP(proc) && MACROP(proc)) {
    SCM argv[2];
    switch ((int)(CAR(proc)>>16) & 0x7f) {
    default: return x;		/* Primitive macro invocation. */
    case 2: case 1:
      argv[0] = x;
      argv[1] = env;
      res = scm_cvapply(CDR(proc), 2L, argv);
      if (res==x) return cons(CAR(x), CDR(x));
      return res;
    case 0: case 4:		/* Acros, primitive or not. */
      argv[0] = x;
      argv[1] = env;
      return cons2(TOPRENAME(i_quote),
		   scm_cvapply(CDR(proc), 2L, argv),
		   EOL);
    }
  }
  return x;
}
static char s_env_ref[] = "environment-ref";
SCM scm_env_ref(env, ident)
     SCM env, ident;
{
  SCM *p, ret;
  if NULLP(env) return BOOL_F;
  ASSERT(NIMP(env) && ENVP(env), env, ARG1, s_env_ref);
  ASSERT(NIMP(ident) && IDENTP(ident), ident, ARG2, s_env_ref);
  ENV_PUSH;
  PUSH_TRACE;
  scm_env = CDR(env);
  p = id_denote(ident);
  ret = p ? *p : BOOL_F;
  ENV_POP;
  ALLOW_INTS_EGC;
  return ret;
}
static char s_extended_env[] = "extended-environment";
SCM scm_extended_env(names, vals, env)
     SCM names, vals, env;
{
  SCM z, nenv;
# ifndef RECKLESS
  SCM v = vals;
  z = names;
  for (z = names; NIMP(z) && CONSP(z); z = CDR(z)) {
    ASSERT(NIMP(v) && CONSP(v), vals, ARG2, s_extended_env);
    v = CDR(v);
  }
  ASSERT(NNULLP(z) || NULLP(v), vals, ARG2, s_extended_env);
# endif
  nenv = acons(names, vals, env2tree(env));
  NEWCELL(z);
  CDR(z) = nenv;
  CAR(z) = tc16_env | (1L << 16);
  return z;
}
static char s_eval_syntax[] = "eval-syntax";
SCM scm_eval_syntax(x, env)
     SCM x, env;
{
  ASSERT(IMP(env) ? NULLP(env) : ENVP(env), env, ARG2, s_eval_syntax);
  return EVAL(x, env);
}
#endif /* MACRO */

static int prinmacro(exp, port, writing)
     SCM exp;
     SCM port;
     int writing;
{
  if (CAR(exp) & (4L<<16)) lputs("#<primitive-", port);
  else lputs("#<", port);
  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 = scm_cvapply(CDR(x), 0L, (SCM *)0);
    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;
  ENV_PUSH;
  PUSH_TRACE;
  if NULLP(env) scm_env = env;
  else {
    ASSERT(NIMP(env) && tc16_env==TYP16(env), env, ARG3, s_ident_eqp);
    scm_env = CDR(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(ENVP(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 (NIMP(env) && ENVP(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) && ENVP(env), env, ARG1, s_env2tree);
  if ((1L << 16) & CAR(env)) return CDR(env);
  if IMP(CDR(env)) return CDR(env);
  ENV_PUSH;
  PUSH_TRACE;
  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)) {
      if (undefineds==*lloc) {
        *lloc = BOOL_F;
        break;
      }
      *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;
  CDR(env) = ans;		/* Memoize migrated environment. */
  CAR(env) |= (1L << 16);
  return ans;
}

static iproc subr1s[] = {
	{"@copy-tree", copytree},
/*	{s_eval, eval}, now a (tail recursive) specfun */
	{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},
#ifdef MACRO
	{s_macroexpand1, scm_macroexpand1},
	{s_env_ref, scm_env_ref},
	{s_eval_syntax, scm_eval_syntax},
#endif
	{0, 0}};

static iproc subr3s[] = {
#ifdef MACRO
  {s_ident_eqp, ident_eqp},
  {s_extended_env, scm_extended_env},
#endif
  {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)
     const char *name;
     SCM (*macroizer)();
     SCM (*fcn)();
{
  SCM symcell = sysintern(name, UNDEFINED);
  SCM z = macroizer(scm_maksubr(name, tc7_subr_2, fcn));
  CAR(z) |= (4L << 16);         /* Flags result as primitive macro. */
  CDR(symcell) = 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);
  init_iprocs(subr3s, tc7_subr_3);
#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);
  make_specfun(s_eval, tc16_eval);

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

  f_apply_closure =
    CDR(sysintern(" apply-closure",
		  scm_evstr("(let ((ap apply)) (lambda (p . a) (ap p a)))")));

#ifdef MACRO
  tc16_ident = newsmob(&idsmob);
  make_subr(s_renamed_ident, tc7_subr_2, renamed_ident);
  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
}