* debug.c, debug.h: Removed obsolete code.

[bpt/guile.git] / libguile / eval.c

/*	Copyright (C) 1995,1996 Free Software Foundation, Inc.
 * 
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2, or (at your option)
 * any later version.
 * 
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 * 
 * You should have received a copy of the GNU General Public License
 * along with this software; see the file COPYING.  If not, write to
 * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
 *
 * As a special exception, the Free Software Foundation gives permission
 * for additional uses of the text contained in its release of GUILE.
 *
 * The exception is that, if you link the GUILE library with other files
 * to produce an executable, this does not by itself cause the
 * resulting executable to be covered by the GNU General Public License.
 * Your use of that executable is in no way restricted on account of
 * linking the GUILE library code into it.
 *
 * This exception does not however invalidate any other reasons why
 * the executable file might be covered by the GNU General Public License.
 *
 * This exception applies only to the code released by the
 * Free Software Foundation under the name GUILE.  If you copy
 * code from other Free Software Foundation releases into a copy of
 * GUILE, as the General Public License permits, the exception does
 * not apply to the code that you add in this way.  To avoid misleading
 * anyone as to the status of such modified files, you must delete
 * this exception notice from them.
 *
 * If you write modifications of your own for GUILE, it is your choice
 * whether to permit this exception to apply to your modifications.
 * If you do not wish that, delete this exception notice.  
 */
\f

/* This file is read twice in order to produce debugging versions of
 * scm_ceval and scm_apply.  These functions, scm_deval and
 * scm_dapply, are produced when we define the preprocessor macro
 * DEVAL.  The file is divided into sections which are treated
 * differently with respect to DEVAL.  The heads of these sections are
 * marked with the string "SECTION:".
 */


/* SECTION: This code is compiled once.
 */

#ifndef DEVAL

#include <stdio.h>
#include "_scm.h"
#include "debug.h"
#include "append.h"
#include "alist.h"
#include "sequences.h"
#include "eq.h"
#include "continuations.h"
#include "throw.h"
#include "smob.h"
#include "markers.h"
#include "procprop.h"
#include "hashtab.h"
#include "hash.h"

#ifdef DEBUG_EXTENSIONS
#include "debug.h"
#endif /* DEBUG_EXTENSIONS */

#include "srcprop.h"
#include "stackchk.h"

#include "eval.h"
\f

/* The evaluator contains a plethora of EVAL symbols.
 * This is an attempt at explanation.
 *
 * The following macros should be used in code which is read twice
 * (where the choice of evaluator is hard soldered):
 *
 *   SCM_CEVAL is the symbol used within one evaluator to call itself.
 *   Originally, it is defined to scm_ceval, but is redefined to
 *   scm_deval during the second pass.
 *  
 *   SIDEVAL corresponds to SCM_CEVAL, but is used in situations where
 *   only side effects of expressions matter.  All immediates are
 *   ignored.
 *  
 *   EVALIM is used when it is known that the expression is an
 *   immediate.  (This macro never calls an evaluator.)
 *  
 *   EVALCAR evaluates the car of an expression.
 *  
 *   EVALCELLCAR is like EVALCAR, but is used when it is known that the
 *   car is a lisp cell.
 *
 * The following macros should be used in code which is read once
 * (where the choice of evaluator is dynamic):
 *
 *   XEVAL takes care of immediates without calling an evaluator.  It
 *   then calls scm_ceval *or* scm_deval, depending on the debugging
 *   mode.
 *  
 *   XEVALCAR corresponds to EVALCAR, but uses scm_ceval *or* scm_deval
 *   depending on the debugging mode.
 *
 * The main motivation for keeping this plethora is efficiency
 * together with maintainability (=> locality of code).
 */

#define EVALCELLCAR(x, env) (SCM_SYMBOLP (SCM_CAR(x)) \
			     ? *scm_lookupcar(x, env) \
			     : SCM_CEVAL(SCM_CAR(x), env))

#ifdef MEMOIZE_LOCALS
#define EVALIM(x, env) (SCM_ILOCP(x)?*scm_ilookup((x), env):x)
#else
#define EVALIM(x, env) x
#endif
#define EVALCAR(x, env) (SCM_NCELLP(SCM_CAR(x))\
			? (SCM_IMP(SCM_CAR(x)) \
			   ? EVALIM(SCM_CAR(x), env) \
			   : SCM_GLOC_VAL(SCM_CAR(x))) \
			: EVALCELLCAR(x, env))
#ifdef DEBUG_EXTENSIONS
#define XEVALCAR(x, env) (SCM_NCELLP(SCM_CAR(x)) \
			  ? (SCM_IMP(SCM_CAR(x)) \
			     ? EVALIM(SCM_CAR(x), env) \
			     : SCM_GLOC_VAL(SCM_CAR(x))) \
			  : (SCM_SYMBOLP(SCM_CAR(x)) \
			     ? *scm_lookupcar(x, env) \
			     : (*scm_ceval_ptr) (SCM_CAR(x), env)))
#else
#define XEVALCAR(x, env) EVALCAR(x, env)
#endif

#define EXTEND_ENV SCM_EXTEND_ENV

#ifdef MEMOIZE_LOCALS

SCM *
scm_ilookup (iloc, env)
     SCM iloc;
     SCM env;
{
  register int ir = SCM_IFRAME (iloc);
  register SCM er = env;
  for (; 0 != ir; --ir)
    er = SCM_CDR (er);
  er = SCM_CAR (er);
  for (ir = SCM_IDIST (iloc); 0 != ir; --ir)
    er = SCM_CDR (er);
  if (SCM_ICDRP (iloc))
    return &SCM_CDR (er);
  return &SCM_CAR (SCM_CDR (er));
}
#endif


SCM *
scm_lookupcar (vloc, genv)
     SCM vloc;
     SCM genv;
{
  SCM env = genv;
  register SCM *al, fl, var = SCM_CAR (vloc);
#ifdef MEMOIZE_LOCALS
  register SCM iloc = SCM_ILOC00;
#endif
  for (; SCM_NIMP (env); env = SCM_CDR (env))
    {
      if (SCM_BOOL_T == scm_procedure_p (SCM_CAR (env)))
	break;
      al = &SCM_CAR (env);
      for (fl = SCM_CAR (*al); SCM_NIMP (fl); fl = SCM_CDR (fl))
	{
	  if (SCM_NCONSP (fl))
	      if (fl == var)
	      {
#ifdef MEMOIZE_LOCALS
		SCM_CAR (vloc) = iloc + SCM_ICDR;
#endif
		return &SCM_CDR (*al);
	      }
	    else
	      break;
	  al = &SCM_CDR (*al);
	  if (SCM_CAR (fl) == var)
	    {
#ifdef MEMOIZE_LOCALS
#ifndef RECKLESS		/* letrec inits to SCM_UNDEFINED */
	      if (SCM_UNBNDP (SCM_CAR (*al)))
		{
		  env = SCM_EOL;
		  goto errout;
		}
#endif
	      SCM_CAR (vloc) = iloc;
#endif
	      return &SCM_CAR (*al);
	    }
#ifdef MEMOIZE_LOCALS
	  iloc += SCM_IDINC;
#endif
	}
#ifdef MEMOIZE_LOCALS
      iloc = (~SCM_IDSTMSK) & (iloc + SCM_IFRINC);
#endif
    }
  {
    SCM top_thunk, vcell;
    if (SCM_NIMP(env))
      {
	top_thunk = SCM_CAR(env);	/* env now refers to a top level env thunk */
	env = SCM_CDR (env);
      }
    else
      top_thunk = SCM_BOOL_F;
    vcell = scm_sym2vcell (var, top_thunk, SCM_BOOL_F);
    if (vcell == SCM_BOOL_F)
      goto errout;
    else
      var = vcell;
  }
#ifndef RECKLESS
  if (SCM_NNULLP (env) || SCM_UNBNDP (SCM_CDR (var)))
    {
      var = SCM_CAR (var);
    errout:
      /* scm_everr (vloc, genv,...) */
      scm_error (scm_misc_error_key,
		 NULL,
		 SCM_NULLP (env)
		 ? "Unbound variable: %S"
		 : "Damaged environment: %S",
		 scm_listify (var, SCM_UNDEFINED),
		 SCM_BOOL_F);
    }
#endif
  SCM_CAR (vloc) = var + 1;
  /* Except wait...what if the var is not a vcell,
   * but syntax or something....
   */
  return &SCM_CDR (var);
}

#define unmemocar scm_unmemocar

SCM 
scm_unmemocar (form, env)
     SCM form;
     SCM env;
{
#ifdef DEBUG_EXTENSIONS
  register int ir;
#endif
  SCM c;

  if (SCM_IMP (form))
    return form;
  c = SCM_CAR (form);
  if (1 == (c & 7))
    SCM_CAR (form) = SCM_CAR (c - 1);
#ifdef MEMOIZE_LOCALS
#ifdef DEBUG_EXTENSIONS
  else if (SCM_ILOCP (c))
    {
      for (ir = SCM_IFRAME (c); ir != 0; --ir)
	env = SCM_CDR (env);
      env = SCM_CAR (SCM_CAR (env));
      for (ir = SCM_IDIST (c); ir != 0; --ir)
	env = SCM_CDR (env);
      SCM_CAR (form) = SCM_ICDRP (c) ? env : SCM_CAR (env);
    }
#endif
#endif
  return form;
}


SCM
scm_eval_car (pair, env)
     SCM pair;
     SCM env;
{
  return XEVALCAR (pair, env);
}

\f
/* 
 * 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;
SCM scm_i_name;
SCM scm_i_define, scm_i_and, scm_i_begin, scm_i_case, scm_i_cond,
  scm_i_do, scm_i_if, scm_i_let, scm_i_letrec, scm_i_letstar,
  scm_i_or, scm_i_set, scm_i_atapply, scm_i_atcall_cc;
static char s_quasiquote[] = "quasiquote";
static char s_delay[] = "delay";
static char s_undefine[] = "undefine";
#ifdef DEBUG_EXTENSIONS
SCM scm_i_enter_frame, scm_i_apply_frame, scm_i_exit_frame;
SCM scm_i_trace;
#endif

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



static void  bodycheck SCM_P ((SCM xorig, SCM *bodyloc, char *what));

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



SCM 
scm_m_quote (xorig, env)
     SCM xorig;
     SCM env;
{
  ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, xorig, s_expression, "quote");
  return scm_cons (SCM_IM_QUOTE, SCM_CDR (xorig));
}



SCM 
scm_m_begin (xorig, env)
     SCM xorig;
     SCM env;
{
  ASSYNT (scm_ilength (SCM_CDR (xorig)) >= 1, xorig, s_expression, "begin");
  return scm_cons (SCM_IM_BEGIN, SCM_CDR (xorig));
}



SCM 
scm_m_if (xorig, env)
     SCM xorig;
     SCM env;
{
  int len = scm_ilength (SCM_CDR (xorig));
  ASSYNT (len >= 2 && len <= 3, xorig, s_expression, "if");
  return scm_cons (SCM_IM_IF, SCM_CDR (xorig));
}



SCM 
scm_m_set (xorig, env)
     SCM xorig;
     SCM env;
{
  SCM x = SCM_CDR (xorig);
  ASSYNT (2 == scm_ilength (x), xorig, s_expression, "set!");
  ASSYNT (SCM_NIMP (SCM_CAR (x)) && SCM_SYMBOLP (SCM_CAR (x)),
	  xorig, s_variable, "set!");
  return scm_cons (SCM_IM_SET, x);
}


#if 0

SCM 
scm_m_vref (xorig, env)
     SCM xorig;
     SCM env;
{
  SCM x = SCM_CDR (xorig);
  ASSYNT (1 == scm_ilength (x), xorig, s_expression, s_vref);
  if (SCM_NIMP(x) && UDSCM_VARIABLEP (SCM_CAR (x)))
    {
      /* scm_everr (SCM_UNDEFINED, env,..., "global variable reference") */
      scm_error (scm_misc_error_key,
		 NULL,
		 "Bad variable: %S",
		 scm_listify (SCM_CAR (SCM_CDR (x)), SCM_UNDEFINED),
		 SCM_BOOL_F);
    }
  ASSYNT (SCM_NIMP(x) && DEFSCM_VARIABLEP (SCM_CAR (x)),
	  xorig, s_variable, s_vref);
  return 
  return scm_cons (IM_VREF, x);
}



SCM 
scm_m_vset (xorig, env)
     SCM xorig;
     SCM env;
{
  SCM x = SCM_CDR (xorig);
  ASSYNT (3 == scm_ilength (x), xorig, s_expression, s_vset);
  ASSYNT ((   DEFSCM_VARIABLEP (SCM_CAR (x))
	   || UDSCM_VARIABLEP (SCM_CAR (x))),
	  xorig, s_variable, s_vset);
  return scm_cons (IM_VSET, x);
}
#endif 



