/* Scheme implementation intended for JACAL.
   Copyright (C) 1990-1994 Aubrey Jaffer & Hugh E. Secker-Walker.

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 1, 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 program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

The author can be reached at jaffer@ai.mit.edu or
Aubrey Jaffer, 84 Pleasant St., Wakefield MA 01880
*/

#include "scm.h"
#include "setjump.h"

#define I_SYM(x) (CAR((x)-1L))
#define I_VAL(x) (CDR((x)-1L))

#define EVALCELLCAR(x, env) \
  SYMBOLP(CAR(x))?*scm_lookupcar(x, env):scm_ceval(CAR(x), env)

#ifdef MEMOIZE_LOCALS
#define EVALIMP(x, env) (ILOCP(x)?*scm_ilookup((x), env):x)
#else
#define EVALIMP(x, env) x
#endif
#define EVALCAR(x, env) (NCELLP(CAR(x))\
			? (IMP(CAR(x)) \
			   ? EVALIMP(CAR(x), env) \
			   : I_VAL(CAR(x))) \
			: EVALCELLCAR(x, env))

#define EXTEND_ENV scm_acons

/* this variable holds the thunk used to lookup top-level variables */
SCM scm_top_level_lookup_thunk_var;

#ifdef MEMOIZE_LOCALS
SCM *
scm_ilookup (iloc, env)
     SCM iloc, env;
{
  register int ir = IFRAME (iloc);
  register SCM er = env;
  for (; 0 != ir; --ir)
    er = CDR (er);
  er = CAR (er);
  for (ir = IDIST (iloc); 0 != ir; --ir)
    er = CDR (er);
  if (ICDRP (iloc))
    return &CDR (er);
  return &CAR (CDR (er));
}
#endif
SCM *
scm_lookupcar (vloc, genv)
     SCM vloc, genv;
{
  SCM env = genv;
  register SCM *al, fl, var = CAR (vloc);
#ifdef MEMOIZE_LOCALS
  register SCM iloc = ILOC00;
#endif
  for (; NIMP (env); env = CDR (env))
    {
      if (BOOL_T == scm_procedurep (CAR (env)))
	break;
      al = &CAR (env);
      for (fl = CAR (*al); NIMP (fl); fl = CDR (fl))
	{
	  if (NCONSP (fl))
	      if (fl == var)
	      {
#ifdef MEMOIZE_LOCALS
		CAR (vloc) = iloc + ICDR;
#endif
		return &CDR (*al);
	      }
	    else
	      break;
	  al = &CDR (*al);
	  if (CAR (fl) == var)
	    {
#ifdef MEMOIZE_LOCALS
#ifndef RECKLESS		/* letrec inits to SCM_UNDEFINED */
	      if (UNBNDP (CAR (*al)))
		{
		  env = EOL;
		  goto errout;
		}
#endif
	      CAR (vloc) = iloc;
#endif
	      return &CAR (*al);
	    }
#ifdef MEMOIZE_LOCALS
	  iloc += IDINC;
#endif
	}
#ifdef MEMOIZE_LOCALS
      iloc = (~IDSTMSK) & (iloc + IFRINC);
#endif
    }
  {
    SCM top_thunk, vcell;
    if (NIMP(env))
      {
	top_thunk = CAR(env);	/* env now refers to a top level env thunk */
	env = CDR (env);
      }
    else
      top_thunk = BOOL_F;
    vcell = scm_sym2vcell (var, top_thunk, BOOL_F);
    if (vcell == BOOL_F)
      goto errout;
    else
      var = vcell;
  }
#ifndef RECKLESS
  if (NNULLP (env) || UNBNDP (CDR (var)))
    {
      var = CAR (var);
    errout:
      scm_everr (vloc, genv, var,
		 (NULLP (env)
		  ? "unbound variable: "
		  : "damaged environment"),
		 "");
    }
#endif
  CAR (vloc) = var + 1;
  return &CDR (var);
}
static SCM 
unmemocar (form, env)
     SCM form, env;
{
  register int ir;
  if (IMP (form))
    return form;
  if (1 == TYP3 (form))
    CAR (form) = I_SYM (CAR (form));
#ifdef MEMOIZE_LOCALS
  else if (ILOCP (form))
    {
      for (ir = IFRAME (CAR (form)); ir != 0; --ir)
	env = CDR (env);
      env = CAR (CAR (env));
      for (ir = IDIST (CAR (form)); ir != 0; --ir)
	env = CDR (env);
      CAR (form) = ICDRP (CAR (form)) ? env : CAR (env);
    }
#endif
  return form;
}

SCM 
scm_eval_args (l, env)
     SCM l, env;
{
  SCM res = EOL, *lloc = &res;
  while (NIMP (l))
    {
      *lloc = scm_cons (EVALCAR (l, env), EOL);
      lloc = &CDR (*lloc);
      l = CDR (l);
    }
  return res;
}

/* 
 * The following rewrite expressions and
 * some memoized forms have different syntax 
 */

static char s_expression[] = "missing or extra expression";
static char s_test[] = "bad test";
static char s_body[] = "bad body";
static char s_bindings[] = "bad bindings";
static char s_variable[] = "bad variable";
static char s_clauses[] = "bad or missing clauses";
static char s_formals[] = "bad formals";
#define ASSYNT(_cond, _arg, _pos, _subr) if(!(_cond))scm_wta(_arg, (char *)_pos, _subr);

SCM scm_i_dot, scm_i_quote, scm_i_quasiquote, scm_i_lambda, scm_i_let,
  scm_i_arrow, scm_i_else, scm_i_unquote, scm_i_uq_splicing, scm_i_apply;
static char s_quasiquote[] = "quasiquote";
static char s_delay[] = "delay";

#define ASRTSYNTAX(cond_, msg_) if(!(cond_))scm_wta(xorig, (msg_), what);

static void 
bodycheck (xorig, bodyloc, what)
     SCM xorig, *bodyloc;
     char *what;
{
  ASRTSYNTAX (scm_ilength (*bodyloc) >= 1, s_expression);
}

SCM 
scm_m_quote (xorig, env)
     SCM xorig, env;
{
  ASSYNT (scm_ilength (CDR (xorig)) == 1, xorig, s_expression, s_quote);
  return scm_cons (IM_QUOTE, CDR (xorig));
}

SCM 
scm_m_begin (xorig, env)
     SCM xorig, env;
{
  ASSYNT (scm_ilength (CDR (xorig)) >= 1, xorig, s_expression, s_begin);
  return scm_cons (IM_BEGIN, CDR (xorig));
}

SCM 
scm_m_if (xorig, env)
     SCM xorig, env;
{
  int len = scm_ilength (CDR (xorig));
  ASSYNT (len >= 2 && len <= 3, xorig, s_expression, s_if);
  return scm_cons (IM_IF, CDR (xorig));
}

SCM 
scm_m_set (xorig, env)
     SCM xorig, env;
{
  SCM x = CDR (xorig);
  ASSYNT (2 == scm_ilength (x), xorig, s_expression, s_set);
  ASSYNT (NIMP (CAR (x)) && SYMBOLP (CAR (x)),
	  xorig, s_variable, s_set);
  return scm_cons (IM_SET, x);
}