SCM 
scm_m_and (xorig, env)
     SCM xorig;
     SCM env;
{
  int len = scm_ilength (SCM_CDR (xorig));
  ASSYNT (len >= 0, xorig, s_test, "and");
  if (len >= 1)
    return scm_cons (SCM_IM_AND, SCM_CDR (xorig));
  else
    return SCM_BOOL_T;
}



SCM 
scm_m_or (xorig, env)
     SCM xorig;
     SCM env;
{
  int len = scm_ilength (SCM_CDR (xorig));
  ASSYNT (len >= 0, xorig, s_test, "or");
  if (len >= 1)
    return scm_cons (SCM_IM_OR, SCM_CDR (xorig));
  else
    return SCM_BOOL_F;
}



SCM 
scm_m_case (xorig, env)
     SCM xorig;
     SCM env;
{
  SCM proc, x = SCM_CDR (xorig);
  ASSYNT (scm_ilength (x) >= 2, xorig, s_clauses, "case");
  while (SCM_NIMP (x = SCM_CDR (x)))
    {
      proc = SCM_CAR (x);
      ASSYNT (scm_ilength (proc) >= 2, xorig, s_clauses, "case");
      ASSYNT (scm_ilength (SCM_CAR (proc)) >= 0 || scm_i_else == SCM_CAR (proc),
	      xorig, s_clauses, "case");
    }
  return scm_cons (SCM_IM_CASE, SCM_CDR (xorig));
}



SCM 
scm_m_cond (xorig, env)
     SCM xorig;
     SCM env;
{
  SCM arg1, x = SCM_CDR (xorig);
  int len = scm_ilength (x);
  ASSYNT (len >= 1, xorig, s_clauses, "cond");
  while (SCM_NIMP (x))
    {
      arg1 = SCM_CAR (x);
      len = scm_ilength (arg1);
      ASSYNT (len >= 1, xorig, s_clauses, "cond");
      if (scm_i_else == SCM_CAR (arg1))
	{
	  ASSYNT (SCM_NULLP (SCM_CDR (x)) && len >= 2, xorig, "bad ELSE clause", "cond");
	  SCM_CAR (arg1) = SCM_BOOL_T;
	}
      if (len >= 2 && scm_i_arrow == SCM_CAR (SCM_CDR (arg1)))
	ASSYNT (3 == len && SCM_NIMP (SCM_CAR (SCM_CDR (SCM_CDR (arg1)))),
		xorig, "bad recipient", "cond");
      x = SCM_CDR (x);
    }
  return scm_cons (SCM_IM_COND, SCM_CDR (xorig));
}



SCM 
scm_m_lambda (xorig, env)
     SCM xorig;
     SCM env;
{
  SCM proc, x = SCM_CDR (xorig);
  if (scm_ilength (x) < 2)
    goto badforms;
  proc = SCM_CAR (x);
  if SCM_NULLP
    (proc) goto memlambda;
  if SCM_IMP
    (proc) goto badforms;
  if SCM_SYMBOLP
    (proc) goto memlambda;
  if SCM_NCONSP
    (proc) goto badforms;
  while SCM_NIMP
    (proc)
    {
      if SCM_NCONSP
	(proc)
	  if (!SCM_SYMBOLP (proc))
	  goto badforms;
	else
	  goto memlambda;
      if (!(SCM_NIMP (SCM_CAR (proc)) && SCM_SYMBOLP (SCM_CAR (proc))))
	goto badforms;
      proc = SCM_CDR (proc);
    }
  if SCM_NNULLP
    (proc)
  badforms:scm_wta (xorig, s_formals, "lambda");
memlambda:
  bodycheck (xorig, &SCM_CDR (x), "lambda");
  return scm_cons (SCM_IM_LAMBDA, SCM_CDR (xorig));
}



SCM 
scm_m_letstar (xorig, env)
     SCM xorig;
     SCM env;
{
  SCM x = SCM_CDR (xorig), arg1, proc, vars = SCM_EOL, *varloc = &vars;
  int len = scm_ilength (x);
  ASSYNT (len >= 2, xorig, s_body, "let*");
  proc = SCM_CAR (x);
  ASSYNT (scm_ilength (proc) >= 0, xorig, s_bindings, "let*");
  while SCM_NIMP (proc)
    {
      arg1 = SCM_CAR (proc);
      ASSYNT (2 == scm_ilength (arg1), xorig, s_bindings, "let*");
      ASSYNT (SCM_NIMP (SCM_CAR (arg1)) && SCM_SYMBOLP (SCM_CAR (arg1)), xorig, s_variable, "let*");
      *varloc = scm_cons2 (SCM_CAR (arg1), SCM_CAR (SCM_CDR (arg1)), SCM_EOL);
      varloc = &SCM_CDR (SCM_CDR (*varloc));
      proc = SCM_CDR (proc);
    }
  x = scm_cons (vars, SCM_CDR (x));
  bodycheck (xorig, &SCM_CDR (x), "let*");
  return scm_cons (SCM_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;
     SCM env;
{
  SCM x = SCM_CDR (xorig), arg1, proc;
  SCM vars = SCM_EOL, inits = SCM_EOL, steps = SCM_EOL;
  SCM *initloc = &inits, *steploc = &steps;
  int len = scm_ilength (x);
  ASSYNT (len >= 2, xorig, s_test, "do");
  proc = SCM_CAR (x);
  ASSYNT (scm_ilength (proc) >= 0, xorig, s_bindings, "do");
  while SCM_NIMP
    (proc)
    {
      arg1 = SCM_CAR (proc);
      len = scm_ilength (arg1);
      ASSYNT (2 == len || 3 == len, xorig, s_bindings, "do");
      ASSYNT (SCM_NIMP (SCM_CAR (arg1)) && SCM_SYMBOLP (SCM_CAR (arg1)), xorig, s_variable, "do");
      /* vars reversed here, inits and steps reversed at evaluation */
      vars = scm_cons (SCM_CAR (arg1), vars);	/* variable */
      arg1 = SCM_CDR (arg1);
      *initloc = scm_cons (SCM_CAR (arg1), SCM_EOL);	/* init */
      initloc = &SCM_CDR (*initloc);
      arg1 = SCM_CDR (arg1);
      *steploc = scm_cons (SCM_IMP (arg1) ? SCM_CAR (vars) : SCM_CAR (arg1), SCM_EOL);	/* step */
      steploc = &SCM_CDR (*steploc);
      proc = SCM_CDR (proc);
    }
  x = SCM_CDR (x);
  ASSYNT (scm_ilength (SCM_CAR (x)) >= 1, xorig, s_test, "do");
  x = scm_cons2 (SCM_CAR (x), SCM_CDR (x), steps);
  x = scm_cons2 (vars, inits, x);
  bodycheck (xorig, &SCM_CAR (SCM_CDR (SCM_CDR (x))), "do");
  return scm_cons (SCM_IM_DO, x);
}

/* evalcar is small version of inline EVALCAR when we don't care about
 * speed
 */
#define evalcar scm_eval_car


static SCM  iqq SCM_P ((SCM form, SCM env, int depth));

static SCM 
iqq (form, env, depth)
     SCM form;
     SCM env;
     int depth;
{
  SCM tmp;
  int edepth = depth;
  if SCM_IMP
    (form) return form;
  if (SCM_VECTORP (form))
    {
      long i = SCM_LENGTH (form);
      SCM *data = SCM_VELTS (form);
      tmp = SCM_EOL;
      for (; --i >= 0;)
	tmp = scm_cons (data[i], tmp);
      return scm_vector (iqq (tmp, env, depth));
    }
  if SCM_NCONSP
    (form) return form;
  tmp = SCM_CAR (form);
  if (scm_i_quasiquote == tmp)
    {
      depth++;
      goto label;
    }
  if (scm_i_unquote == tmp)
    {
      --depth;
    label:
      form = SCM_CDR (form);
      /* !!! might need a check here to be sure that form isn't a struct. */
      SCM_ASSERT (SCM_NIMP (form) && SCM_ECONSP (form) && SCM_NULLP (SCM_CDR (form)),
	      form, SCM_ARG1, s_quasiquote);
      if (0 == depth)
	return evalcar (form, env);
      return scm_cons2 (tmp, iqq (SCM_CAR (form), env, depth), SCM_EOL);
    }
  if (SCM_NIMP (tmp) && (scm_i_uq_splicing == SCM_CAR (tmp)))
    {
      tmp = SCM_CDR (tmp);
      if (0 == --edepth)
	return scm_append (scm_cons2 (evalcar (tmp, env), iqq (SCM_CDR (form), env, depth), SCM_EOL));
    }
  return scm_cons (iqq (SCM_CAR (form), env, edepth), iqq (SCM_CDR (form), env, depth));
}

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


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


SCM 
scm_m_delay (xorig, env)
     SCM xorig;
     SCM env;
{
  ASSYNT (scm_ilength (xorig) == 2, xorig, s_expression, s_delay);
  xorig = SCM_CDR (xorig);
  return scm_makprom (scm_closure (scm_cons2 (SCM_EOL, SCM_CAR (xorig), SCM_CDR (xorig)),
				   env));
}


static SCM env_top_level SCM_P ((SCM env));

static SCM
env_top_level (env)
     SCM env;
{
  while (SCM_NIMP(env))
    {
      if (SCM_BOOL_T == scm_procedure_p (SCM_CAR(env)))
	return SCM_CAR(env);
      env = SCM_CDR (env);
    }
  return SCM_BOOL_F;
}


SCM 
scm_m_define (x, env)
     SCM x;
     SCM env;
{
  SCM proc, arg1 = x;
  x = SCM_CDR (x);
  /*  ASSYNT(SCM_NULLP(env), x, "bad placement", s_define);*/
  ASSYNT (scm_ilength (x) >= 2, arg1, s_expression, "define");
  proc = SCM_CAR (x);
  x = SCM_CDR (x);
  while (SCM_NIMP (proc) && SCM_CONSP (proc))
    {				/* nested define syntax */
      x = scm_cons (scm_cons2 (scm_i_lambda, SCM_CDR (proc), x), SCM_EOL);
      proc = SCM_CAR (proc);
    }
  ASSYNT (SCM_NIMP (proc) && SCM_SYMBOLP (proc), arg1, s_variable, "define");
  ASSYNT (1 == scm_ilength (x), arg1, s_expression, "define");
  if (SCM_TOP_LEVEL (env))
    {
      x = evalcar (x, env);
#ifdef DEBUG_EXTENSIONS
      if (SCM_REC_PROCNAMES_P && SCM_NIMP (x) && SCM_CLOSUREP (x))
	scm_set_procedure_property_x (x, scm_i_name, proc);
#endif
      arg1 = scm_sym2vcell (proc, env_top_level (env), SCM_BOOL_T);
#if 0
#ifndef RECKLESS
      if (SCM_NIMP (SCM_CDR (arg1)) && ((SCM) SCM_SNAME (SCM_CDR (arg1)) == proc)
	  && (SCM_CDR (arg1) != x))
	scm_warn ("redefining built-in ", SCM_CHARS (proc));
      else
#endif
      if (5 <= scm_verbose && SCM_UNDEFINED != SCM_CDR (arg1))
	scm_warn ("redefining ", SCM_CHARS (proc));
#endif
      SCM_CDR (arg1) = x;
#ifdef SICP
      return scm_cons2 (scm_i_quote, SCM_CAR (arg1), SCM_EOL);
#else
      return SCM_UNSPECIFIED;
#endif
    }
  return scm_cons2 (SCM_IM_DEFINE, proc, x);
}

SCM
scm_m_undefine (x, env)
     SCM x, env;
{
  SCM arg1 = x;
  x = SCM_CDR (x);
  ASSYNT (SCM_TOP_LEVEL (env), arg1, "bad placement ", s_undefine);
  ASSYNT (SCM_NIMP (x) && SCM_CONSP (x) && SCM_CDR (x) == SCM_EOL,
	  arg1, s_expression, s_undefine);
  x = SCM_CAR (x);
  ASSYNT (SCM_NIMP (x) && SCM_SYMBOLP (x), arg1, s_variable, s_undefine);
  arg1 = scm_sym2vcell (x, env_top_level (env), SCM_BOOL_F);
  ASSYNT (SCM_NFALSEP (arg1) && !SCM_UNBNDP (SCM_CDR (arg1)),
	  x, "variable already unbound ", s_undefine);
#if 0
#ifndef RECKLESS
  if (SCM_NIMP (SCM_CDR (arg1)) && ((SCM) SCM_SNAME (SCM_CDR (arg1)) == x))
    scm_warn ("undefining built-in ", SCM_CHARS (x));
  else
#endif
    if (5 <= scm_verbose && SCM_UNDEFINED != SCM_CDR (arg1))
      scm_warn ("redefining ", SCM_CHARS (x));
#endif
  SCM_CDR (arg1) = SCM_UNDEFINED;
#ifdef SICP
  return SCM_CAR (arg1);
#else
  return SCM_UNSPECIFIED;
#endif
}

/* end of acros */


SCM 
scm_m_letrec (xorig, env)
     SCM xorig;
     SCM env;
{
  SCM cdrx = SCM_CDR (xorig);	/* locally mutable version of form */
  char *what = SCM_CHARS (SCM_CAR (xorig));
  SCM x = cdrx, proc, arg1;	/* structure traversers */
  SCM vars = SCM_EOL, inits = SCM_EOL, *initloc = &inits;

  ASRTSYNTAX (scm_ilength (x) >= 2, s_body);
  proc = SCM_CAR (x);
  if SCM_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 = SCM_CAR (proc);
      ASRTSYNTAX (2 == scm_ilength (arg1), s_bindings);
      ASRTSYNTAX (SCM_NIMP (SCM_CAR (arg1)) && SCM_SYMBOLP (SCM_CAR (arg1)), s_variable);
      vars = scm_cons (SCM_CAR (arg1), vars);
      *initloc = scm_cons (SCM_CAR (SCM_CDR (arg1)), SCM_EOL);
      initloc = &SCM_CDR (*initloc);
    }
  while SCM_NIMP
  (proc = SCM_CDR (proc));
  cdrx = scm_cons2 (vars, inits, SCM_CDR (x));
  bodycheck (xorig, &SCM_CDR (SCM_CDR (cdrx)), what);
  return scm_cons (SCM_IM_LETREC, cdrx);
}


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

  ASSYNT (scm_ilength (x) >= 2, xorig, s_body, "let");
  proc = SCM_CAR (x);
  if (SCM_NULLP (proc)
      || (SCM_NIMP (proc) && SCM_CONSP (proc)
	  && SCM_NIMP (SCM_CAR (proc)) && SCM_CONSP (SCM_CAR (proc)) && SCM_NULLP (SCM_CDR (proc))))
    return scm_m_letstar (xorig, env);	/* null or single binding, let* is faster */
  ASSYNT (SCM_NIMP (proc), xorig, s_bindings, "let");
  if (SCM_CONSP (proc))			/* plain let, proc is <bindings> */
      return scm_cons (SCM_IM_LET, SCM_CDR (scm_m_letrec (xorig, env)));
  if (!SCM_SYMBOLP (proc))
    scm_wta (xorig, s_bindings, "let");	/* bad let */
  name = proc;			/* named let, build equiv letrec */
  x = SCM_CDR (x);
  ASSYNT (scm_ilength (x) >= 2, xorig, s_body, "let");
  proc = SCM_CAR (x);		/* bindings scm_list */
  ASSYNT (scm_ilength (proc) >= 0, xorig, s_bindings, "let");
  while SCM_NIMP
    (proc)
    {				/* vars and inits both in order */
      arg1 = SCM_CAR (proc);
      ASSYNT (2 == scm_ilength (arg1), xorig, s_bindings, "let");
      ASSYNT (SCM_NIMP (SCM_CAR (arg1)) && SCM_SYMBOLP (SCM_CAR (arg1)), xorig, s_variable, "let");
      *varloc = scm_cons (SCM_CAR (arg1), SCM_EOL);
      varloc = &SCM_CDR (*varloc);
      *initloc = scm_cons (SCM_CAR (SCM_CDR (arg1)), SCM_EOL);
      initloc = &SCM_CDR (*initloc);
      proc = SCM_CDR (proc);
    }
  return
    scm_m_letrec (scm_cons2 (scm_i_let,
			     scm_cons (scm_cons2 (name, scm_cons2 (scm_i_lambda, vars, SCM_CDR (x)), SCM_EOL), SCM_EOL),
			     scm_acons (name, inits, SCM_EOL)), 	/* body */
		  env);
}



SCM 
scm_m_apply (xorig, env)
     SCM xorig;
     SCM env;
{
  ASSYNT (scm_ilength (SCM_CDR (xorig)) == 2, xorig, s_expression, "@apply");
  return scm_cons (SCM_IM_APPLY, SCM_CDR (xorig));
}

#define s_atcall_cc (SCM_ISYMCHARS(SCM_IM_CONT)+1)


SCM 
scm_m_cont (xorig, env)
     SCM xorig;
     SCM env;
{
  ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, xorig, s_expression, "@call-with-current-continuation");
  return scm_cons (SCM_IM_CONT, SCM_CDR (xorig));
}

/* scm_unmemocopy takes a memoized expression together with its
 * environment and rewrites it to its original form.  Thus, it is the
 * inversion of the rewrite rules above.  The procedure is not
 * optimized for speed.  It's used in scm_iprin1 when printing the
 * code of a closure, in scm_procedure_source and in scm_expr_stack
 * when generating the source for a stackframe.
 */


static SCM unmemocopy SCM_P ((SCM x, SCM env));

static SCM
unmemocopy (x, env)
     SCM x;
     SCM env;
{
  SCM ls, z;
#ifdef DEBUG_EXTENSIONS
  SCM p;
#endif
  if (SCM_NCELLP (x) || SCM_NECONSP (x))
    return x;
#ifdef DEBUG_EXTENSIONS
  p = scm_whash_lookup (scm_source_whash, x);
#endif
  switch (SCM_TYP7 (x))
    {
    case (127 & SCM_IM_AND):
      ls = z = scm_cons (scm_i_and, SCM_UNSPECIFIED);
      break;
    case (127 & SCM_IM_BEGIN):
      ls = z = scm_cons (scm_i_begin, SCM_UNSPECIFIED);
      break;
    case (127 & SCM_IM_CASE):
      ls = z = scm_cons (scm_i_case, SCM_UNSPECIFIED);
      break;
    case (127 & SCM_IM_COND):
      ls = z = scm_cons (scm_i_cond, SCM_UNSPECIFIED);
      break;
    case (127 & SCM_IM_DO):
      ls = scm_cons (scm_i_do, SCM_UNSPECIFIED);
      goto transform;
    case (127 & SCM_IM_IF):
      ls = z = scm_cons (scm_i_if, SCM_UNSPECIFIED);
      break;
    case (127 & SCM_IM_LET):
      ls = scm_cons (scm_i_let, SCM_UNSPECIFIED);
      goto transform;
    case (127 & SCM_IM_LETREC):
      {
	SCM f, v, e, s;
	ls = scm_cons (scm_i_letrec, SCM_UNSPECIFIED);
      transform:
	x = SCM_CDR (x);
	f = v = SCM_CAR (x);
	x = SCM_CDR (x);
	z = EXTEND_ENV (f, SCM_EOL, env);
	e = scm_reverse (unmemocopy (SCM_CAR (x),
				     SCM_CAR (ls) == scm_i_letrec ? z : env));
	env = z;
	s = SCM_CAR (ls) == scm_i_do
	    ? scm_reverse (unmemocopy (SCM_CDR (SCM_CDR (SCM_CDR (x))), env))
	    : f;
	z = SCM_EOL;
	do
	  {
	    z = scm_acons (SCM_CAR (v),
			   scm_cons (SCM_CAR (e),
				     SCM_CAR (s) == SCM_CAR (v)
				     ? SCM_EOL
				     : scm_cons (SCM_CAR (s), SCM_EOL)),
			   z);
	    v = SCM_CDR (v);
	    e = SCM_CDR (e);
	    s = SCM_CDR (s);
	  }
	while SCM_NIMP (v);
	SCM_CDR (ls) = z = scm_cons (z, SCM_UNSPECIFIED);
	if (SCM_CAR (ls) == scm_i_do)
	  {
	    x = SCM_CDR (x);
	    z = (SCM_CDR (z) = scm_cons (unmemocopy (SCM_CAR (x), env),
				     SCM_UNSPECIFIED));
	    x = (SCM) (&SCM_CAR (SCM_CDR (x)) - 1);
	  }
	break;
      }
    case (127 & SCM_IM_LETSTAR):
      {
	SCM b, y;
	x = SCM_CDR (x);
	b = SCM_CAR (x);
	y = SCM_EOL;
	if SCM_IMP (b)
	  {
	    env = EXTEND_ENV (SCM_EOL, SCM_EOL, env);
	    goto letstar;
	  }
	y = z = scm_acons (SCM_CAR (b),
			   unmemocar (
	scm_cons (unmemocopy (SCM_CAR (SCM_CDR (b)), env), SCM_EOL), env),
			   SCM_UNSPECIFIED);
	env = EXTEND_ENV (SCM_CAR (b), SCM_BOOL_F, env);
	b = SCM_CDR (SCM_CDR (b));
	if (SCM_IMP (b))
	  {
	    SCM_SETCDR (y, SCM_EOL);
	    ls = scm_cons (scm_i_let, z = scm_cons (y, SCM_UNSPECIFIED));
	    break;
	  }
	do
	  {
	    z = (SCM_CDR (z) = scm_acons (SCM_CAR (b),
					  unmemocar (
	    scm_cons (unmemocopy (SCM_CAR (SCM_CDR (b)), env), SCM_EOL), env),
					  SCM_UNSPECIFIED));
	    env = EXTEND_ENV (SCM_CAR (b), SCM_BOOL_F, env);
	    b = SCM_CDR (SCM_CDR (b));
	  }
	while SCM_NIMP (b);
	SCM_CDR (z) = SCM_EOL;
      letstar:
	ls = scm_cons (scm_i_letstar, z = scm_cons (y, SCM_UNSPECIFIED));
	break;
      }
    case (127 & SCM_IM_OR):
      ls = z = scm_cons (scm_i_or, SCM_UNSPECIFIED);
      break;
    case (127 & SCM_IM_LAMBDA):
      x = SCM_CDR (x);
      ls = scm_cons (scm_i_lambda,
		     z = scm_cons (SCM_CAR (x), SCM_UNSPECIFIED));
      env = EXTEND_ENV (SCM_CAR (x), SCM_EOL, env);
      break;
    case (127 & SCM_IM_QUOTE):
      ls = z = scm_cons (scm_i_quote, SCM_UNSPECIFIED);
      break;
    case (127 & SCM_IM_SET):
      ls = z = scm_cons (scm_i_set, SCM_UNSPECIFIED);
      break;
    case (127 & SCM_IM_DEFINE):
      {
	SCM n;
	x = SCM_CDR (x);
	ls = scm_cons (scm_i_define,
		       z = scm_cons (n = SCM_CAR (x), SCM_UNSPECIFIED));
	if (SCM_NNULLP (env))
	  SCM_CAR (SCM_CAR (env)) = scm_cons (n, SCM_CAR (SCM_CAR (env)));
	break;
      }
    case (127 & SCM_MAKISYM (0)):
      z = SCM_CAR (x);
      if (!SCM_ISYMP (z))
	goto unmemo;
      switch SCM_ISYMNUM (z)
	{
	case (SCM_ISYMNUM (SCM_IM_APPLY)):
	  ls = z = scm_cons (scm_i_atapply, SCM_UNSPECIFIED);
	  goto loop;
	case (SCM_ISYMNUM (SCM_IM_CONT)):
	  ls = z = scm_cons (scm_i_atcall_cc, SCM_UNSPECIFIED);
	  goto loop;
	default:
	}
    unmemo:
    default:
      ls = z = unmemocar (scm_cons (unmemocopy (SCM_CAR (x), env),
				    SCM_UNSPECIFIED),
			  env);
    }
loop:
  while (SCM_CELLP (x = SCM_CDR (x)) && SCM_ECONSP (x))
    z = (SCM_CDR (z) = unmemocar (scm_cons (unmemocopy (SCM_CAR (x), env),
					    SCM_UNSPECIFIED),
				  env));
  SCM_CDR (z) = x;
#ifdef DEBUG_EXTENSIONS
  if (SCM_NFALSEP (p))
    scm_whash_insert (scm_source_whash, ls, p);
#endif
  return ls;
}


SCM
scm_unmemocopy (x, env)
     SCM x;
     SCM env;
{
  if (SCM_NNULLP (env))
    /* Make a copy of the lowest frame to protect it from
       modifications by SCM_IM_DEFINE */
    return unmemocopy (x, scm_cons (SCM_CAR (env), SCM_CDR (env)));
  else
    return unmemocopy (x, env);
}

#ifndef RECKLESS