#if 0
SCM 
scm_m_vref (xorig, env)
     SCM xorig, env;
{
  SCM x = CDR (xorig);
  ASSYNT (1 == scm_ilength (x), xorig, s_expression, s_vref);
  if (NIMP(x) && UDVARIABLEP (CAR (x)))
    {
      scm_everr (SCM_UNDEFINED, env, CAR(CDR(x)), s_variable,
		 "global variable reference");
    }
  ASSYNT (NIMP(x) && DEFVARIABLEP (CAR (x)),
	  xorig, s_variable, s_vref);
  return 
  return scm_cons (IM_VREF, x);
}

SCM 
scm_m_vset (xorig, env)
     SCM xorig, env;
{
  SCM x = CDR (xorig);
  ASSYNT (3 == scm_ilength (x), xorig, s_expression, s_vset);
  ASSYNT ((   DEFVARIABLEP (CAR (x))
	   || UDVARIABLEP (CAR (x))),
	  xorig, s_variable, s_vset);
  return scm_cons (IM_VSET, x);
}
#endif 

SCM 
scm_m_and (xorig, env)
     SCM xorig, env;
{
  int len = scm_ilength (CDR (xorig));
  ASSYNT (len >= 0, xorig, s_test, s_and);
  if (len >= 1)
    return scm_cons (IM_AND, CDR (xorig));
  else
    return BOOL_T;
}

SCM 
scm_m_or (xorig, env)
     SCM xorig, env;
{
  int len = scm_ilength (CDR (xorig));
  ASSYNT (len >= 0, xorig, s_test, s_or);
  if (len >= 1)
    return scm_cons (IM_OR, CDR (xorig));
  else
    return BOOL_F;
}

SCM 
scm_m_case (xorig, env)
     SCM xorig, env;
{
  SCM proc, x = CDR (xorig);
  ASSYNT (scm_ilength (x) >= 2, xorig, s_clauses, s_case);
  while (NIMP (x = CDR (x)))
    {
      proc = CAR (x);
      ASSYNT (scm_ilength (proc) >= 2, xorig, s_clauses, s_case);
      ASSYNT (scm_ilength (CAR (proc)) >= 0 || scm_i_else == CAR (proc),
	      xorig, s_clauses, s_case);
    }
  return scm_cons (IM_CASE, CDR (xorig));
}

SCM 
scm_m_cond (xorig, env)
     SCM xorig, env;
{
  SCM arg1, x = CDR (xorig);
  int len = scm_ilength (x);
  ASSYNT (len >= 1, xorig, s_clauses, s_cond);
  while (NIMP (x))
    {
      arg1 = CAR (x);
      len = scm_ilength (arg1);
      ASSYNT (len >= 1, xorig, s_clauses, s_cond);
      if (scm_i_else == CAR (arg1))
	{
	  ASSYNT (NULLP (CDR (x)) && len >= 2, xorig, "bad ELSE clause", s_cond);
	  CAR (arg1) = BOOL_T;
	}
      if (len >= 2 && scm_i_arrow == CAR (CDR (arg1)))
	ASSYNT (3 == len && NIMP (CAR (CDR (CDR (arg1)))),
		xorig, "bad recipient", s_cond);
      x = CDR (x);
    }
  return scm_cons (IM_COND, CDR (xorig));
}

SCM 
scm_m_lambda (xorig, env)
     SCM xorig, env;
{
  SCM proc, x = CDR (xorig);
  if (scm_ilength (x) < 2)
    goto badforms;
  proc = CAR (x);
  if NULLP
    (proc) goto memlambda;
  if IMP
    (proc) goto badforms;
  if SYMBOLP
    (proc) goto memlambda;
  if NCONSP
    (proc) goto badforms;
  while NIMP
    (proc)
    {
      if NCONSP
	(proc)
	  if (!SYMBOLP (proc))
	  goto badforms;
	else
	  goto memlambda;
      if (!(NIMP (CAR (proc)) && SYMBOLP (CAR (proc))))
	goto badforms;
      proc = CDR (proc);
    }
  if NNULLP
    (proc)
  badforms:scm_wta (xorig, s_formals, s_lambda);
memlambda:
  bodycheck (xorig, &CDR (x), s_lambda);
  return scm_cons (IM_LAMBDA, CDR (xorig));
}
SCM 
scm_m_letstar (xorig, env)
     SCM xorig, env;
{
  SCM x = CDR (xorig), arg1, proc, vars = EOL, *varloc = &vars;
  int len = scm_ilength (x);
  ASSYNT (len >= 2, xorig, s_body, s_letstar);
  proc = CAR (x);
  ASSYNT (scm_ilength (proc) >= 0, xorig, s_bindings, s_letstar);
  while NIMP
    (proc)
    {
      arg1 = CAR (proc);
      ASSYNT (2 == scm_ilength (arg1), xorig, s_bindings, s_letstar);
      ASSYNT (NIMP (CAR (arg1)) && SYMBOLP (CAR (arg1)), xorig, s_variable, s_letstar);
      *varloc = scm_cons2 (CAR (arg1), CAR (CDR (arg1)), EOL);
      varloc = &CDR (CDR (*varloc));
      proc = CDR (proc);
    }
  x = scm_cons (vars, CDR (x));
  bodycheck (xorig, &CDR (x), s_letstar);
  return scm_cons (IM_LETSTAR, x);
}

/* DO gets the most radically altered syntax
   (do ((<var1> <init1> <step1>)
   (<var2> <init2>)
   ... )
   (<test> <return>)
   <body>)
   ;; becomes
   (do_mem (varn ... var2 var1)
   (<init1> <init2> ... <initn>)
   (<test> <return>)
   (<body>)
   <step1> <step2> ... <stepn>) ;; missing steps replaced by var
   */
SCM 
scm_m_do (xorig, env)
     SCM xorig, env;
{
  SCM x = CDR (xorig), arg1, proc;
  SCM vars = EOL, inits = EOL, steps = EOL;
  SCM *initloc = &inits, *steploc = &steps;
  int len = scm_ilength (x);
  ASSYNT (len >= 2, xorig, s_test, s_do);
  proc = CAR (x);
  ASSYNT (scm_ilength (proc) >= 0, xorig, s_bindings, s_do);
  while NIMP
    (proc)
    {
      arg1 = CAR (proc);
      len = scm_ilength (arg1);
      ASSYNT (2 == len || 3 == len, xorig, s_bindings, s_do);
      ASSYNT (NIMP (CAR (arg1)) && SYMBOLP (CAR (arg1)), xorig, s_variable, s_do);
      /* vars reversed here, inits and steps reversed at evaluation */
      vars = scm_cons (CAR (arg1), vars);	/* variable */
      arg1 = CDR (arg1);
      *initloc = scm_cons (CAR (arg1), EOL);	/* init */
      initloc = &CDR (*initloc);
      arg1 = CDR (arg1);
      *steploc = scm_cons (IMP (arg1) ? CAR (vars) : CAR (arg1), EOL);	/* step */
      steploc = &CDR (*steploc);
      proc = CDR (proc);
    }
  x = CDR (x);
  ASSYNT (scm_ilength (CAR (x)) >= 1, xorig, s_test, s_do);
  x = scm_cons2 (CAR (x), CDR (x), steps);
  x = scm_cons2 (vars, inits, x);
  bodycheck (xorig, &CAR (CDR (CDR (x))), s_do);
  return scm_cons (IM_DO, x);
}