int 
scm_badargsp (formals, args)
     SCM formals;
     SCM args;
{
  while SCM_NIMP
    (formals)
    {
      if SCM_NCONSP
	(formals) return 0;
      if SCM_IMP
	(args) return 1;
      formals = SCM_CDR (formals);
      args = SCM_CDR (args);
    }
  return SCM_NNULLP (args) ? 1 : 0;
}
#endif


\f
long scm_tc16_macro;


SCM 
scm_eval_args (l, env)
     SCM l;
     SCM env;
{
  SCM res = SCM_EOL, *lloc = &res;
  while (SCM_NIMP (l))
    {
      *lloc = scm_cons (EVALCAR (l, env), SCM_EOL);
      lloc = &SCM_CDR (*lloc);
      l = SCM_CDR (l);
    }
  return res;
}
#endif /* !DEVAL */


/* SECTION: This code is specific for the debugging support.  One
 * branch is read when DEVAL isn't defined, the other when DEVAL is
 * defined.
 */

#ifndef DEVAL

#define SCM_APPLY scm_apply
#define PREP_APPLY(proc, args)
#define ENTER_APPLY
#define RETURN(x) return x;
#ifdef STACK_CHECKING
#ifndef NO_CEVAL_STACK_CHECKING
#define EVAL_STACK_CHECKING
#endif
#endif

#else /* !DEVAL */

#undef SCM_CEVAL
#define SCM_CEVAL scm_deval	/* Substitute all uses of scm_ceval */
#undef SCM_APPLY
#define SCM_APPLY scm_dapply
#undef PREP_APPLY
#define PREP_APPLY(p, l) \
{ ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
#undef ENTER_APPLY
#define ENTER_APPLY \
{\
  SCM_SET_ARGSREADY (debug);\
  if (CHECK_APPLY)\
    if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
      {\
	SCM tmp, tail = SCM_TRACED_FRAME_P (debug) ? SCM_BOOL_T : SCM_BOOL_F;\
	SCM_SET_TRACED_FRAME (debug);\
	if (SCM_CHEAPTRAPS_P)\
	  {\
	    tmp = scm_make_debugobj ((scm_debug_frame *) &debug);\
	    scm_ithrow (scm_i_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\
	  }\
	else\
	  {\
	    scm_make_cont (&tmp);\
	    if (!setjmp (SCM_JMPBUF (tmp)))\
	      scm_ithrow (scm_i_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\
	  }\
      }\
}
#undef RETURN
#define RETURN(e) {proc = (e); goto exit;}
#ifdef STACK_CHECKING
#ifndef EVAL_STACK_CHECKING
#define EVAL_STACK_CHECKING
#endif
#endif

/* scm_ceval_ptr points to the currently selected evaluator.
 * *fixme*: Although efficiency is important here, this state variable
 * should probably not be a global.  It should be related to the
 * current repl.
 */


SCM (*scm_ceval_ptr) SCM_P ((SCM x, SCM env));

/* scm_last_debug_frame contains a pointer to the last debugging
 * information stack frame.  It is accessed very often from the
 * debugging evaluator, so it should probably not be indirectly
 * addressed.  Better to save and restore it from the current root at
 * any stack swaps.
 */

#ifndef USE_THREADS
scm_debug_frame *scm_last_debug_frame;
#endif

/* scm_debug_eframe_size is the number of slots available for pseudo
 * stack frames at each real stack frame.
 */

int scm_debug_eframe_size;

int scm_debug_mode, scm_check_entry_p, scm_check_apply_p, scm_check_exit_p;

scm_option scm_debug_opts[] = {
  { SCM_OPTION_BOOLEAN, "cheap", 1,
    "*Flyweight representation of the stack at traps." },
  { SCM_OPTION_BOOLEAN, "breakpoints", 0, "*Check for breakpoints." },
  { SCM_OPTION_BOOLEAN, "trace", 0, "*Trace mode." },
  { SCM_OPTION_BOOLEAN, "procnames", 1,
    "Record procedure names at definition." },
  { SCM_OPTION_BOOLEAN, "backwards", 0,
    "Display backtrace in anti-chronological order." },
  { SCM_OPTION_INTEGER, "frames", 2,
    "Maximum number of tail-recursive frames in backtrace." },
  { SCM_OPTION_INTEGER, "depth", 80, "Maximal length of backtrace." },
  { SCM_OPTION_BOOLEAN, "backtrace", 0,
    "Show backtrace on error (use debugging evaluator)." },
  { SCM_OPTION_BOOLEAN, "deval", 0, "Use the debugging evaluator." },
  { SCM_OPTION_INTEGER, "stack", 20000, "Stack size limit (0 = no check)." }
};

scm_option scm_evaluator_trap_table[] = {
  { SCM_OPTION_BOOLEAN, "enter-frame", 0, "Trap when eval enters new frame." },
  { SCM_OPTION_BOOLEAN, "apply-frame", 0, "Trap when entering apply." },
  { SCM_OPTION_BOOLEAN, "exit-frame", 0, "Trap when exiting eval or apply." }
};

SCM
scm_deval_args (l, env, lloc)
     SCM l, env, *lloc;
{
  SCM *res = lloc;
  while (SCM_NIMP (l))
    {
      *lloc = scm_cons (EVALCAR (l, env), SCM_EOL);
      lloc = &SCM_CDR (*lloc);
      l = SCM_CDR (l);
    }
  return *res;
}

#endif /* !DEVAL */


/* SECTION: Some local definitions for the evaluator.
 */

#ifndef DEVAL
#ifdef SCM_FLOATS
#define CHECK_EQVISH(A,B) 	(((A) == (B)) || (SCM_NFALSEP (scm_eqv_p ((A), (B)))))
#else
#define CHECK_EQVISH(A,B) 	((A) == (B))
#endif
#endif /* DEVAL */


/* SECTION: This is the evaluator.  Like any real monster, it has
 * three heads.  This code is compiled twice.
 */

#if 0

SCM 
scm_ceval (x, env)
     SCM x;
     SCM env;
{}
#endif
#if 0

SCM 
scm_deval (x, env)
     SCM x;
     SCM env;
{}
#endif


SCM 
SCM_CEVAL (x, env)
     SCM x;
     SCM env;
{
  union
    {
      SCM *lloc;
      SCM arg1;
    } t;
  SCM proc, arg2;
#ifdef DEVAL
  struct
  {
    scm_debug_frame *prev;
    long status;
    scm_debug_info vect[scm_debug_eframe_size];
    scm_debug_info *info;
  } debug;
  debug.prev = scm_last_debug_frame;
  debug.status = scm_debug_eframe_size;
  debug.info = &debug.vect[0];
  scm_last_debug_frame = (scm_debug_frame *) &debug;
#endif
#ifdef EVAL_STACK_CHECKING
  if (SCM_STACK_OVERFLOW_P ((SCM_STACKITEM *) &proc)
      && scm_stack_checking_enabled_p)
    {
#ifdef DEVAL
      debug.info->e.exp = x;
      debug.info->e.env = env;
#endif
      scm_report_stack_overflow ();
    }
#endif
#ifdef DEVAL
  goto start;
#endif
loopnoap:
  PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
loop:
#ifdef DEVAL
#if 0 /* This will probably never have any practical use ... */
  if (CHECK_EXIT)
    {
      if (SINGLE_STEP || (SCM_TRACE_P && SCM_TRACED_FRAME_P (debug)))
	{
	  SINGLE_STEP = 0;
	  SCM_RESET_DEBUG_MODE;
	  SCM_CLEAR_TRACED_FRAME (debug);
	  scm_make_cont (&t.arg1);
	  if (!setjmp (SCM_JMPBUF (t.arg1)))
	    scm_ithrow (scm_i_exit_tail, scm_cons (t.arg1, SCM_EOL), 0);
	}
    }
nextframe:
#endif
  SCM_CLEAR_ARGSREADY (debug);
  if (SCM_OVERFLOWP (debug))
    --debug.info;
  else if (++debug.info == (scm_debug_info *) &debug.info)
    {
      SCM_SET_OVERFLOW (debug);
      debug.info -= 2;
    }
start:
  debug.info->e.exp = x;
  debug.info->e.env = env;
  if (CHECK_ENTRY)
    if (SCM_ENTER_FRAME_P || (SCM_BREAKPOINTS_P && SRCBRKP (x)))
      {
	SCM tail = SCM_TAILRECP (debug) ? SCM_BOOL_T : SCM_BOOL_F;
	SCM_SET_TAILREC (debug);
	SCM_ENTER_FRAME_P = 0;
	SCM_RESET_DEBUG_MODE;
	if (SCM_CHEAPTRAPS_P)
	  t.arg1 = scm_make_debugobj ((scm_debug_frame *) &debug);
	else
	  {
	    scm_make_cont (&t.arg1);
	    if (setjmp (SCM_JMPBUF (t.arg1)))
	      {
		x = SCM_THROW_VALUE (t.arg1);
		if (SCM_IMP (x))
		  {
		    RETURN (x);
		  }
		else
		  /* This gives the possibility for the debugger to
		     modify the source expression before evaluation. */
		  goto dispatch;
	      }
	  }
	scm_ithrow (scm_i_enter_frame,
		    scm_cons2 (t.arg1, tail,
			       scm_cons (scm_unmemocopy (x, env), SCM_EOL)),
		    0);
      }
dispatch:
#endif
  SCM_ASYNC_TICK;
  switch (SCM_TYP7 (x))
    {
    case scm_tcs_symbols:
      /* Only happens when called at top level.
       */
      x = scm_cons (x, SCM_UNDEFINED);
      goto retval;

    case (127 & SCM_IM_AND):
      x = SCM_CDR (x);
      t.arg1 = x;
      while (SCM_NNULLP (t.arg1 = SCM_CDR (t.arg1)))
	if (SCM_FALSEP (EVALCAR (x, env)))
	  {
	    RETURN (SCM_BOOL_F);
	  }
	else
	  x = t.arg1;
      PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
      goto carloop;

    case (127 & SCM_IM_BEGIN):
    cdrxnoap:
      PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
    cdrxbegin:
      x = SCM_CDR (x);

    begin:
      t.arg1 = x;
      while (SCM_NNULLP (t.arg1 = SCM_CDR (t.arg1)))
	{
	  SIDEVAL (SCM_CAR (x), env);
	  x = t.arg1;
	}

    carloop:			/* scm_eval car of last form in list */
      if (SCM_NCELLP (SCM_CAR (x)))
	{
	  x = SCM_CAR (x);
	  RETURN (SCM_IMP (x) ? EVALIM (x, env) : SCM_GLOC_VAL (x))
	}

      if (SCM_SYMBOLP (SCM_CAR (x)))
	{
	retval:
	  RETURN (*scm_lookupcar (x, env))
	}

      x = SCM_CAR (x);
      goto loop;		/* tail recurse */


    case (127 & SCM_IM_CASE):
      x = SCM_CDR (x);
      t.arg1 = EVALCAR (x, env);
      while (SCM_NIMP (x = SCM_CDR (x)))
	{
	  proc = SCM_CAR (x);
	  if (scm_i_else == SCM_CAR (proc))
	    {
	      x = SCM_CDR (proc);
	      PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
	      goto begin;
	    }
	  proc = SCM_CAR (proc);
	  while (SCM_NIMP (proc))
	    {
	      if (CHECK_EQVISH (SCM_CAR (proc), t.arg1))
		{
		  x = SCM_CDR (SCM_CAR (x));
		  PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
		  goto begin;
		}
	      proc = SCM_CDR (proc);
	    }
	}
      RETURN (SCM_UNSPECIFIED)


    case (127 & SCM_IM_COND):
      while (SCM_NIMP (x = SCM_CDR (x)))
	{
	  proc = SCM_CAR (x);
	  t.arg1 = EVALCAR (proc, env);
	  if (SCM_NFALSEP (t.arg1))
	    {
	      x = SCM_CDR (proc);
	      if SCM_NULLP (x)
		{
		  RETURN (t.arg1)
		}
	      if (scm_i_arrow != SCM_CAR (x))
		{
		  PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
		  goto begin;
		}
	      proc = SCM_CDR (x);
	      proc = EVALCAR (proc, env);
	      SCM_ASRTGO (SCM_NIMP (proc), badfun);
	      PREP_APPLY (proc, scm_cons (t.arg1, SCM_EOL));
	      ENTER_APPLY;
	      goto evap1;
	    }
	}
      RETURN (SCM_UNSPECIFIED)


    case (127 & SCM_IM_DO):
      x = SCM_CDR (x);
      proc = SCM_CAR (SCM_CDR (x)); /* inits */
      t.arg1 = SCM_EOL;		/* values */
      while (SCM_NIMP (proc))
	{
	  t.arg1 = scm_cons (EVALCAR (proc, env), t.arg1);
	  proc = SCM_CDR (proc);
	}
      env = EXTEND_ENV (SCM_CAR (x), t.arg1, env);
      x = SCM_CDR (SCM_CDR (x));
      while (proc = SCM_CAR (x), SCM_FALSEP (EVALCAR (proc, env)))
	{
	  for (proc = SCM_CAR (SCM_CDR (x)); SCM_NIMP (proc); proc = SCM_CDR (proc))
	    {
	      t.arg1 = SCM_CAR (proc); /* body */
	      SIDEVAL (t.arg1, env);
	    }
	  for (t.arg1 = SCM_EOL, proc = SCM_CDR (SCM_CDR (x)); SCM_NIMP (proc); proc = SCM_CDR (proc))
	    t.arg1 = scm_cons (EVALCAR (proc, env), t.arg1); /* steps */
	  env = EXTEND_ENV (SCM_CAR (SCM_CAR (env)), t.arg1, SCM_CDR (env));
	}
      x = SCM_CDR (proc);
      if (SCM_NULLP (x))
	RETURN (SCM_UNSPECIFIED);
      PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
      goto begin;


    case (127 & SCM_IM_IF):
      x = SCM_CDR (x);
      if (SCM_NFALSEP (EVALCAR (x, env)))
	x = SCM_CDR (x);
      else if (SCM_IMP (x = SCM_CDR (SCM_CDR (x))))
	{
	  RETURN (SCM_UNSPECIFIED);
	}
      PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
      goto carloop;


    case (127 & SCM_IM_LET):
      x = SCM_CDR (x);
      proc = SCM_CAR (SCM_CDR (x));
      t.arg1 = SCM_EOL;
      do
	{
	  t.arg1 = scm_cons (EVALCAR (proc, env), t.arg1);
	}
      while (SCM_NIMP (proc = SCM_CDR (proc)));
      env = EXTEND_ENV (SCM_CAR (x), t.arg1, env);
      x = SCM_CDR (x);
      goto cdrxnoap;


    case (127 & SCM_IM_LETREC):
      x = SCM_CDR (x);
      env = EXTEND_ENV (SCM_CAR (x), scm_undefineds, env);
      x = SCM_CDR (x);
      proc = SCM_CAR (x);
      t.arg1 = SCM_EOL;
      do
	{
	  t.arg1 = scm_cons (EVALCAR (proc, env), t.arg1);
	}
      while (SCM_NIMP (proc = SCM_CDR (proc)));
      SCM_CDR (SCM_CAR (env)) = t.arg1;
      goto cdrxnoap;


    case (127 & SCM_IM_LETSTAR):
      x = SCM_CDR (x);
      proc = SCM_CAR (x);
      if (SCM_IMP (proc))
	{
	  env = EXTEND_ENV (SCM_EOL, SCM_EOL, env);
	  goto cdrxnoap;
	}
      do
	{
	  t.arg1 = SCM_CAR (proc);
	  proc = SCM_CDR (proc);
	  env = EXTEND_ENV (t.arg1, EVALCAR (proc, env), env);
	}
      while (SCM_NIMP (proc = SCM_CDR (proc)));
      goto cdrxnoap;

    case (127 & SCM_IM_OR):
      x = SCM_CDR (x);
      t.arg1 = x;
      while (SCM_NNULLP (t.arg1 = SCM_CDR (t.arg1)))
	{
	  x = EVALCAR (x, env);
	  if (SCM_NFALSEP (x))
	    {
	      RETURN (x);
	    }
	  x = t.arg1;
	}
      PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
      goto carloop;


    case (127 & SCM_IM_LAMBDA):
      RETURN (scm_closure (SCM_CDR (x), env));


    case (127 & SCM_IM_QUOTE):
      RETURN (SCM_CAR (SCM_CDR (x)));


    case (127 & SCM_IM_SET):
      x = SCM_CDR (x);
      proc = SCM_CAR (x);
      switch (7 & (int) proc)
	{
	case 0:
	  t.lloc = scm_lookupcar (x, env);
	  break;
	case 1:
	  t.lloc = &SCM_GLOC_VAL (proc);
	  break;
#ifdef MEMOIZE_LOCALS
	case 4:
	  t.lloc = scm_ilookup (proc, env);
	  break;
#endif
	}
      x = SCM_CDR (x);
      *t.lloc = EVALCAR (x, env);
#ifdef SICP
      RETURN (*t.lloc);
#else
      RETURN (SCM_UNSPECIFIED);
#endif


    case (127 & SCM_IM_DEFINE):	/* only for internal defines */
      x = SCM_CDR (x);
      proc = SCM_CAR (x);
      x = SCM_CDR (x);
      x = evalcar (x, env);
#ifdef DEBUG_EXTENSIONS
      if (SCM_REC_PROCNAMES_P && SCM_NIMP (x) && SCM_CLOSUREP (x))
	scm_set_procedure_property_x (x, scm_i_name, proc);
#endif
      env = SCM_CAR (env);
      SCM_DEFER_INTS;
      SCM_CAR (env) = scm_cons (proc, SCM_CAR (env));
      SCM_CDR (env) = scm_cons (x, SCM_CDR (env));
      SCM_ALLOW_INTS;
      RETURN (SCM_UNSPECIFIED);



      /* new syntactic forms go here. */
    case (127 & SCM_MAKISYM (0)):
      proc = SCM_CAR (x);
      SCM_ASRTGO (SCM_ISYMP (proc), badfun);
      switch SCM_ISYMNUM (proc)
	{
#if 0
	case (SCM_ISYMNUM (IM_VREF)):
	  {
	    SCM var;
	    var = SCM_CAR (SCM_CDR (x));
	    RETURN (SCM_CDR(var));
	  }
	case (SCM_ISYMNUM (IM_VSET)):
	  SCM_CDR (SCM_CAR ( SCM_CDR (x))) = EVALCAR( SCM_CDR ( SCM_CDR (x)), env);
	  SCM_CAR (SCM_CAR ( SCM_CDR (x))) = scm_tc16_variable;
	  RETURN (SCM_UNSPECIFIED)
#endif

	case (SCM_ISYMNUM (SCM_IM_APPLY)):
	  proc = SCM_CDR (x);
	  proc = EVALCAR (proc, env);
	  SCM_ASRTGO (SCM_NIMP (proc), badfun);
	  if (SCM_CLOSUREP (proc))
	    {
	      PREP_APPLY (proc, SCM_EOL);
	      t.arg1 = SCM_CDR (SCM_CDR (x));
	      t.arg1 = EVALCAR (t.arg1, env);
#ifdef DEVAL
	      debug.info->a.args = t.arg1;
#endif
#ifndef RECKLESS
	      if (scm_badargsp (SCM_CAR (SCM_CODE (proc)), t.arg1))
		goto wrongnumargs;
#endif
	      env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)), t.arg1, SCM_ENV (proc));
	      x = SCM_CODE (proc);
	      goto cdrxbegin;
	    }
	  proc = scm_i_apply;
	  goto evapply;

	case (SCM_ISYMNUM (SCM_IM_CONT)):
	  scm_make_cont (&t.arg1);
	  if (setjmp (SCM_JMPBUF (t.arg1)))
	    {
	      SCM val;
	      val = SCM_THROW_VALUE (t.arg1);
	      RETURN (val);
	    }
	  proc = SCM_CDR (x);
	  proc = evalcar (proc, env);
	  SCM_ASRTGO (SCM_NIMP (proc), badfun);
	  PREP_APPLY (proc, scm_cons (t.arg1, SCM_EOL));
	  ENTER_APPLY;
	  goto evap1;

	default:
	  goto badfun;
	}

    default:
      proc = x;
    badfun:
      /* scm_everr (x, env,...) */
      scm_error (scm_misc_error_key,
		 NULL,
		 "Wrong type to apply: %S",
		 scm_listify (proc, SCM_UNDEFINED),
		 SCM_BOOL_F);
    case scm_tc7_vector:
    case scm_tc7_wvect:
    case scm_tc7_bvect:
    case scm_tc7_byvect:
    case scm_tc7_svect:
    case scm_tc7_ivect:
    case scm_tc7_uvect:
    case scm_tc7_fvect:
    case scm_tc7_dvect:
    case scm_tc7_cvect:
#ifdef LONGLONGS
    case scm_tc7_llvect:
#endif
    case scm_tc7_string:
    case scm_tc7_mb_string:
    case scm_tc7_substring:
    case scm_tc7_mb_substring:
    case scm_tc7_smob:
    case scm_tcs_closures:
    case scm_tcs_subrs:
      RETURN (x);

#ifdef MEMOIZE_LOCALS
    case (127 & SCM_ILOC00):
      proc = *scm_ilookup (SCM_CAR (x), env);
      SCM_ASRTGO (SCM_NIMP (proc), badfun);
#ifndef RECKLESS
#ifdef CAUTIOUS
      goto checkargs;
#endif
#endif
      break;
#endif /* ifdef MEMOIZE_LOCALS */


    case scm_tcs_cons_gloc:
      proc = SCM_GLOC_VAL (SCM_CAR (x));
      SCM_ASRTGO (SCM_NIMP (proc), badfun);
#ifndef RECKLESS
#ifdef CAUTIOUS
      goto checkargs;
#endif
#endif
      break;


    case scm_tcs_cons_nimcar:
      if (SCM_SYMBOLP (SCM_CAR (x)))
	{
	  proc = *scm_lookupcar (x, env);
	  if (SCM_IMP (proc))
	    {
	      unmemocar (x, env);
	      goto badfun;
	    }
	  if (scm_tc16_macro == SCM_TYP16 (proc))
	    {
	      unmemocar (x, env);

	    handle_a_macro:
	      t.arg1 = SCM_APPLY (SCM_CDR (proc), x, scm_cons (env, scm_listofnull));
	      switch ((int) (SCM_CAR (proc) >> 16))
		{
		case 2:
		  if (scm_ilength (t.arg1) <= 0)
		    t.arg1 = scm_cons2 (SCM_IM_BEGIN, t.arg1, SCM_EOL);
#ifdef DEVAL
		  if (!SCM_CLOSUREP (SCM_CDR (proc)))
		    {
#if 0 /* Top-level defines doesn't very often occur in backtraces */
		      if (scm_m_define == SCM_SUBRF (SCM_CDR (proc)) && SCM_TOP_LEVEL (env))
			/* Prevent memoizing result of define macro */
			{
			  debug.info->e.exp = scm_cons (SCM_CAR (x), SCM_CDR (x));
			  scm_set_source_properties_x (debug.info->e.exp,
						       scm_source_properties (x));
			}
#endif
		      SCM_DEFER_INTS;
		      SCM_CAR (x) = SCM_CAR (t.arg1);
		      SCM_CDR (x) = SCM_CDR (t.arg1);
		      SCM_ALLOW_INTS;
		      goto dispatch;
		    }
		  /* Prevent memoizing of debug info expression. */
		  debug.info->e.exp = scm_cons (SCM_CAR (x), SCM_CDR (x));
		  scm_set_source_properties_x (debug.info->e.exp,
					       scm_source_properties (x));
#endif
		  SCM_DEFER_INTS;
		  SCM_CAR (x) = SCM_CAR (t.arg1);
		  SCM_CDR (x) = SCM_CDR (t.arg1);
		  SCM_ALLOW_INTS;
		  goto loopnoap;
		case 1:
		  if (SCM_NIMP (x = t.arg1))
		    goto loopnoap;
		case 0:
		  RETURN (t.arg1);
		}
	    }
	}
      else
	proc = SCM_CEVAL (SCM_CAR (x), env);
      SCM_ASRTGO (SCM_NIMP (proc), badfun);
#ifndef RECKLESS
#ifdef CAUTIOUS
    checkargs:
#endif
      if (SCM_CLOSUREP (proc))
	{
	  arg2 = SCM_CAR (SCM_CODE (proc));
	  t.arg1 = SCM_CDR (x);
	  while (SCM_NIMP (arg2))
	    {
	      if (SCM_NCONSP (arg2))
		goto evapply;
	      if (SCM_IMP (t.arg1))
		goto umwrongnumargs;
	      arg2 = SCM_CDR (arg2);
	      t.arg1 = SCM_CDR (t.arg1);
	    }
	  if (SCM_NNULLP (t.arg1))
	    goto umwrongnumargs;
	}
      else if (scm_tc16_macro == SCM_TYP16 (proc))
	goto handle_a_macro;
#endif
    }


evapply:
  PREP_APPLY (proc, SCM_EOL);
  if (SCM_NULLP (SCM_CDR (x))) {
    ENTER_APPLY;
    switch (SCM_TYP7 (proc))
      {				/* no arguments given */
      case scm_tc7_subr_0:
	RETURN (SCM_SUBRF (proc) ());
      case scm_tc7_subr_1o:
	RETURN (SCM_SUBRF (proc) (SCM_UNDEFINED));
      case scm_tc7_lsubr:
	RETURN (SCM_SUBRF (proc) (SCM_EOL));
      case scm_tc7_rpsubr:
	RETURN (SCM_BOOL_T);
      case scm_tc7_asubr:
	RETURN (SCM_SUBRF (proc) (SCM_UNDEFINED, SCM_UNDEFINED));
#ifdef CCLO
      case scm_tc7_cclo:
	t.arg1 = proc;
	proc = SCM_CCLO_SUBR (proc);
#ifdef DEVAL
	debug.info->a.proc = proc;
	debug.info->a.args = scm_cons (t.arg1, SCM_EOL);
#endif
	goto evap1;
#endif
      case scm_tcs_closures:
	x = SCM_CODE (proc);
	env = EXTEND_ENV (SCM_CAR (x), SCM_EOL, SCM_ENV (proc));
	goto cdrxbegin;
      case scm_tc7_contin:
      case scm_tc7_subr_1:
      case scm_tc7_subr_2:
      case scm_tc7_subr_2o:
      case scm_tc7_cxr:
      case scm_tc7_subr_3:
      case scm_tc7_lsubr_2:
      umwrongnumargs:
	unmemocar (x, env);
      wrongnumargs:
	/* scm_everr (x, env,...)  */
	scm_wrong_num_args (proc);
      default:
	/* handle macros here */
	goto badfun;
      }
  }

  /* must handle macros by here */
  x = SCM_CDR (x);
#ifdef CAUTIOUS
  if (SCM_IMP (x))
    goto wrongnumargs;
#endif
  t.arg1 = EVALCAR (x, env);
#ifdef DEVAL
  debug.info->a.args = scm_cons (t.arg1, SCM_EOL);
#endif
  x = SCM_CDR (x);
  if (SCM_NULLP (x))
    {
      ENTER_APPLY;
    evap1:
      switch (SCM_TYP7 (proc))
	{				/* have one argument in t.arg1 */
	case scm_tc7_subr_2o:
	  RETURN (SCM_SUBRF (proc) (t.arg1, SCM_UNDEFINED));
	case scm_tc7_subr_1:
	case scm_tc7_subr_1o:
	  RETURN (SCM_SUBRF (proc) (t.arg1));
	case scm_tc7_cxr:
#ifdef SCM_FLOATS
	  if (SCM_SUBRF (proc))
	    {
	      if (SCM_INUMP (t.arg1))
		{
		  RETURN (scm_makdbl (SCM_DSUBRF (proc) ((double) SCM_INUM (t.arg1)),
				      0.0));
		}
	      SCM_ASRTGO (SCM_NIMP (t.arg1), floerr);
	      if (SCM_REALP (t.arg1))
		{
		  RETURN (scm_makdbl (SCM_DSUBRF (proc) (SCM_REALPART (t.arg1)), 0.0));
		}
#ifdef SCM_BIGDIG
	      if (SCM_BIGP (t.arg1))
		{
		  RETURN (scm_makdbl (SCM_DSUBRF (proc) (scm_big2dbl (t.arg1)), 0.0));
		}
#endif
	    floerr:
	      scm_wta (t.arg1, (char *) SCM_ARG1, SCM_CHARS (SCM_SNAME (proc)));
	    }
#endif
	  proc = (SCM) SCM_SNAME (proc);
	  {
	    char *chrs = SCM_CHARS (proc) + SCM_LENGTH (proc) - 1;
	    while ('c' != *--chrs)
	      {
		SCM_ASSERT (SCM_NIMP (t.arg1) && SCM_CONSP (t.arg1),
			    t.arg1, SCM_ARG1, SCM_CHARS (proc));
		t.arg1 = ('a' == *chrs) ? SCM_CAR (t.arg1) : SCM_CDR (t.arg1);
	      }
	    RETURN (t.arg1);
	  }
	case scm_tc7_rpsubr:
	  RETURN (SCM_BOOL_T);
	case scm_tc7_asubr:
	  RETURN (SCM_SUBRF (proc) (t.arg1, SCM_UNDEFINED));
	case scm_tc7_lsubr:
#ifdef DEVAL
	  RETURN (SCM_SUBRF (proc) (debug.info->a.args))
#else
	  RETURN (SCM_SUBRF (proc) (scm_cons (t.arg1, SCM_EOL)));
#endif
#ifdef CCLO
	case scm_tc7_cclo:
	  arg2 = t.arg1;
	  t.arg1 = proc;
	  proc = SCM_CCLO_SUBR (proc);
#ifdef DEVAL
	  debug.info->a.args = scm_cons (t.arg1, debug.info->a.args);
	  debug.info->a.proc = proc;
#endif
	  goto evap2;
#endif
	case scm_tcs_closures:
	  x = SCM_CODE (proc);
#ifdef DEVAL
	  env = EXTEND_ENV (SCM_CAR (x), debug.info->a.args, SCM_ENV (proc));
#else
	  env = EXTEND_ENV (SCM_CAR (x), scm_cons (t.arg1, SCM_EOL), SCM_ENV (proc));
#endif
	  goto cdrxbegin;
	case scm_tc7_contin:
	  scm_call_continuation (proc, t.arg1);
	case scm_tc7_subr_2:
	case scm_tc7_subr_0:
	case scm_tc7_subr_3:
	case scm_tc7_lsubr_2:
	  goto wrongnumargs;
	default:
	  goto badfun;
	}
    }
#ifdef CAUTIOUS
  if (SCM_IMP (x))
    goto wrongnumargs;
#endif
  {				/* have two or more arguments */
    arg2 = EVALCAR (x, env);
#ifdef DEVAL
    debug.info->a.args = scm_cons2 (t.arg1, arg2, SCM_EOL);
#endif
    x = SCM_CDR (x);
    if (SCM_NULLP (x)) {
      ENTER_APPLY;
#ifdef CCLO
    evap2:
#endif
      switch (SCM_TYP7 (proc))
	{			/* have two arguments */
	case scm_tc7_subr_2:
	case scm_tc7_subr_2o:
	  RETURN (SCM_SUBRF (proc) (t.arg1, arg2));
	case scm_tc7_lsubr:
#ifdef DEVAL
	  RETURN (SCM_SUBRF (proc) (debug.info->a.args))
#else
	  RETURN (SCM_SUBRF (proc) (scm_cons2 (t.arg1, arg2, SCM_EOL)));
#endif
	case scm_tc7_lsubr_2:
	  RETURN (SCM_SUBRF (proc) (t.arg1, arg2, SCM_EOL));
	case scm_tc7_rpsubr:
	case scm_tc7_asubr:
	  RETURN (SCM_SUBRF (proc) (t.arg1, arg2));
#ifdef CCLO
	cclon:
	case scm_tc7_cclo:
#ifdef DEVAL
	  RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc), proc,
			     scm_cons (debug.info->a.args, SCM_EOL)));
#else
	  RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc), proc,
			     scm_cons2 (t.arg1, arg2,
					scm_cons (scm_eval_args (x, env), SCM_EOL))));