/* evalcar is small version of inline EVALCAR when we don't care about speed */
static SCM 
evalcar (x, env)
     SCM x, env;
{
  return EVALCAR (x, env);
}

static SCM 
iqq (form, env, depth)
     SCM form, env;
     int depth;
{
  SCM tmp;
  int edepth = depth;
  if IMP
    (form) return form;
  if VECTORP
    (form)
    {
      long i = LENGTH (form);
      SCM *data = VELTS (form);
      tmp = EOL;
      for (; --i >= 0;)
	tmp = scm_cons (data[i], tmp);
      return scm_vector (iqq (tmp, env, depth));
    }
  if NCONSP
    (form) return form;
  tmp = CAR (form);
  if (scm_i_quasiquote == tmp)
    {
      depth++;
      goto label;
    }
  if (scm_i_unquote == tmp)
    {
      --depth;
    label:
      form = CDR (form);
      ASSERT (NIMP (form) && ECONSP (form) && NULLP (CDR (form)),
	      form, ARG1, s_quasiquote);
      if (0 == depth)
	return evalcar (form, env);
      return scm_cons2 (tmp, iqq (CAR (form), env, depth), EOL);
    }
  if (NIMP (tmp) && (scm_i_uq_splicing == CAR (tmp)))
    {
      tmp = CDR (tmp);
      if (0 == --edepth)
	return scm_append (scm_cons2 (evalcar (tmp, env), iqq (CDR (form), env, depth), EOL));
    }
  return scm_cons (iqq (CAR (form), env, edepth), iqq (CDR (form), env, depth));
}

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

SCM 
scm_m_quasiquote (xorig, env)
     SCM xorig, env;
{
  SCM x = CDR (xorig);
  ASSYNT (scm_ilength (x) == 1, xorig, s_expression, s_quasiquote);
  return iqq (CAR (x), env, 1);
}

SCM 
scm_m_delay (xorig, env)
     SCM xorig, env;
{
  ASSYNT (scm_ilength (xorig) == 2, xorig, s_expression, s_delay);
  xorig = CDR (xorig);
  return scm_makprom (scm_closure (scm_cons2 (EOL, CAR (xorig), CDR (xorig)),
				   env));
}

static SCM
env_top_level (env)
     SCM env;
{
  while (NIMP(env))
    {
      if (BOOL_T == scm_procedurep (CAR(env)))
	return CAR(env);
      env = CDR (env);
    }
  return BOOL_F;
}

extern int scm_verbose;
SCM 
scm_m_define (x, env)
     SCM x, env;
{
  SCM proc, arg1 = x;
  x = CDR (x);
  /*  ASSYNT(NULLP(env), x, "bad placement", s_define);*/
  ASSYNT (scm_ilength (x) >= 2, arg1, s_expression, s_define);
  proc = CAR (x);
  x = CDR (x);
  while (NIMP (proc) && CONSP (proc))
    {				/* nested define syntax */
      x = scm_cons (scm_cons2 (scm_i_lambda, CDR (proc), x), EOL);
      proc = CAR (proc);
    }
  ASSYNT (NIMP (proc) && SYMBOLP (proc), arg1, s_variable, s_define);
  ASSYNT (1 == scm_ilength (x), arg1, s_expression, s_define);
  if (TOP_LEVEL (env))
    {
      x = evalcar (x, env);
      arg1 = scm_sym2vcell (proc, env_top_level (env), BOOL_T);
#ifndef RECKLESS
      if (NIMP (CDR (arg1)) && ((SCM) SNAME (CDR (arg1)) == proc)
	  && (CDR (arg1) != x))
	scm_warn ("redefining built-in ", CHARS (proc));
      else
#endif
      if (5 <= scm_verbose && SCM_UNDEFINED != CDR (arg1))
	scm_warn ("redefining ", CHARS (proc));
      CDR (arg1) = x;
#ifdef SICP
      return scm_cons2 (scm_i_quote, CAR (arg1), EOL);
#else
      return UNSPECIFIED;
#endif
    }
  return scm_cons2 (IM_DEFINE, proc, x);
}
/* end of acros */

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

  ASRTSYNTAX (scm_ilength (x) >= 2, s_body);
  proc = CAR (x);
  if NULLP
    (proc) return scm_m_letstar (xorig, env);	/* null binding, let* faster */
  ASRTSYNTAX (scm_ilength (proc) >= 1, s_bindings);
  do
    {
      /* vars scm_list reversed here, inits reversed at evaluation */
      arg1 = CAR (proc);
      ASRTSYNTAX (2 == scm_ilength (arg1), s_bindings);
      ASRTSYNTAX (NIMP (CAR (arg1)) && SYMBOLP (CAR (arg1)), s_variable);
      vars = scm_cons (CAR (arg1), vars);
      *initloc = scm_cons (CAR (CDR (arg1)), EOL);
      initloc = &CDR (*initloc);
    }
  while NIMP
  (proc = CDR (proc));
  cdrx = scm_cons2 (vars, inits, CDR (x));
  bodycheck (xorig, &CDR (CDR (cdrx)), what);
  return scm_cons (IM_LETREC, cdrx);
}

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

  ASSYNT (scm_ilength (x) >= 2, xorig, s_body, s_let);
  proc = CAR (x);
  if (NULLP (proc)
      || (NIMP (proc) && CONSP (proc)
	  && NIMP (CAR (proc)) && CONSP (CAR (proc)) && NULLP (CDR (proc))))
    return scm_m_letstar (xorig, env);	/* null or single binding, let* is faster */
  ASSYNT (NIMP (proc), xorig, s_bindings, s_let);
  if (CONSP (proc))			/* plain let, proc is <bindings> */
      return scm_cons (IM_LET, CDR (scm_m_letrec (xorig, env)));
  if (!SYMBOLP (proc))
    scm_wta (xorig, s_bindings, s_let);	/* bad let */
  name = proc;			/* named let, build equiv letrec */
  x = CDR (x);
  ASSYNT (scm_ilength (x) >= 2, xorig, s_body, s_let);
  proc = CAR (x);		/* bindings scm_list */
  ASSYNT (scm_ilength (proc) >= 0, xorig, s_bindings, s_let);
  while NIMP
    (proc)
    {				/* vars and inits both in order */
      arg1 = CAR (proc);
      ASSYNT (2 == scm_ilength (arg1), xorig, s_bindings, s_let);
      ASSYNT (NIMP (CAR (arg1)) && SYMBOLP (CAR (arg1)), xorig, s_variable, s_let);
      *varloc = scm_cons (CAR (arg1), EOL);
      varloc = &CDR (*varloc);
      *initloc = scm_cons (CAR (CDR (arg1)), EOL);
      initloc = &CDR (*initloc);
      proc = CDR (proc);
    }
  return
    scm_m_letrec (scm_cons2 (scm_i_let,
			     scm_cons (scm_cons2 (name, scm_cons2 (scm_i_lambda, vars, CDR (x)), EOL), EOL),
			     scm_acons (name, inits, EOL)), 	/* body */
		  env);
}