#endif
	  /*    case scm_tc7_cclo:
		x = scm_cons(arg2, scm_eval_args(x, env));
		arg2 = t.arg1;
		t.arg1 = proc;
		proc = SCM_CCLO_SUBR(proc);
		goto evap3; */
#endif
	case scm_tc7_subr_0:
	case scm_tc7_cxr:
	case scm_tc7_subr_1o:
	case scm_tc7_subr_1:
	case scm_tc7_subr_3:
	case scm_tc7_contin:
	  goto wrongnumargs;
	default:
	  goto badfun;
	case scm_tcs_closures:
#ifdef DEVAL
	  env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)), debug.info->a.args, SCM_ENV (proc));
#else
	  env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)), scm_cons2 (t.arg1, arg2, SCM_EOL), SCM_ENV (proc));
#endif
	  x = SCM_CODE (proc);
	  goto cdrxbegin;
	}
    }
#ifdef DEVAL
    debug.info->a.args = scm_cons2 (t.arg1, arg2,
	    scm_deval_args (x, env, &SCM_CDR (SCM_CDR (debug.info->a.args))));
#endif
    ENTER_APPLY;
    switch (SCM_TYP7 (proc))
      {			/* have 3 or more arguments */
#ifdef DEVAL
      case scm_tc7_subr_3:
	SCM_ASRTGO (SCM_NULLP (SCM_CDR (x)), wrongnumargs);
	RETURN (SCM_SUBRF (proc) (t.arg1, arg2, SCM_CAR (SCM_CDR (SCM_CDR (debug.info->a.args)))));
      case scm_tc7_asubr:
	/*      t.arg1 = SCM_SUBRF(proc)(t.arg1, arg2);
		while SCM_NIMP(x) {
		t.arg1 = SCM_SUBRF(proc)(t.arg1, EVALCAR(x, env));
		x = SCM_CDR(x);
		}
		RETURN (t.arg1) */
      case scm_tc7_rpsubr:
	RETURN (SCM_APPLY (proc, t.arg1, scm_acons (arg2, SCM_CDR (SCM_CDR (debug.info->a.args)), SCM_EOL)))
	  case scm_tc7_lsubr_2:
	    RETURN (SCM_SUBRF (proc) (t.arg1, arg2, SCM_CDR (SCM_CDR (debug.info->a.args))))
	  case scm_tc7_lsubr:
	    RETURN (SCM_SUBRF (proc) (debug.info->a.args))
#ifdef CCLO
      case scm_tc7_cclo:
	goto cclon;
#endif
      case scm_tcs_closures:
	SCM_SET_ARGSREADY (debug);
	env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)),
			      debug.info->a.args,
			      SCM_ENV (proc));
	x = SCM_CODE (proc);
	goto cdrxbegin;
#else /* DEVAL */
      case scm_tc7_subr_3:
	SCM_ASRTGO (SCM_NULLP (SCM_CDR (x)), wrongnumargs);
	RETURN (SCM_SUBRF (proc) (t.arg1, arg2, EVALCAR (x, env)));
      case scm_tc7_asubr:
	/*      t.arg1 = SCM_SUBRF(proc)(t.arg1, arg2);
		while SCM_NIMP(x) {
		t.arg1 = SCM_SUBRF(proc)(t.arg1, EVALCAR(x, env));
		x = SCM_CDR(x);
		}
		RETURN (t.arg1) */
      case scm_tc7_rpsubr:
	RETURN (SCM_APPLY (proc, t.arg1, scm_acons (arg2, scm_eval_args (x, env), SCM_EOL)));
      case scm_tc7_lsubr_2:
	RETURN (SCM_SUBRF (proc) (t.arg1, arg2, scm_eval_args (x, env)));
      case scm_tc7_lsubr:
	RETURN (SCM_SUBRF (proc) (scm_cons2 (t.arg1, arg2, scm_eval_args (x, env))));
#ifdef CCLO
      case scm_tc7_cclo:
	goto cclon;
#endif
      case scm_tcs_closures:
#ifdef DEVAL
	SCM_SET_ARGSREADY (debug);
#endif
	env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)),
			      scm_cons2 (t.arg1, arg2, scm_eval_args (x, env)),
			      SCM_ENV (proc));
	x = SCM_CODE (proc);
	goto cdrxbegin;
#endif /* DEVAL */
      case scm_tc7_subr_2:
      case scm_tc7_subr_1o:
      case scm_tc7_subr_2o:
      case scm_tc7_subr_0:
      case scm_tc7_cxr:
      case scm_tc7_subr_1:
      case scm_tc7_contin:
	goto wrongnumargs;
      default:
	goto badfun;
      }
  }
#ifdef DEVAL
exit:
  if (CHECK_EXIT)
    if (SCM_EXIT_FRAME_P || (SCM_TRACE_P && SCM_TRACED_FRAME_P (debug)))
      {
	SCM_EXIT_FRAME_P = 0;
	SCM_RESET_DEBUG_MODE;
	SCM_CLEAR_TRACED_FRAME (debug);
	if (SCM_CHEAPTRAPS_P)
	  t.arg1 = scm_make_debugobj ((scm_debug_frame *) &debug);
	else
	  {
	    scm_make_cont (&t.arg1);
	    if (setjmp (SCM_JMPBUF (t.arg1)))
	      {
		proc = SCM_THROW_VALUE (t.arg1);
		goto ret;
	      }
	  }
	scm_ithrow (scm_i_exit_frame, scm_cons2 (t.arg1, proc, SCM_EOL), 0);
      }
ret:
  scm_last_debug_frame = debug.prev;
  return proc;
#endif
}


/* SECTION: This code is compiled once.
 */

#ifndef DEVAL

SCM_PROC(s_procedure_documentation, "procedure-documentation", 1, 0, 0, scm_procedure_documentation);

SCM 
scm_procedure_documentation (proc)
     SCM proc;
{
  SCM code;
  SCM_ASSERT (SCM_BOOL_T == scm_procedure_p (proc) && SCM_NIMP (proc) && SCM_TYP7 (proc) != scm_tc7_contin,
	  proc, SCM_ARG1, s_procedure_documentation);
  switch (SCM_TYP7 (proc))
    {
    case scm_tcs_closures:
      code = SCM_CDR (SCM_CODE (proc));
      if (SCM_IMP (SCM_CDR (code)))
	return SCM_BOOL_F;
      code = SCM_CAR (code);
      if (SCM_IMP (code))
	return SCM_BOOL_F;
      if (SCM_STRINGP (code))
	return code;
    default:
      return SCM_BOOL_F;
/*
  case scm_tcs_subrs:
#ifdef CCLO
  case scm_tc7_cclo:
#endif
*/
    }
}

/* This code processes the 'arg ...' parameters to apply.

   (apply PROC ARG1 ... ARGS)

   The ARG1 ... arguments are consed on to the front of ARGS (which
   must be a list), and then PROC is applied to the elements of the
   result.  apply:nconc2last takes care of building the list of
   arguments, given (ARG1 ... ARGS).

   apply:nconc2last destroys its argument.  On that topic, this code
   came into my care with the following beautifully cryptic comment on
   that topic: "This will only screw you if you do (scm_apply
   scm_apply '( ... ))"  If you know what they're referring to, send
   me a patch to this comment.  */

SCM_PROC(s_nconc2last, "apply:nconc2last", 1, 0, 0, scm_nconc2last);

SCM 
scm_nconc2last (lst)
     SCM lst;
{
  SCM *lloc;
  SCM_ASSERT (scm_ilength (lst) > 0, lst, SCM_ARG1, s_nconc2last);
  lloc = &lst;
  while (SCM_NNULLP (SCM_CDR (*lloc)))
    lloc = &SCM_CDR (*lloc);
  SCM_ASSERT (scm_ilength (SCM_CAR (*lloc)) >= 0, lst, SCM_ARG1, s_nconc2last);
  *lloc = SCM_CAR (*lloc);
  return lst;
}

#endif /* !DEVAL */


/* SECTION: When DEVAL is defined this code yields scm_dapply.
 * It is compiled twice.
 */

#if 0

SCM 
scm_apply (proc, arg1, args)
     SCM proc;
     SCM arg1;
     SCM args;
{}
#endif

#if 0

SCM 
scm_dapply (proc, arg1, args)
     SCM proc;
     SCM arg1;
     SCM args;
{}
#endif


SCM 
SCM_APPLY (proc, arg1, args)
     SCM proc;
     SCM arg1;
     SCM args;
{
#ifdef DEBUG_EXTENSIONS
#ifdef DEVAL
  scm_debug_frame debug;
  debug.prev = scm_last_debug_frame;
  debug.status = SCM_APPLYFRAME;
  debug.vect[0].a.proc = proc;
  debug.vect[0].a.args = SCM_EOL;
  scm_last_debug_frame = &debug;
#else
  if (SCM_DEBUGGINGP)
    return scm_dapply (proc, arg1, args);
#endif
#endif

  SCM_ASRTGO (SCM_NIMP (proc), badproc);
  if (SCM_NULLP (args))
    {
      if (SCM_NULLP (arg1))
	arg1 = SCM_UNDEFINED;
      else
	{
	  args = SCM_CDR (arg1);
	  arg1 = SCM_CAR (arg1);
	}
    }
  else
    {
      /*		SCM_ASRTGO(SCM_NIMP(args) && SCM_CONSP(args), wrongnumargs); */
      args = scm_nconc2last (args);
    }
#ifdef DEVAL
  debug.vect[0].a.args = scm_cons (arg1, args);
  if (SCM_ENTER_FRAME_P)
    {
      SCM tmp;
      SCM_ENTER_FRAME_P = 0;
      SCM_RESET_DEBUG_MODE;
      if (SCM_CHEAPTRAPS_P)
	tmp = scm_make_debugobj ((scm_debug_frame *) &debug);
      else
	{
	  scm_make_cont (&tmp);
	  if (setjmp (SCM_JMPBUF (tmp)))
	    goto entap;
	}
      scm_ithrow (scm_i_enter_frame, scm_cons (tmp, SCM_EOL), 0);
    }
entap:
  ENTER_APPLY;
#endif
#ifdef CCLO
tail:
#endif
  switch (SCM_TYP7 (proc))
    {
    case scm_tc7_subr_2o:
      args = SCM_NULLP (args) ? SCM_UNDEFINED : SCM_CAR (args);
      RETURN (SCM_SUBRF (proc) (arg1, args))
    case scm_tc7_subr_2:
      SCM_ASRTGO (SCM_NULLP (SCM_CDR (args)), wrongnumargs);
      args = SCM_CAR (args);
      RETURN (SCM_SUBRF (proc) (arg1, args))
    case scm_tc7_subr_0:
      SCM_ASRTGO (SCM_UNBNDP (arg1), wrongnumargs);
      RETURN (SCM_SUBRF (proc) ())
    case scm_tc7_subr_1:
    case scm_tc7_subr_1o:
      SCM_ASRTGO (SCM_NULLP (args), wrongnumargs);
      RETURN (SCM_SUBRF (proc) (arg1))
    case scm_tc7_cxr:
      SCM_ASRTGO (SCM_NULLP (args), wrongnumargs);
#ifdef SCM_FLOATS
      if (SCM_SUBRF (proc))
	{
	  if (SCM_INUMP (arg1))
	    {
	      RETURN (scm_makdbl (SCM_DSUBRF (proc) ((double) SCM_INUM (arg1)), 0.0));
	    }
	  SCM_ASRTGO (SCM_NIMP (arg1), floerr);
	  if (SCM_REALP (arg1))
	    {
	      RETURN (scm_makdbl (SCM_DSUBRF (proc) (SCM_REALPART (arg1)), 0.0));
	    }
#ifdef SCM_BIGDIG
	  if SCM_BIGP
	    (arg1)
	      RETURN (scm_makdbl (SCM_DSUBRF (proc) (scm_big2dbl (arg1)), 0.0))
#endif
	floerr:
	  scm_wta (arg1, (char *) SCM_ARG1, SCM_CHARS (SCM_SNAME (proc)));
	}
#endif
      proc = (SCM) SCM_SNAME (proc);
      {
	char *chrs = SCM_CHARS (proc) + SCM_LENGTH (proc) - 1;
	while ('c' != *--chrs)
	  {
	    SCM_ASSERT (SCM_NIMP (arg1) && SCM_CONSP (arg1),
		    arg1, SCM_ARG1, SCM_CHARS (proc));
	    arg1 = ('a' == *chrs) ? SCM_CAR (arg1) : SCM_CDR (arg1);
	  }
	RETURN (arg1)
      }
    case scm_tc7_subr_3:
      RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CAR (SCM_CDR (args))))
    case scm_tc7_lsubr:
#ifdef DEVAL
      RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : debug.vect[0].a.args))
#else
      RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : scm_cons (arg1, args)))
#endif
    case scm_tc7_lsubr_2:
      SCM_ASRTGO (SCM_NIMP (args) && SCM_CONSP (args), wrongnumargs);
      RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CDR (args)))
    case scm_tc7_asubr:
      if (SCM_NULLP (args))
	RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED))
      while (SCM_NIMP (args))
	{
	  SCM_ASSERT (SCM_CONSP (args), args, SCM_ARG2, "apply");
	  arg1 = SCM_SUBRF (proc) (arg1, SCM_CAR (args));
	  args = SCM_CDR (args);
	}
      RETURN (arg1);
    case scm_tc7_rpsubr:
      if (SCM_NULLP (args))
	RETURN (SCM_BOOL_T);
      while (SCM_NIMP (args))
	{
	  SCM_ASSERT (SCM_CONSP (args), args, SCM_ARG2, "apply");
	  if (SCM_FALSEP (SCM_SUBRF (proc) (arg1, SCM_CAR (args))))
	    RETURN (SCM_BOOL_F);
	  arg1 = SCM_CAR (args);
	  args = SCM_CDR (args);
	}
      RETURN (SCM_BOOL_T);
    case scm_tcs_closures:
#ifdef DEVAL
      arg1 = (SCM_UNBNDP (arg1) ? SCM_EOL : debug.vect[0].a.args);
#else
      arg1 = (SCM_UNBNDP (arg1) ? SCM_EOL : scm_cons (arg1, args));
#endif
#ifndef RECKLESS
      if (scm_badargsp (SCM_CAR (SCM_CODE (proc)), arg1))
	goto wrongnumargs;
#endif
      args = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)), arg1, SCM_ENV (proc));
      proc = SCM_CODE (proc);
      while (SCM_NNULLP (proc = SCM_CDR (proc)))
	arg1 = EVALCAR (proc, args);
      RETURN (arg1);
    case scm_tc7_contin:
      SCM_ASRTGO (SCM_NULLP (args), wrongnumargs);
      scm_call_continuation (proc, arg1);
#ifdef CCLO
    case scm_tc7_cclo:
#ifdef DEVAL
      args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args);
      arg1 = proc;
      proc = SCM_CCLO_SUBR (proc);
      debug.vect[0].a.proc = proc;
      debug.vect[0].a.args = scm_cons (arg1, args);
#else
      args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args));
      arg1 = proc;
      proc = SCM_CCLO_SUBR (proc);
#endif
      goto tail;
#endif
    wrongnumargs:
      scm_wrong_num_args (proc);
    default:
    badproc:
      scm_wta (proc, (char *) SCM_ARG1, "apply");
      RETURN (arg1);
    }
#ifdef DEVAL
exit:
  if (CHECK_EXIT)
    if (SCM_EXIT_FRAME_P || (SCM_TRACE_P && SCM_TRACED_FRAME_P (debug)))
      {
	SCM_EXIT_FRAME_P = 0;
	SCM_RESET_DEBUG_MODE;
	SCM_CLEAR_TRACED_FRAME (debug);
	if (SCM_CHEAPTRAPS_P)
	  arg1 = scm_make_debugobj ((scm_debug_frame *) &debug);
	else
	  {
	    scm_make_cont (&arg1);
	    if (setjmp (SCM_JMPBUF (arg1)))
	      {
		proc = SCM_THROW_VALUE (arg1);
		goto ret;
	      }
	  }
	scm_ithrow (scm_i_exit_frame, scm_cons2 (arg1, proc, SCM_EOL), 0);
      }
ret:
  scm_last_debug_frame = debug.prev;
  return proc;
#endif
}


/* SECTION: The rest of this file is only read once.
 */

#ifndef DEVAL

SCM_PROC(s_map, "map", 2, 0, 1, scm_map);

SCM 
scm_map (proc, arg1, args)
     SCM proc;
     SCM arg1;
     SCM args;
{
  long i;
  SCM res = SCM_EOL;
  SCM *pres = &res;
  SCM *ve = &args;		/* Keep args from being optimized away. */

  if (SCM_NULLP (arg1))
    return res;
  SCM_ASSERT (SCM_NIMP (arg1), arg1, SCM_ARG2, s_map);
  if (SCM_NULLP (args))
    {
      while (SCM_NIMP (arg1))
	{
	  SCM_ASSERT (SCM_CONSP (arg1), arg1, SCM_ARG2, s_map);
	  *pres = scm_cons (scm_apply (proc, SCM_CAR (arg1), scm_listofnull), SCM_EOL);
	  pres = &SCM_CDR (*pres);
	  arg1 = SCM_CDR (arg1);
	}
      return res;
    }
  args = scm_vector (scm_cons (arg1, args));
  ve = SCM_VELTS (args);
#ifndef RECKLESS
  for (i = SCM_LENGTH (args) - 1; i >= 0; i--)
    SCM_ASSERT (SCM_NIMP (ve[i]) && SCM_CONSP (ve[i]), args, SCM_ARG2, s_map);
#endif
  while (1)
    {
      arg1 = SCM_EOL;
      for (i = SCM_LENGTH (args) - 1; i >= 0; i--)
	{
	  if SCM_IMP
	    (ve[i]) return res;
	  arg1 = scm_cons (SCM_CAR (ve[i]), arg1);
	  ve[i] = SCM_CDR (ve[i]);
	}
      *pres = scm_cons (scm_apply (proc, arg1, SCM_EOL), SCM_EOL);
      pres = &SCM_CDR (*pres);
    }
}


SCM_PROC(s_for_each, "for-each", 2, 0, 1, scm_for_each);