#define s_atapply (ISYMCHARS(IM_APPLY)+1)

SCM 
scm_m_apply (xorig, env)
     SCM xorig, env;
{
  ASSYNT (scm_ilength (CDR (xorig)) == 2, xorig, s_expression, s_atapply);
  return scm_cons (IM_APPLY, CDR (xorig));
}

#define s_atcall_cc (ISYMCHARS(IM_CONT)+1)

SCM 
scm_m_cont (xorig, env)
     SCM xorig, env;
{
  ASSYNT (scm_ilength (CDR (xorig)) == 1, xorig, s_expression, s_atcall_cc);
  return scm_cons (IM_CONT, CDR (xorig));
}

#ifndef RECKLESS
int 
scm_badargsp (formals, args)
     SCM formals, args;
{
  while NIMP
    (formals)
    {
      if NCONSP
	(formals) return 0;
      if IMP
	(args) return 1;
      formals = CDR (formals);
      args = CDR (args);
    }
  return NNULLP (args) ? 1 : 0;
}
#endif

char scm_s_map[] = "map", scm_s_for_each[] = "for-each" /*, s_apply[] = "apply" */ ;
SCM scm_eqv P ((SCM x, SCM y));
long scm_tc16_macro;

SCM 
scm_ceval (x, env)
     SCM x, env;
{
  union
    {
      SCM *lloc;
      SCM arg1;
    } t;
  SCM proc, arg2;
  CHECK_STACK;
loop:POLL;
  switch (TYP7 (x))
    {
    case tcs_symbols:
      /* only happens when called at top level */
      x = scm_cons (x, SCM_UNDEFINED);
      goto retval;
    case (127 & IM_AND):
      x = CDR (x);
      t.arg1 = x;
      while (NNULLP (t.arg1 = CDR (t.arg1)))
	if FALSEP (EVALCAR (x, env)) return BOOL_F;
	else
	  x = t.arg1;
      goto carloop;
    case (127 & IM_BEGIN):
    cdrxbegin:
      x = CDR (x);
    begin:
      t.arg1 = x;
      while (NNULLP (t.arg1 = CDR (t.arg1)))
	{
	  SIDEVAL (CAR (x), env);
	  x = t.arg1;
	}
    carloop:			/* scm_eval car of last form in scm_list */
      if (NCELLP (CAR (x)))
	{
	  x = CAR (x);
	  return IMP (x) ? EVALIMP (x, env) : I_VAL (x);
	}
      if (SYMBOLP (CAR (x)))
	{
	retval:
	  return *scm_lookupcar (x, env);
	}
      x = CAR (x);
      goto loop;		/* tail recurse */

    case (127 & IM_CASE):
      x = CDR (x);
      t.arg1 = EVALCAR (x, env);
      while (NIMP (x = CDR (x)))
	{
	  proc = CAR (x);
	  if (scm_i_else == CAR (proc))
	    {
	      x = CDR (proc);
	      goto begin;
	    }
	  proc = CAR (proc);
	  while (NIMP (proc))
	    {
	      if (CAR (proc) == t.arg1
#ifdef FLOATS
		  || NFALSEP (scm_eqv (CAR (proc), t.arg1))
#endif
		)
		{
		  x = CDR (CAR (x));
		  goto begin;
		}
	      proc = CDR (proc);
	    }
	}
      return UNSPECIFIED;
    case (127 & IM_COND):
      while (NIMP (x = CDR (x)))
	{
	  proc = CAR (x);
	  t.arg1 = EVALCAR (proc, env);
	  if NFALSEP
	    (t.arg1)
	    {
	      x = CDR (proc);
	      if NULLP
		(x) return t.arg1;
	      if (scm_i_arrow != CAR (x))
		goto begin;
	      proc = CDR (x);
	      proc = EVALCAR (proc, env);
	      ASRTGO (NIMP (proc), badfun);
	      goto evap1;
	    }
	}
      return UNSPECIFIED;
    case (127 & IM_DO):
      x = CDR (x);
      proc = CAR (CDR (x));	/* inits */
      t.arg1 = EOL;		/* values */
      while (NIMP (proc))
	{
	  t.arg1 = scm_cons (EVALCAR (proc, env), t.arg1);
	  proc = CDR (proc);
	}
      env = EXTEND_ENV (CAR (x), t.arg1, env);
      x = CDR (CDR (x));
      while (proc = CAR (x), FALSEP (EVALCAR (proc, env)))
	{
	  for (proc = CAR (CDR (x)); NIMP (proc); proc = CDR (proc))
	    {
	      t.arg1 = CAR (proc);	/* body */
	      SIDEVAL (t.arg1, env);
	    }
	  for (t.arg1 = EOL, proc = CDR (CDR (x)); NIMP (proc); proc = CDR (proc))
	    t.arg1 = scm_cons (EVALCAR (proc, env), t.arg1);	/* steps */
	  env = EXTEND_ENV (CAR (CAR (env)), t.arg1, CDR (env));
	}
      x = CDR (proc);
      if NULLP (x)
	return UNSPECIFIED;
      goto begin;
    case (127 & IM_IF):
      x = CDR (x);
      if NFALSEP
	(EVALCAR (x, env)) x = CDR (x);
      else if IMP
	(x = CDR (CDR (x))) return UNSPECIFIED;
      goto carloop;
    case (127 & IM_LET):
      x = CDR (x);
      proc = CAR (CDR (x));
      t.arg1 = EOL;
      do
	{
	  t.arg1 = scm_cons (EVALCAR (proc, env), t.arg1);
	}
      while NIMP
      (proc = CDR (proc));
      env = EXTEND_ENV (CAR (x), t.arg1, env);
      x = CDR (x);
      goto cdrxbegin;
    case (127 & IM_LETREC):
      x = CDR (x);
      env = EXTEND_ENV (CAR (x), undefineds, env);
      x = CDR (x);
      proc = CAR (x);
      t.arg1 = EOL;
      do
	{
	  t.arg1 = scm_cons (EVALCAR (proc, env), t.arg1);
	}
      while NIMP
      (proc = CDR (proc));
      CDR (CAR (env)) = t.arg1;
      goto cdrxbegin;
    case (127 & IM_LETSTAR):
      x = CDR (x);
      proc = CAR (x);
      if IMP
	(proc)
	{
	  env = EXTEND_ENV (EOL, EOL, env);
	  goto cdrxbegin;
	}
      do
	{
	  t.arg1 = CAR (proc);
	  proc = CDR (proc);
	  env = EXTEND_ENV (t.arg1, EVALCAR (proc, env), env);
	}
      while NIMP
      (proc = CDR (proc));
      goto cdrxbegin;
    case (127 & IM_OR):
      x = CDR (x);
      t.arg1 = x;
      while (NNULLP (t.arg1 = CDR (t.arg1)))
	{
	  x = EVALCAR (x, env);
	  if NFALSEP
	    (x) return x;
	  x = t.arg1;
	}
      goto carloop;
    case (127 & IM_LAMBDA):
      return scm_closure (CDR (x), env);
    case (127 & IM_QUOTE):
      return CAR (CDR (x));
    case (127 & IM_SET):
      x = CDR (x);
      proc = CAR (x);
      switch (7 & (int) proc)
	{
	case 0:
	  t.lloc = scm_lookupcar (x, env);
	  break;
	case 1:
	  t.lloc = &I_VAL (proc);
	  break;
#ifdef MEMOIZE_LOCALS
	case 4:
	  t.lloc = scm_ilookup (proc, env);
	  break;
#endif
	}
      x = CDR (x);
      *t.lloc = EVALCAR (x, env);
#ifdef SICP
      return *t.lloc;
#else
      return UNSPECIFIED;
#endif
    case (127 & IM_DEFINE):	/* only for internal defines */
      x = CDR (x);
      proc = CAR (x);
      x = CDR (x);
      x = evalcar (x, env);
      env = CAR (env);
      DEFER_INTS;
      CAR (env) = scm_cons (proc, CAR (env));
      CDR (env) = scm_cons (x, CDR (env));
      ALLOW_INTS;
      return UNSPECIFIED;
      /* new syntactic forms go here. */
    case (127 & MAKISYM (0)):
      proc = CAR (x);
      ASRTGO (ISYMP (proc), badfun);
      switch ISYMNUM (proc)
	{
#if 0
	case (ISYMNUM (IM_VREF)):
	  {
	    SCM var;
	    var = CAR (CDR (x));
	    return CDR(var);
	  }
	case (ISYMNUM (IM_VSET)):
	  CDR (CAR ( CDR (x))) = EVALCAR( CDR ( CDR (x)), env);
	  CAR (CAR ( CDR (x))) = scm_tc16_variable;
	  return UNSPECIFIED;
#endif
	case (ISYMNUM (IM_APPLY)):
	  proc = CDR (x);
	  proc = EVALCAR (proc, env);
	  ASRTGO (NIMP (proc), badfun);
	  if (CLOSUREP (proc))
	    {
	      t.arg1 = CDR (CDR (x));
	      t.arg1 = EVALCAR (t.arg1, env);
#ifndef RECKLESS
	      if (scm_badargsp (CAR (CODE (proc)), t.arg1))
		goto wrongnumargs;
#endif
	      env = EXTEND_ENV (CAR (CODE (proc)), t.arg1, ENV (proc));
	      x = CODE (proc);
	      goto cdrxbegin;
	    }
	  proc = scm_i_apply;
	  goto evapply;
	case (ISYMNUM (IM_CONT)):
	  t.arg1 = scm_make_cont ();
	  if (setjmp (JMPBUF (t.arg1)))
	    return scm_throwval;
	  proc = CDR (x);
	  proc = evalcar (proc, env);
	  ASRTGO (NIMP (proc), badfun);
	  goto evap1;
	default:
	  goto badfun;
	}
    default:
      proc = x;
    badfun:
      scm_everr (x, env, proc, "Wrong type to apply: ", "");
    case tc7_vector:
    case tc7_bvect:
    case tc7_ivect:
    case tc7_uvect:
    case tc7_fvect:
    case tc7_dvect:
    case tc7_cvect:
    case tc7_string:
    case tc7_smob:
    case tcs_closures:
    case tcs_subrs:
      return x;
#ifdef MEMOIZE_LOCALS
    case (127 & ILOC00):
      proc = *scm_ilookup (CAR (x), env);
      ASRTGO (NIMP (proc), badfun);
#ifndef RECKLESS
#ifdef CAUTIOUS
      goto checkargs;
#endif
#endif
      break;
#endif /* ifdef MEMOIZE_LOCALS */
    case tcs_cons_gloc:
      proc = I_VAL (CAR (x));
      ASRTGO (NIMP (proc), badfun);
#ifndef RECKLESS
#ifdef CAUTIOUS
      goto checkargs;
#endif
#endif
      break;
    case tcs_cons_nimcar:
      if (SYMBOLP (CAR (x)))
	{
	  proc = *scm_lookupcar (x, env);
	  if (IMP (proc))
	    {
	      unmemocar (x, env);
	      goto badfun;
	    }
	  if (scm_tc16_macro == TYP16 (proc))
	    {
	      unmemocar (x, env);
	      t.arg1 = scm_apply (CDR (proc), x, scm_cons (env, listofnull));
	      switch ((int) (CAR (proc) >> 16))
		{
		case 2:
		  if (scm_ilength (t.arg1) <= 0)
		    t.arg1 = scm_cons2 (IM_BEGIN, t.arg1, EOL);
		  DEFER_INTS;
		  CAR (x) = CAR (t.arg1);
		  CDR (x) = CDR (t.arg1);
		  ALLOW_INTS;
		  goto loop;
		case 1:
		  if (NIMP (x = t.arg1))
		    goto loop;
		case 0:
		  return t.arg1;
		}
	    }
	}
      else
	proc = scm_ceval (CAR (x), env);
      ASRTGO (NIMP (proc), badfun);
#ifndef RECKLESS
#ifdef CAUTIOUS
    checkargs:
#endif
      if (CLOSUREP (proc))
	{
	  arg2 = CAR (CODE (proc));
	  t.arg1 = CDR (x);
	  while (NIMP (arg2))
	    {
	      if (NCONSP (arg2))
		  goto evapply;
	      if (IMP (t.arg1))
		goto umwrongnumargs;
	      arg2 = CDR (arg2);
	      t.arg1 = CDR (t.arg1);
	    }
	  if (NNULLP (t.arg1))
	    goto umwrongnumargs;
	}
#endif
    }
evapply:
  if (NULLP (CDR (x)))
    switch (TYP7 (proc))
      {				/* no arguments given */
      case tc7_subr_0:
	return SUBRF (proc) ();
      case tc7_subr_1o:
	return SUBRF (proc) (SCM_UNDEFINED);
      case tc7_lsubr:
	return SUBRF (proc) (EOL);
      case tc7_rpsubr:
	return BOOL_T;
      case tc7_asubr:
	return SUBRF (proc) (SCM_UNDEFINED, SCM_UNDEFINED);
#ifdef CCLO
      case tc7_cclo:
	t.arg1 = proc;
	proc = CCLO_SUBR (proc);
	goto evap1;
#endif
      case tcs_closures:
	x = CODE (proc);
	env = EXTEND_ENV (CAR (x), EOL, ENV (proc));
	goto cdrxbegin;
      case tc7_contin:
      case tc7_subr_1:
      case tc7_subr_2:
      case tc7_subr_2o:
      case tc7_cxr:
      case tc7_subr_3:
      case tc7_lsubr_2:
      umwrongnumargs:
	unmemocar (x, env);
      wrongnumargs:
	scm_everr (x, env, proc, (char *) WNA, "");
      default:
	goto badfun;
      }
  x = CDR (x);
#ifdef CAUTIOUS
  if (IMP (x))
    goto wrongnumargs;
#endif
  t.arg1 = EVALCAR (x, env);
  x = CDR (x);
  if (NULLP (x))
  evap1:
    switch (TYP7 (proc))
      {				/* have one argument in t.arg1 */
      case tc7_subr_2o:
	return SUBRF (proc) (t.arg1, SCM_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 scm_makdbl (DSUBRF (proc) ((double) INUM (t.arg1)),
				   0.0);
	    ASRTGO (NIMP (t.arg1), floerr);
	    if (REALP (t.arg1))
		return scm_makdbl (DSUBRF (proc) (REALPART (t.arg1)), 0.0);
#ifdef BIGDIG
	    if (BIGP (t.arg1))
		return scm_makdbl (DSUBRF (proc) (scm_big2dbl (t.arg1)), 0.0);
#endif
	  floerr:
	    scm_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, SCM_UNDEFINED);
      case tc7_lsubr:
	return SUBRF (proc) (scm_cons (t.arg1, EOL));
#ifdef CCLO
      case tc7_cclo:
	arg2 = t.arg1;
	t.arg1 = proc;
	proc = CCLO_SUBR (proc);
	goto evap2;
#endif
      case tcs_closures:
	x = CODE (proc);
	env = EXTEND_ENV (CAR (x), scm_cons (t.arg1, EOL), ENV (proc));
	goto cdrxbegin;
      case tc7_contin:
	scm_lthrow (proc, t.arg1);
      case tc7_subr_2:
      case tc7_subr_0:
      case tc7_subr_3:
      case tc7_lsubr_2:
	goto wrongnumargs;
      default:
	goto badfun;
      }
#ifdef CAUTIOUS
  if (IMP (x))
    goto wrongnumargs;
#endif
  {				/* have two or more arguments */
    arg2 = EVALCAR (x, env);
    x = CDR (x);
    if (NULLP (x))
#ifdef CCLO
    evap2:
#endif
      switch TYP7
	(proc)
	{			/* have two arguments */
	case tc7_subr_2:
	case tc7_subr_2o:
	  return SUBRF (proc) (t.arg1, arg2);
	case tc7_lsubr:
	  return SUBRF (proc) (scm_cons2 (t.arg1, arg2, EOL));
	case tc7_lsubr_2:
	  return SUBRF (proc) (t.arg1, arg2, EOL);
	case tc7_rpsubr:
	case tc7_asubr:
	  return SUBRF (proc) (t.arg1, arg2);
#ifdef CCLO
	cclon: case tc7_cclo:
	  return scm_apply (CCLO_SUBR (proc), proc,
	  scm_cons2 (t.arg1, arg2, scm_cons (scm_eval_args (x, env), EOL)));
/*    case tc7_cclo:
      x = scm_cons(arg2, scm_eval_args(x, env));
      arg2 = t.arg1;
      t.arg1 = proc;
      proc = CCLO_SUBR(proc);
      goto evap3; */
#endif
	case tc7_subr_0:
	case tc7_cxr:
	case tc7_subr_1o:
	case tc7_subr_1:
	case tc7_subr_3:
	case tc7_contin:
	  goto wrongnumargs;
	default:
	  goto badfun;
	case tcs_closures:
	  env = EXTEND_ENV (CAR (CODE (proc)), scm_cons2 (t.arg1, arg2, EOL), ENV (proc));
	  x = CODE (proc);
	  goto cdrxbegin;
	}
    switch TYP7
      (proc)
      {				/* have 3 or more arguments */
      case tc7_subr_3:
	ASRTGO (NULLP (CDR (x)), wrongnumargs);
	return SUBRF (proc) (t.arg1, arg2, EVALCAR (x, env));
      case tc7_asubr:
/*      t.arg1 = SUBRF(proc)(t.arg1, arg2);
      while NIMP(x) {
	t.arg1 = SUBRF(proc)(t.arg1, EVALCAR(x, env));
	x = CDR(x);
      }
      return t.arg1; */
      case tc7_rpsubr:
	return scm_apply (proc, t.arg1, scm_acons (arg2, scm_eval_args (x, env), EOL));
      case tc7_lsubr_2:
	return SUBRF (proc) (t.arg1, arg2, scm_eval_args (x, env));
      case tc7_lsubr:
	return SUBRF (proc) (scm_cons2 (t.arg1, arg2, scm_eval_args (x, env)));
#ifdef CCLO
      case tc7_cclo:
	goto cclon;
#endif
      case tcs_closures:
	env = EXTEND_ENV (CAR (CODE (proc)),
			  scm_cons2 (t.arg1, arg2, scm_eval_args (x, env)),
			  ENV (proc));
	x = CODE (proc);
	goto cdrxbegin;
      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 
scm_procedurep (obj)
     SCM obj;
{
  if (NIMP (obj))
    switch (TYP7 (obj))
      {
      case tcs_closures:
      case tc7_contin:
      case tcs_subrs:
#ifdef CCLO
      case tc7_cclo:
#endif
	return BOOL_T;
      default:
	return BOOL_F;
      }
  return BOOL_F;
}

static char s_proc_doc[] = "procedure-documentation";
SCM 
l_proc_doc (proc)
     SCM proc;
{
  SCM code;
  ASSERT (BOOL_T == scm_procedurep (proc) && NIMP (proc) && TYP7 (proc) != tc7_contin,
	  proc, ARG1, s_proc_doc);
  switch TYP7
    (proc)
    {
    case tcs_closures:
      code = CDR (CODE (proc));
      if (IMP (CDR (code)))
	return BOOL_F;
      code = CAR (code);
      if (IMP (code))
	return BOOL_F;
      if (STRINGP (code))
	return code;
    default:
      return BOOL_F;
/*
  case tcs_subrs:
#ifdef CCLO
  case tc7_cclo:
#endif
*/
    }
}

/* This code is for scm_apply. it is destructive on multiple args.
   This will only screw you if you do (scm_apply scm_apply '( ... )) */
SCM 
scm_nconc2last (lst)
     SCM lst;
{
  SCM *lloc = &lst;
  while (NNULLP (CDR (*lloc)))
    lloc = &CDR (*lloc);
  *lloc = CAR (*lloc);
  return lst;
}

SCM 
scm_apply (proc, arg1, args)
     SCM proc, arg1, args;
{
  ASRTGO (NIMP (proc), badproc);
  if (NULLP (args))
    if (NULLP (arg1))
      arg1 = SCM_UNDEFINED;
    else
      {
	args = CDR (arg1);
	arg1 = CAR (arg1);
      }
  else
    {
      /*		ASRTGO(NIMP(args) && CONSP(args), wrongnumargs); */
      args = scm_nconc2last (args);
    }
#ifdef CCLO
tail:
#endif
  switch (TYP7 (proc))
    {
    case tc7_subr_2o:
      args = NULLP (args) ? SCM_UNDEFINED : CAR (args);
      return SUBRF (proc) (arg1, args);
    case tc7_subr_2:
      ASRTGO (NULLP (CDR (args)), wrongnumargs);
      args = CAR (args);
      return SUBRF (proc) (arg1, args);
    case tc7_subr_0:
      ASRTGO (UNBNDP (arg1), wrongnumargs);
      return SUBRF (proc) ();
    case tc7_subr_1:
    case tc7_subr_1o:
      ASRTGO (NULLP (args), wrongnumargs);
      return SUBRF (proc) (arg1);
    case tc7_cxr:
      ASRTGO (NULLP (args), wrongnumargs);
#ifdef FLOATS
      if (SUBRF (proc))
	{
	  if INUMP
	    (arg1)
	      return scm_makdbl (DSUBRF (proc) ((double) INUM (arg1)), 0.0);
	  ASRTGO (NIMP (arg1), floerr);
	  if REALP
	    (arg1)
	      return scm_makdbl (DSUBRF (proc) (REALPART (arg1)), 0.0);
#ifdef BIGDIG
	  if BIGP
	    (arg1)
	      return scm_makdbl (DSUBRF (proc) (scm_big2dbl (arg1)), 0.0);
#endif
	floerr:
	  scm_wta (arg1, (char *) ARG1, CHARS (SNAME (proc)));
	}
#endif
      proc = (SCM) SNAME (proc);
      {
	char *chrs = CHARS (proc) + LENGTH (proc) - 1;
	while ('c' != *--chrs)
	  {
	    ASSERT (NIMP (arg1) && CONSP (arg1),
		    arg1, ARG1, CHARS (proc));
	    arg1 = ('a' == *chrs) ? CAR (arg1) : CDR (arg1);
	  }
	return arg1;
      }
    case tc7_subr_3:
      return SUBRF (proc) (arg1, CAR (args), CAR (CDR (args)));
    case tc7_lsubr:
      return SUBRF (proc) (UNBNDP (arg1) ? EOL : scm_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, SCM_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 : scm_cons (arg1, args));
#ifndef RECKLESS
      if (scm_badargsp (CAR (CODE (proc)), arg1))
	goto wrongnumargs;
#endif
      args = EXTEND_ENV (CAR (CODE (proc)), arg1, ENV (proc));
      proc = CODE (proc);
      while (NNULLP (proc = CDR (proc)))
	arg1 = EVALCAR (proc, args);
      return arg1;
    case tc7_contin:
      ASRTGO (NULLP (args), wrongnumargs);
      scm_lthrow (proc, arg1);
#ifdef CCLO
    case tc7_cclo:
      args = (UNBNDP(arg1) ? EOL : scm_cons (arg1, args));
      arg1 = proc;
      proc = CCLO_SUBR (proc);
      goto tail;
#endif
    wrongnumargs:
      scm_wta (proc, (char *) WNA, s_apply);
    default:
    badproc:
      scm_wta (proc, (char *) ARG1, s_apply);
      return arg1;
    }
}

SCM 
scm_map (proc, arg1, args)
     SCM proc, arg1, args;
{
  long i;
  SCM res = EOL, *pres = &res;
  SCM *ve = &args;		/* Keep args from being optimized away. */
  if NULLP
    (arg1) return res;
  ASSERT (NIMP (arg1), arg1, ARG2, scm_s_map);
  if NULLP
    (args)
    {
      while NIMP
	(arg1)
	{
	  ASSERT (CONSP (arg1), arg1, ARG2, scm_s_map);
	  *pres = scm_cons (scm_apply (proc, CAR (arg1), listofnull), EOL);
	  pres = &CDR (*pres);
	  arg1 = CDR (arg1);
	}
      return res;
    }
  args = scm_vector (scm_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, scm_s_map);
#endif
  while (1)
    {
      arg1 = EOL;
      for (i = LENGTH (args) - 1; i >= 0; i--)
	{
	  if IMP
	    (ve[i]) return res;
	  arg1 = scm_cons (CAR (ve[i]), arg1);
	  ve[i] = CDR (ve[i]);
	}
      *pres = scm_cons (scm_apply (proc, arg1, EOL), EOL);
      pres = &CDR (*pres);
    }
}
SCM 
scm_for_each (proc, arg1, args)
     SCM proc, arg1, args;
{
  SCM *ve = &args;		/* Keep args from being optimized away. */
  long i;
  if NULLP (arg1)
    return UNSPECIFIED;
  ASSERT (NIMP (arg1), arg1, ARG2, scm_s_for_each);
  if NULLP (args)
    {
      while NIMP (arg1)
	{
	  ASSERT (CONSP (arg1), arg1, ARG2, scm_s_for_each);
	  scm_apply (proc, CAR (arg1), listofnull);
	  arg1 = CDR (arg1);
	}
      return UNSPECIFIED;
    }
  args = scm_vector (scm_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, scm_s_for_each);
#endif
  while (1)
    {
      arg1 = EOL;
      for (i = LENGTH (args) - 1; i >= 0; i--)
	{
	  if IMP
	    (ve[i]) return UNSPECIFIED;
	  arg1 = scm_cons (CAR (ve[i]), arg1);
	  ve[i] = CDR (ve[i]);
	}
      scm_apply (proc, arg1, EOL);
    }
}

SCM 
scm_closure (code, env)
     SCM code, env;
{
  register SCM z;
  NEWCELL (z);
  SETCODE (z, code);
  ENV (z) = env;
  return z;
}

long scm_tc16_promise;
SCM 
scm_makprom (code)
     SCM code;
{
  register SCM z;
  NEWCELL (z);
  CDR (z) = code;
  CAR (z) = scm_tc16_promise;
  return z;
}
static int 
prinprom (exp, port, writing)
     SCM exp;
     SCM port;
     int writing;
{
  scm_lputs ("#<promise ", port);
  scm_iprin1 (CDR (exp), port, writing);
  scm_lputc ('>', port);
  return !0;
}

SCM 
scm_makacro (code)
     SCM code;
{
  register SCM z;
  NEWCELL (z);
  CDR (z) = code;
  CAR (z) = scm_tc16_macro;
  return z;
}
SCM 
scm_makmacro (code)
     SCM code;
{
  register SCM z;
  NEWCELL (z);
  CDR (z) = code;
  CAR (z) = scm_tc16_macro | (1L << 16);
  return z;
}
SCM 
scm_makmmacro (code)
     SCM code;
{
  register SCM z;
  NEWCELL (z);
  CDR (z) = code;
  CAR (z) = scm_tc16_macro | (2L << 16);
  return z;
}
static int 
prinmacro (exp, port, writing)
     SCM exp;
     SCM port;
     int writing;
{
  if (CAR (exp) & (3L << 16))
    scm_lputs ("#<macro", port);
  else
    scm_lputs ("#<syntax", port);
  if (CAR (exp) & (2L << 16))
    scm_lputc ('!', port);
  scm_lputc (' ', port);
  scm_iprin1 (CDR (exp), port, writing);
  scm_lputc ('>', port);
  return !0;
}

char scm_s_force[] = "force";
SCM 
scm_force (x)
     SCM x;
{
  ASSERT ((TYP16 (x) == scm_tc16_promise), x, ARG1, scm_s_force);
  if (!((1L << 16) & CAR (x)))
    {
      SCM ans = scm_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 
scm_copytree (obj)
     SCM obj;
{
  SCM ans, tl;
  if IMP
    (obj) return obj;
  if VECTORP
    (obj)
    {
      sizet i = LENGTH (obj);
      ans = scm_make_vector (MAKINUM (i), UNSPECIFIED);
      while (i--)
	VELTS (ans)[i] = scm_copytree (VELTS (obj)[i]);
      return ans;
    }
  if NCONSP (obj)
    return obj;
/*  return scm_cons(scm_copytree(CAR(obj)), scm_copytree(CDR(obj))); */
  ans = tl = scm_cons (scm_copytree (CAR (obj)), UNSPECIFIED);
  while (NIMP (obj = CDR (obj)) && CONSP (obj))
    tl = (CDR (tl) = scm_cons (scm_copytree (CAR (obj)), UNSPECIFIED));
  CDR (tl) = obj;
  return ans;
}

static SCM system_transformer;

SCM 
scm_eval_3 (obj, copyp, env)
     SCM obj;
     int copyp;
     SCM env;
{
  if (NIMP (CDR (system_transformer)))
    obj = scm_apply (CDR (system_transformer), obj, listofnull);
  else if (copyp)
    obj = scm_copytree (obj);
  return IMP(obj) ? obj : scm_ceval (obj, env);
}

SCM
scm_top_level_env (thunk)
     SCM thunk;
{
  if (IMP(thunk))
    return EOL;
  else
    return scm_cons(thunk, (SCM)EOL);
}

SCM
scm_eval2 (obj, env_thunk)
     SCM obj;
     SCM env_thunk;
{
  return scm_eval_3 (obj, 1, scm_top_level_env(env_thunk));
}

SCM
scm_eval (obj)
     SCM obj;
{
  return
    scm_eval_3(obj, 1, scm_top_level_env(CDR(scm_top_level_lookup_thunk_var)));
}

SCM
scm_neval (obj)
     SCM obj;
{
  return
    scm_eval_3(obj,
	       0,
	       scm_top_level_env (CDR (scm_top_level_lookup_thunk_var)));
}

SCM 
scm_definedp (x, env)
     SCM x, env;
{
  SCM proc = CAR (x = CDR (x));
  if (ISYMP (proc))
    return BOOL_T;
  else if(IMP(proc) || !SYMBOLP(proc))
    return BOOL_F;
  else
    {
      SCM vcell = scm_sym2vcell(proc, env_top_level(env), BOOL_F);
      return (vcell == BOOL_F || UNBNDP(CDR(vcell))) ? BOOL_F : BOOL_T;
    }
}

static scm_iproc subr1s[] =
{
  {"copy-tree", scm_copytree},
  {"eval", scm_eval},
  {"eval!", scm_neval},
  {scm_s_force, scm_force},
  {s_proc_doc, l_proc_doc},
  {"procedure->syntax", scm_makacro},
  {"procedure->macro", scm_makmacro},
  {"procedure->memoizing-macro", scm_makmmacro},
  {"apply:nconc-to-last", scm_nconc2last},
  {0, 0}};

static scm_iproc lsubr2s[] =
{
/*	{s_apply, scm_apply}, now explicity initted */
  {scm_s_map, scm_map},
  {scm_s_for_each, scm_for_each},
  {0, 0}};

static scm_smobfuns promsmob =
{scm_markcdr, scm_free0, prinprom};
static scm_smobfuns macrosmob =
{scm_markcdr, scm_free0, prinmacro};

SCM 
scm_make_synt (name, macroizer, fcn)
     char *name;
SCM (*macroizer) ();
SCM (*fcn) ();
{
  SCM symcell = scm_sysintern (name, SCM_UNDEFINED);
  long tmp = ((((CELLPTR) (CAR (symcell))) - scm_heap_org) << 8);
  register SCM z;
  if ((tmp >> 8) != ((CELLPTR) (CAR (symcell)) - scm_heap_org))
    tmp = 0;
  NEWCELL (z);
  SUBRF (z) = fcn;
  CAR (z) = tmp + tc7_subr_2;
  CDR (symcell) = macroizer (z);
  return CAR (symcell);
}

static char s_eval2[] = "eval2";

void 
scm_init_eval ()
{
  scm_tc16_promise = scm_newsmob (&promsmob);
  scm_tc16_macro = scm_newsmob (&macrosmob);
  scm_init_iprocs (subr1s, tc7_subr_1);
  scm_make_subr (s_eval2, tc7_subr_2, scm_eval2);
  scm_init_iprocs (lsubr2s, tc7_lsubr_2);
  scm_i_apply = scm_make_subr (s_apply, tc7_lsubr_2, scm_apply);
  system_transformer = scm_sysintern ("scm:scm_eval-transformer", SCM_UNDEFINED);
  scm_i_dot = CAR (scm_sysintern (".", SCM_UNDEFINED));
  scm_i_arrow = CAR (scm_sysintern ("=>", SCM_UNDEFINED));
  scm_i_else = CAR (scm_sysintern ("else", SCM_UNDEFINED));
  scm_i_unquote = CAR (scm_sysintern ("unquote", SCM_UNDEFINED));
  scm_i_uq_splicing = CAR (scm_sysintern ("unquote-splicing", SCM_UNDEFINED));

  /* acros */
  scm_i_quasiquote = scm_make_synt (s_quasiquote, scm_makacro, scm_m_quasiquote);
  scm_make_synt (s_define, scm_makmmacro, scm_m_define);
  scm_make_synt (s_delay, scm_makacro, scm_m_delay);
  /* end of acros */

  scm_top_level_lookup_thunk_var =
    scm_sysintern("*top-level-lookup-thunk*", BOOL_F);

  scm_make_synt (s_and, scm_makmmacro, scm_m_and);
  scm_make_synt (s_begin, scm_makmmacro, scm_m_begin);
  scm_make_synt (s_case, scm_makmmacro, scm_m_case);
  scm_make_synt (s_cond, scm_makmmacro, scm_m_cond);
  scm_make_synt (s_do, scm_makmmacro, scm_m_do);
  scm_make_synt (s_if, scm_makmmacro, scm_m_if);
  scm_i_lambda = scm_make_synt (s_lambda, scm_makmmacro, scm_m_lambda);
  scm_i_let = scm_make_synt (s_let, scm_makmmacro, scm_m_let);
  scm_make_synt (s_letrec, scm_makmmacro, scm_m_letrec);
  scm_make_synt (s_letstar, scm_makmmacro, scm_m_letstar);
  scm_make_synt (s_or, scm_makmmacro, scm_m_or);
  scm_i_quote = scm_make_synt (s_quote, scm_makmmacro, scm_m_quote);
  scm_make_synt (s_set, scm_makmmacro, scm_m_set);
  scm_make_synt (s_atapply, scm_makmmacro, scm_m_apply);
  scm_make_synt (s_atcall_cc, scm_makmmacro, scm_m_cont);

  scm_make_synt ("defined?", scm_makmmacro, scm_definedp);
}