SCM 
scm_for_each (proc, arg1, args)
     SCM proc;
     SCM arg1;
     SCM args;
{
  SCM *ve = &args;		/* Keep args from being optimized away. */
  long i;
  if SCM_NULLP (arg1)
    return SCM_UNSPECIFIED;
  SCM_ASSERT (SCM_NIMP (arg1), arg1, SCM_ARG2, s_for_each);
  if SCM_NULLP (args)
    {
      while SCM_NIMP (arg1)
	{
	  SCM_ASSERT (SCM_CONSP (arg1), arg1, SCM_ARG2, s_for_each);
	  scm_apply (proc, SCM_CAR (arg1), scm_listofnull);
	  arg1 = SCM_CDR (arg1);
	}
      return SCM_UNSPECIFIED;
    }
  args = scm_vector (scm_cons (arg1, args));
  ve = SCM_VELTS (args);
#ifndef RECKLESS
  for (i = SCM_LENGTH (args) - 1; i >= 0; i--)
    SCM_ASSERT (SCM_NIMP (ve[i]) && SCM_CONSP (ve[i]), args, SCM_ARG2, s_for_each);
#endif
  while (1)
    {
      arg1 = SCM_EOL;
      for (i = SCM_LENGTH (args) - 1; i >= 0; i--)
	{
	  if SCM_IMP
	    (ve[i]) return SCM_UNSPECIFIED;
	  arg1 = scm_cons (SCM_CAR (ve[i]), arg1);
	  ve[i] = SCM_CDR (ve[i]);
	}
      scm_apply (proc, arg1, SCM_EOL);
    }
}



SCM 
scm_closure (code, env)
     SCM code;
     SCM env;
{
  register SCM z;
  SCM_NEWCELL (z);
  SCM_SETCODE (z, code);
  SCM_ENV (z) = env;
  return z;
}


long scm_tc16_promise;

SCM 
scm_makprom (code)
     SCM code;
{
  register SCM z;
  SCM_NEWCELL (z);
  SCM_CDR (z) = code;
  SCM_CAR (z) = scm_tc16_promise;
  return z;
}



static int  prinprom SCM_P ((SCM exp, SCM port, scm_print_state *pstate));

static int 
prinprom (exp, port, pstate)
     SCM exp;
     SCM port;
     scm_print_state *pstate;
{
  int writingp = SCM_WRITINGP (pstate);
  scm_gen_puts (scm_regular_string, "#<promise ", port);
  SCM_SET_WRITINGP (pstate, 1);
  scm_iprin1 (SCM_CDR (exp), port, pstate);
  SCM_SET_WRITINGP (pstate, writingp);
  scm_gen_putc ('>', port);
  return !0;
}


SCM_PROC(s_makacro, "procedure->syntax", 1, 0, 0, scm_makacro);

SCM 
scm_makacro (code)
     SCM code;
{
  register SCM z;
  SCM_NEWCELL (z);
  SCM_CDR (z) = code;
  SCM_CAR (z) = scm_tc16_macro;
  return z;
}


SCM_PROC(s_makmacro, "procedure->macro", 1, 0, 0, scm_makmacro);

SCM 
scm_makmacro (code)
     SCM code;
{
  register SCM z;
  SCM_NEWCELL (z);
  SCM_CDR (z) = code;
  SCM_CAR (z) = scm_tc16_macro | (1L << 16);
  return z;
}


SCM_PROC(s_makmmacro, "procedure->memoizing-macro", 1, 0, 0, scm_makmmacro);

SCM 
scm_makmmacro (code)
     SCM code;
{
  register SCM z;
  SCM_NEWCELL (z);
  SCM_CDR (z) = code;
  SCM_CAR (z) = scm_tc16_macro | (2L << 16);
  return z;
}



static int  prinmacro SCM_P ((SCM exp, SCM port, scm_print_state *pstate));

static int 
prinmacro (exp, port, pstate)
     SCM exp;
     SCM port;
     scm_print_state *pstate;
{
  int writingp = SCM_WRITINGP (pstate);
  if (SCM_CAR (exp) & (3L << 16))
    scm_gen_puts (scm_regular_string, "#<macro", port);
  else
    scm_gen_puts (scm_regular_string, "#<syntax", port);
  if (SCM_CAR (exp) & (2L << 16))
    scm_gen_putc ('!', port);
  scm_gen_putc (' ', port);
  SCM_SET_WRITINGP (pstate, 1);
  scm_iprin1 (SCM_CDR (exp), port, pstate);
  SCM_SET_WRITINGP (pstate, writingp);
  scm_gen_putc ('>', port);
  return !0;
}

SCM_PROC(s_force, "force", 1, 0, 0, scm_force);

SCM 
scm_force (x)
     SCM x;
{
  SCM_ASSERT ((SCM_TYP16 (x) == scm_tc16_promise), x, SCM_ARG1, s_force);
  if (!((1L << 16) & SCM_CAR (x)))
    {
      SCM ans = scm_apply (SCM_CDR (x), SCM_EOL, SCM_EOL);
      if (!((1L << 16) & SCM_CAR (x)))
	{
	  SCM_DEFER_INTS;
	  SCM_CDR (x) = ans;
	  SCM_CAR (x) |= (1L << 16);
	  SCM_ALLOW_INTS;
	}
    }
  return SCM_CDR (x);
}

SCM_PROC (s_promise_p, "promise?", 1, 0, 0, scm_promise_p);

SCM
scm_promise_p (x)
     SCM x;
{
  return ((SCM_NIMP (x) && (SCM_TYP16 (x) == scm_tc16_promise))
	   ? SCM_BOOL_T
	   : SCM_BOOL_F);
}

SCM_PROC(s_copy_tree, "copy-tree", 1, 0, 0, scm_copy_tree);

SCM 
scm_copy_tree (obj)
     SCM obj;
{
  SCM ans, tl;
  if SCM_IMP
    (obj) return obj;
  if (SCM_VECTORP (obj))
    {
      scm_sizet i = SCM_LENGTH (obj);
      ans = scm_make_vector (SCM_MAKINUM (i), SCM_UNSPECIFIED, SCM_UNDEFINED);
      while (i--)
	SCM_VELTS (ans)[i] = scm_copy_tree (SCM_VELTS (obj)[i]);
      return ans;
    }
  if SCM_NCONSP (obj)
    return obj;
/*  return scm_cons(scm_copy_tree(SCM_CAR(obj)), scm_copy_tree(SCM_CDR(obj))); */
  ans = tl = scm_cons (scm_copy_tree (SCM_CAR (obj)), SCM_UNSPECIFIED);
  while (SCM_NIMP (obj = SCM_CDR (obj)) && SCM_CONSP (obj))
    tl = (SCM_CDR (tl) = scm_cons (scm_copy_tree (SCM_CAR (obj)), SCM_UNSPECIFIED));
  SCM_CDR (tl) = obj;
  return ans;
}


SCM 
scm_eval_3 (obj, copyp, env)
     SCM obj;
     int copyp;
     SCM env;
{
  if (SCM_NIMP (SCM_CDR (scm_system_transformer)))
    obj = scm_apply (SCM_CDR (scm_system_transformer), obj, scm_listofnull);
  else if (copyp)
    obj = scm_copy_tree (obj);
  return XEVAL (obj, env);
}


SCM
scm_top_level_env (thunk)
     SCM thunk;
{
  if (SCM_IMP(thunk))
    return SCM_EOL;
  else
    return scm_cons(thunk, (SCM)SCM_EOL);
}

SCM_PROC(s_eval2, "eval2", 2, 0, 0, scm_eval2);

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

SCM_PROC(s_eval, "eval", 1, 0, 0, scm_eval);

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

SCM_PROC(s_eval_x, "eval!", 1, 0, 0, scm_eval_x);

SCM
scm_eval_x (obj)
     SCM obj;
{
  return
    scm_eval_3(obj,
	       0,
	       scm_top_level_env (SCM_CDR (scm_top_level_lookup_thunk_var)));
}

SCM_PROC (s_macro_eval_x, "macro-eval!", 2, 0, 0, scm_macro_eval_x);

SCM
scm_macro_eval_x (exp, env)
     SCM exp;
     SCM env;
{
  return scm_eval_3 (exp, 0, env);
}


SCM 
scm_definedp (x, env)
     SCM x;
     SCM env;
{
  SCM proc = SCM_CAR (x = SCM_CDR (x));
  if (SCM_ISYMP (proc))
    return SCM_BOOL_T;
  else if(SCM_IMP(proc) || !SCM_SYMBOLP(proc))
    return SCM_BOOL_F;
  else
    {
      SCM vcell = scm_sym2vcell(proc, env_top_level(env), SCM_BOOL_F);
      return (vcell == SCM_BOOL_F || SCM_UNBNDP(SCM_CDR(vcell))) ? SCM_BOOL_F : SCM_BOOL_T;
    }
}

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 = ((((SCM_CELLPTR) (SCM_CAR (symcell))) - scm_heap_org) << 8);
  register SCM z;
  if ((tmp >> 8) != ((SCM_CELLPTR) (SCM_CAR (symcell)) - scm_heap_org))
    tmp = 0;
  SCM_NEWCELL (z);
  SCM_SUBRF (z) = fcn;
  SCM_CAR (z) = tmp + scm_tc7_subr_2;
  SCM_CDR (symcell) = macroizer (z);
  return SCM_CAR (symcell);
}


/* At this point, scm_deval and scm_dapply are generated.
 */

#ifdef DEBUG_EXTENSIONS
# define DEVAL
# include "eval.c"
#endif



void 
scm_init_eval ()
{
  scm_tc16_promise = scm_newsmob (&promsmob);
  scm_tc16_macro = scm_newsmob (&macrosmob);
  scm_i_apply = scm_make_subr ("apply", scm_tc7_lsubr_2, scm_apply);
  scm_system_transformer = scm_sysintern ("scm:eval-transformer", SCM_UNDEFINED);
  scm_i_dot = SCM_CAR (scm_sysintern (".", SCM_UNDEFINED));
  scm_i_arrow = SCM_CAR (scm_sysintern ("=>", SCM_UNDEFINED));
  scm_i_else = SCM_CAR (scm_sysintern ("else", SCM_UNDEFINED));
  scm_i_unquote = SCM_CAR (scm_sysintern ("unquote", SCM_UNDEFINED));
  scm_i_uq_splicing = SCM_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_undefine, scm_makacro, scm_m_undefine);
  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*", SCM_BOOL_F);

  scm_i_and = scm_make_synt ("and", scm_makmmacro, scm_m_and);
  scm_i_begin = scm_make_synt ("begin", scm_makmmacro, scm_m_begin);
  scm_i_case = scm_make_synt ("case", scm_makmmacro, scm_m_case);
  scm_i_cond = scm_make_synt ("cond", scm_makmmacro, scm_m_cond);
  scm_i_define = scm_make_synt ("define", scm_makmmacro, scm_m_define);
  scm_i_do = scm_make_synt ("do", scm_makmmacro, scm_m_do);
  scm_i_if = scm_make_synt ("if", scm_makmmacro, scm_m_if);
  scm_i_lambda = scm_make_synt ("lambda", scm_makmmacro, scm_m_lambda);
  scm_i_let = scm_make_synt ("let", scm_makmmacro, scm_m_let);
  scm_i_letrec = scm_make_synt ("letrec", scm_makmmacro, scm_m_letrec);
  scm_i_letstar = scm_make_synt ("let*", scm_makmmacro, scm_m_letstar);
  scm_i_or = scm_make_synt ("or", scm_makmmacro, scm_m_or);
  scm_i_quote = scm_make_synt ("quote", scm_makmmacro, scm_m_quote);
  scm_i_set = scm_make_synt ("set!", scm_makmmacro, scm_m_set);
  scm_i_atapply = scm_make_synt ("@apply", scm_makmmacro, scm_m_apply);
  scm_i_atcall_cc = scm_make_synt ("@call-with-current-continuation",
				   scm_makmmacro, scm_m_cont);

  scm_make_synt ("defined?", scm_makmmacro, scm_definedp);
  scm_i_name = SCM_CAR (scm_sysintern ("name", SCM_UNDEFINED));
  scm_permanent_object (scm_i_name);

#ifdef DEBUG_EXTENSIONS
  scm_i_enter_frame = SCM_CAR (scm_sysintern ("enter-frame", SCM_UNDEFINED));
  scm_i_apply_frame = SCM_CAR (scm_sysintern ("apply-frame", SCM_UNDEFINED));
  scm_i_exit_frame = SCM_CAR (scm_sysintern ("exit-frame", SCM_UNDEFINED));
  scm_i_trace = SCM_CAR (scm_sysintern ("trace", SCM_UNDEFINED));
#endif

#include "eval.x"
}

#endif /* !DEVAL */