/* libsizzle/eval.c - evaluator
 
  Copyright (C) 1999, 2000 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
 
  This 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 software 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 package; see the file COPYING.  If not, write to
  the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  Boston, MA 02111-1307, USA.  */

#if HAVE_CONFIG_H
# include <config.h>
#endif 

/*  #define ENABLE_TRACE 1 */

#include <assert.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <signal.h>
#include <fcntl.h>
#if HAVE_UNISTD_H
# include <unistd.h>
#endif
#if HAVE_TIMES
#include <sys/times.h>
#endif
#ifdef __MINGW32__
# include <io.h>
#endif

#if ENABLE_NLS
# include <libintl.h>
# define _(String) gettext(String)
#else
# define _(String) (String)
#endif

#include "alloc.h"
#include "node.h"
#include "vector.h"
#include "promise.h"
#include "values.h"
#include "read.h"
#include "list.h"
#include "fdport.h"
#include "port.h"
#include "iofun.h"
#include "sport.h"
#include "cvar.h"
#include "capi.h"
#include "macros.h"
#include "modules.h"
#include "syntax.h"
#include "profile.h"
#include "eval.h"
#include "validate.h"

#ifndef O_BINARY
# define O_BINARY 0
#endif

/* This constant limits the depth of recursive calls to the evaluation
   function.  The value may seem small, but remember that Scheme
   properly handles tail recursions.  */
#define MAX_EVALUATE_STACK 100000

/* Non-zero if Sizzle is in interactive mode.  */
int zzz_interaction_mode;

/* This is set to true once the hint for evaluating (backtrace) after
   an exception is given.  Only annoy the user on the first exception.  */
static int eval_backtrace_hint_given;

/* This is set to true once the hint for evaluating (set!
   eval-save-backtrace #t) after an exception is given.  Only annoy the
   user on the first exception.  */
static int eval_save_backtrace_hint_given;

/* On exceptions, the backtrace is saved to this variable.  */
static zzz_scm_t error_backtrace;

/* On exceptions, the expression causing the exception is held here.  */
static zzz_scm_t error_expression;

/* The maximum value for the evaluation nesting.  Accessible via the
   Scheme variable @var{%max-evaluate-stack%}.  */
static int max_evaluate_stack;

/* The number of clock ticks the last top-level evaluation took.
   Accessible via the Scheme variable @var{%eval-time-taken%}.  */
int zzz_eval_time_taken;

/* If true, all data is written to the output port before evaluating.
   For debugging, may be accessed with the Scheme variable
   @var{%print-read%}.  */
static int eval_print_read;

/* If true, evaluation results are printed on the output port even in
   non-interactive mode.  For debugging, may be accessed with the Scheme
   variable @var{%print-result%}.  */
static int eval_print_result;

/* If true, Sizzle saves a procedure backtrace when evaluating
   expressions.  For debugging, may be accessed with the Scheme
   variable `%save-backtrace%'.  */
static int eval_save_backtrace;

/* If true, a backtrace is printed immediately after an exception returned
   to the top-level repl.  This variable is bound to the scheme
   variable @var{%print-backtrace%}.  */
static int eval_print_backtrace;

/* The number of entries in the backtrace to show.  May be set with
   the Scheme variable @var{%print-backtrace-limit}'.  */
static int eval_print_backtrace_limit;

/* Set to 1 in the signal handler for SIGINT. Must be checked
   regularly (by call to ZZZ_TICK() for example) in order to notice
   the interrupt.  */
int zzz_interrupt_requested;

/* If session transcription is turned on with @code{transcript-on},
   this is the port to which the transcript is written.  */
static zzz_scm_t zzz_transcript_port;

/* Thrown when evaluation stack usage exceeds
   @var{%max-evaluate-nesting%}.  */
static zzz_scm_t stack_overflow_exception;

/* Thrown when a procedure application with a wrong number of
   arguments is encountered.  */
static zzz_scm_t wrong_number_args_exception;

/* Thrown when a procedure is called with an argument of the wrong
   type.  */
static zzz_scm_t wrong_type_argument_exception;

/* Thrown when a miscalleneous error happens.  */
static zzz_scm_t misc_error_exception;



/* Forward declarations.  */
static result_t transcript_off_func (zzz_scm_t env, zzz_scm_t * result);
static result_t zzz_evaluate_car(zzz_scm_t env, zzz_scm_t expr,
				 zzz_scm_t * result);

zzz_scm_t
zzz_make_wna_exception (zzz_scm_t args)
{
  return zzz_make_exception (wrong_number_args_exception, args);
}

zzz_scm_t
zzz_make_wta_exception (zzz_scm_t args)
{
  return zzz_make_exception (wrong_type_argument_exception, args);
}

zzz_scm_t
zzz_make_misc_error_exception (zzz_scm_t args)
{
  return zzz_make_exception (misc_error_exception, args);
}

/* If the car of @var{expr} is a symbol, try to replace it with a lloc
   or gloc object.  If not possible, leave @var{expr} unmodified.  */
void
zzz_memoize_car (zzz_scm_t env, zzz_scm_t expr)
{
  if (symbol_p (car (expr)))
    set_car (expr, zzz_get_variable_location (env, car (expr)));
}

/* Evaluate the car of @var{expr}, and return the result in the
   location pointed to by @var{result}.  On error, return an error
   code other than @code{RESULT_SUCCESS} and store an error object in
   the location pointed to by @var{result}.  If possible and it is a
   symbol, try to replace the car of @var{expr} with a more efficient
   object (e.g. an lloc or gloc object).  */
static result_t 
zzz_evaluate_car(zzz_scm_t env, zzz_scm_t expr, zzz_scm_t * result)
{
  zzz_scm_t proc;
  result_t err;

  proc = car (expr);
  if (symbol_p (proc))
    {
      proc = zzz_get_variable_location (env, car (expr));
      set_car (expr, proc);

    }
  if (lloc_p (proc))
    {
      zzz_signed_object_t env_ofs = fixnum_val (lloc_env (proc));
      zzz_signed_object_t offset = fixnum_val (lloc_slot (proc));
      zzz_scm_t c;
      
      while (env_ofs-- > 0)
	env = env_link (env);
      c = env_val (env);
      while (offset-- > 0)
	c = cdr (c);
      *result = cdr (car (c));
      PROFILE_COUNT(zzz_lloc_accesses);
      return RESULT_SUCCESS;
    } 
  else if (gloc_p (proc))
    {
      *result = *gloc_val (proc);
      PROFILE_COUNT(zzz_gloc_accesses);
      return RESULT_SUCCESS;
    } 
  if ((err = zzz_evaluate (env, car (expr), result)) != RESULT_SUCCESS)
    return err;
  return RESULT_SUCCESS;
}

/* Given a list of cells, @var{expr_list}, evaluate each of the list
  members and return a list of the evaluation results in
  @code{result_list}.  Return @code{RESULT_SUCCESS} on success and an
  error code on failure.  */
static result_t
evaluate_list (zzz_scm_t env, zzz_scm_t expr_list, zzz_scm_t * result_list)
{
  result_t err;
  zzz_scm_t param = NULL;
  zzz_scm_t * pp = &param;
  zzz_scm_t res;

  while (cons_p (expr_list))
    {
      if ((err = zzz_evaluate_car (env, expr_list, &res)) != RESULT_SUCCESS)
	{
	  *result_list = res;
	  return err;
	}
      *pp = zzz_cons (res, NULL);
      pp = cdr_addr (*pp);
      expr_list = cdr (expr_list);
    }
  *result_list = param;
  return RESULT_SUCCESS;
}

/* The following two macros will check that the given condition holds,
   or otherwise return from the current function with an error about
   wrong number of arguments.  */
#define FEW_ARGS(cond, func)						\
  do									\
   {									\
     if (!(cond))							\
       {								\
	 *result = zzz_make_wna_exception				\
	   (zzz_make_list						\
	    (zzz_make_ro_string (zzz_too_few_arguments, -1),		\
	     func_name (func),						\
	     zzz_make_string ("'", -1),					\
	     NULL));							\
	 return RESULT_EXCEPTION;					\
       }								\
   }									\
  while (0)
	
#define MANY_ARGS(cond, func)						 \
  do									 \
   {									 \
     if (!(cond))							 \
       {								 \
	 *result = zzz_make_wna_exception				 \
	   (zzz_make_list						 \
	    (zzz_make_ro_string (zzz_too_many_arguments, -1),		 \
	     func_name (func),						 \
	     zzz_make_string ("'", -1),					 \
	     NULL));							 \
	 return RESULT_EXCEPTION;					 \
       }								 \
   }									 \
  while (0)

/* These typedefs are used to cast function pointers to the correct
   type before calling.  */
typedef result_t (* func_0_0_1) (zzz_scm_t env, zzz_scm_t param_list,
				 zzz_scm_t * result);
typedef result_t (* func_0_0_0) (zzz_scm_t env, zzz_scm_t * result);
typedef result_t (* func_1_0_0) (zzz_scm_t env, zzz_scm_t param0,
				 zzz_scm_t * result);
typedef result_t (* func_2_0_0) (zzz_scm_t env, zzz_scm_t param0,
				 zzz_scm_t param1, zzz_scm_t * result);
typedef result_t (* func_3_0_0) (zzz_scm_t env, zzz_scm_t param0,
				 zzz_scm_t param1, zzz_scm_t param2,
				 zzz_scm_t * result);
typedef result_t (* func_4_0_0) (zzz_scm_t env, zzz_scm_t param0,
				 zzz_scm_t param1, zzz_scm_t param2,
				 zzz_scm_t param3, zzz_scm_t * result);
typedef result_t (* func_5_0_0) (zzz_scm_t env, zzz_scm_t param0,
				 zzz_scm_t param1, zzz_scm_t param2,
				 zzz_scm_t param3, zzz_scm_t param4,
				 zzz_scm_t * result);
typedef result_t (* func_0_1_0) (zzz_scm_t env, zzz_scm_t param0,
				 zzz_scm_t * result);
typedef result_t (* func_1_1_0) (zzz_scm_t env, zzz_scm_t param0,
				 zzz_scm_t param1, zzz_scm_t * result);
typedef result_t (* func_2_1_0) (zzz_scm_t env, zzz_scm_t param0,
				 zzz_scm_t param1, zzz_scm_t param2,
				 zzz_scm_t * result);
typedef result_t (* func_1_0_1) (zzz_scm_t env, zzz_scm_t param0,
				 zzz_scm_t rest, zzz_scm_t * result);
typedef result_t (* func_3_3_0) (zzz_scm_t env, zzz_scm_t param0,
				 zzz_scm_t param1, zzz_scm_t param2,
				 zzz_scm_t param3, zzz_scm_t param4,
				 zzz_scm_t param5, zzz_scm_t * result);
typedef result_t (* func_0_2_0) (zzz_scm_t env, zzz_scm_t param0,
				 zzz_scm_t param1, zzz_scm_t * result);
typedef result_t (* func_2_2_0) (zzz_scm_t env, zzz_scm_t param0,
				 zzz_scm_t param1, zzz_scm_t param2,
				 zzz_scm_t param3, zzz_scm_t * result);
typedef result_t (* func_1_2_0) (zzz_scm_t env, zzz_scm_t param0,
				 zzz_scm_t param1, zzz_scm_t param2,
				 zzz_scm_t * result);
typedef result_t (* func_2_0_1) (zzz_scm_t env, zzz_scm_t param0,
				 zzz_scm_t param1, zzz_scm_t rest,
				 zzz_scm_t * result);
typedef result_t (* func_1_3_0) (zzz_scm_t env, zzz_scm_t param0,
				 zzz_scm_t param1, zzz_scm_t param2,
				 zzz_scm_t param3, zzz_scm_t * result);
typedef result_t (* func_2_4_0) (zzz_scm_t env, zzz_scm_t param0,
				 zzz_scm_t param1, zzz_scm_t param2,
				 zzz_scm_t param3, zzz_scm_t param4,
				 zzz_scm_t param5, zzz_scm_t * result);
typedef result_t (* func_2_3_0) (zzz_scm_t env, zzz_scm_t param0,
				 zzz_scm_t param1, zzz_scm_t param2,
				 zzz_scm_t param3, zzz_scm_t param4,
				 zzz_scm_t * result);
typedef result_t (* func_6_0_0) (zzz_scm_t env, zzz_scm_t param0,
				 zzz_scm_t param1, zzz_scm_t param2,
				 zzz_scm_t param3, zzz_scm_t param4,
				 zzz_scm_t param5, zzz_scm_t * result);
typedef result_t (* func_7_0_0) (zzz_scm_t env, zzz_scm_t param0,
				 zzz_scm_t param1, zzz_scm_t param2,
				 zzz_scm_t param3, zzz_scm_t param4,
				 zzz_scm_t param5, zzz_scm_t param6,
				 zzz_scm_t * result);

static int trace_indent = 0;

static void
print_trace_indent (zzz_scm_t port)
{
  int x = trace_indent;
  zzz_scm_t res;

  while (x-- > 0)
    zzz_port_puts (zzz_current_err_port, "  ", 2, &res);
}

/* Call the primitive procedure @var{proc} with environment @var{env}
   and with the parameter list @var{param_list} and store the result
   of the call in the location pointed to by @var{result}.  This
   function figures out how to call the given primitive and verifies
   that the actual arguments match the formal parameters.  */
static result_t
call_builtin_func (zzz_scm_t proc, zzz_scm_t env, zzz_scm_t param_list,
		   zzz_scm_t * result)
{
#if ENABLE_TRACE
  zzz_scm_t res;
#endif
  result_t err;

  PROFILE_COUNT(zzz_primitive_calls);

#if ENABLE_TRACE
  if (func_traced_p (proc))
    {
      print_trace_indent (zzz_current_err_port);
      zzz_port_puts (zzz_current_err_port,
		     "+ ",
		     2,
		     &res);
      zzz_port_print (zzz_current_err_port,
		      func_name (proc),
		      &zzz_print_state,
		      &res);
      zzz_port_puts (zzz_current_err_port, " <- ", 4, &res);
      zzz_port_print (zzz_current_err_port,
		      param_list,
		      &zzz_print_state,
		      &res);
      zzz_port_putc ('\n', zzz_current_err_port, &res);
      trace_indent++;
    }
#endif
  /* Dispatch on the formal parameter list specification and verify
     the number of actual parameters.  Primitives using the first
     argument format (a list of arguments) have to check for
     themselves whether the number of arguments is correct.  */
  switch (tagged_info (proc))
    {
    case argv_0_0_1:
      err = func_ptr (proc) (env, param_list, result);
      break;

    case argv_0_0_0:
      MANY_ARGS (!cons_p (param_list), proc);
      err = ((func_0_0_0) func_ptr (proc)) (env, result);
      break;

    case argv_1_0_0:
      FEW_ARGS (cons_p (param_list), proc);
      MANY_ARGS (!cons_p (cdr (param_list)), proc);
      err = ((func_1_0_0) func_ptr (proc)) (env, car (param_list), result);
      break;

    case argv_2_0_0:
      FEW_ARGS (cons_p (param_list), proc);
      FEW_ARGS (cons_p (cdr (param_list)), proc);
      MANY_ARGS (!cons_p (cdr (cdr (param_list))), proc);
      err = ((func_2_0_0) func_ptr (proc))
	(env, car (param_list), car (cdr (param_list)), result);
      break;

    case argv_3_0_0:
      FEW_ARGS (cons_p (param_list), proc);
      FEW_ARGS (cons_p (cdr (param_list)), proc);
      FEW_ARGS (cons_p (cdr (cdr (param_list))), proc);
      MANY_ARGS (!cons_p (cdr (cdr (cdr (param_list)))), proc);
      err = ((func_3_0_0) func_ptr (proc))
	(env, car (param_list), car (cdr (param_list)),
	 car (cdr (cdr (param_list))), result);
      break;

    case argv_4_0_0:
      FEW_ARGS (cons_p (param_list), proc);
      FEW_ARGS (cons_p (cdr (param_list)), proc);
      FEW_ARGS (cons_p (cdr (cdr (param_list))), proc);
      FEW_ARGS (cons_p (cdr (cdr (cdr (param_list)))), proc);
      MANY_ARGS (!cons_p (cdr (cdr (cdr (cdr (param_list))))), proc);
      err = ((func_4_0_0) func_ptr (proc))
	(env, car (param_list), car (cdr (param_list)),
	 car (cdr (cdr (param_list))), car (cdr (cdr (cdr (param_list)))),
	 result);
      break;

    case argv_5_0_0:
      FEW_ARGS (cons_p (param_list), proc);
      FEW_ARGS (cons_p (cdr (param_list)), proc);
      FEW_ARGS (cons_p (cdr (cdr (param_list))), proc);
      FEW_ARGS (cons_p (cdr (cdr (cdr (param_list)))), proc);
      FEW_ARGS (cons_p (cdr (cdr (cdr (cdr (param_list))))), proc);
      MANY_ARGS (!cons_p (cdr (cdr (cdr (cdr (cdr (param_list)))))), proc);
      err = ((func_5_0_0) func_ptr (proc))
	(env, car (param_list), car (cdr (param_list)),
	 car (cdr (cdr (param_list))), car (cdr (cdr (cdr (param_list)))),
	 car (cdr (cdr (cdr (cdr (param_list))))),
	 result);
      break;

    case argv_6_0_0:
      FEW_ARGS (cons_p (param_list), proc);
      FEW_ARGS (cons_p (cdr (param_list)), proc);
      FEW_ARGS (cons_p (cdr (cdr (param_list))), proc);
      FEW_ARGS (cons_p (cdr (cdr (cdr (param_list)))), proc);
      FEW_ARGS (cons_p (cdr (cdr (cdr (cdr (param_list))))), proc);
      FEW_ARGS (cons_p (cdr (cdr (cdr (cdr (cdr (param_list)))))), proc);
      MANY_ARGS (!cons_p (cdr (cdr (cdr (cdr (cdr (cdr (param_list))))))),
		 proc);
      err = ((func_6_0_0) func_ptr (proc))
	(env,
	 car (param_list), 
	 car (cdr (param_list)),
	 car (cdr (cdr (param_list))),
	 car (cdr (cdr (cdr (param_list)))),
	 car (cdr (cdr (cdr (cdr (param_list))))),
	 car (cdr (cdr (cdr (cdr (cdr (param_list)))))),
	 result);
      break;

    case argv_7_0_0:
      FEW_ARGS (cons_p (param_list), proc);
      FEW_ARGS (cons_p (cdr (param_list)), proc);
      FEW_ARGS (cons_p (cdr (cdr (param_list))), proc);
      FEW_ARGS (cons_p (cdr (cdr (cdr (param_list)))), proc);
      FEW_ARGS (cons_p (cdr (cdr (cdr (cdr (param_list))))), proc);
      FEW_ARGS (cons_p (cdr (cdr (cdr (cdr (cdr (param_list)))))), proc);
      FEW_ARGS (cons_p (cdr (cdr (cdr (cdr (cdr (cdr (param_list))))))), proc);
      MANY_ARGS
	(!cons_p (cdr (cdr (cdr (cdr (cdr (cdr (cdr (param_list)))))))), proc);
      err = ((func_7_0_0) func_ptr (proc))
	(env,
	 car (param_list), 
	 car (cdr (param_list)),
	 car (cdr (cdr (param_list))),
	 car (cdr (cdr (cdr (param_list)))),
	 car (cdr (cdr (cdr (cdr (param_list))))),
	 car (cdr (cdr (cdr (cdr (cdr (param_list)))))),
	 car (cdr (cdr (cdr (cdr (cdr (cdr (param_list))))))),
	 result);
      break;

    case argv_0_1_0:
      if (cons_p (param_list))
	{
	  MANY_ARGS (!cons_p (cdr (param_list)), proc);
	  err = ((func_0_1_0) func_ptr (proc)) (env, car (param_list), result);
	}
      else
	err = ((func_0_1_0) func_ptr (proc)) (env, zzz_undefined, result);
      break;

    case argv_1_1_0:
      FEW_ARGS (cons_p (param_list), proc);
      if (cons_p (cdr (param_list)))
	{
	  MANY_ARGS (!cons_p (cdr (cdr (param_list))), proc);
	  err = ((func_1_1_0) func_ptr (proc))
	    (env, car (param_list), car (cdr (param_list)), result);
	}
      else
	  err = ((func_1_1_0) func_ptr (proc))
	    (env, car (param_list), zzz_undefined, result);
      break;

    case argv_2_1_0:
      FEW_ARGS (cons_p (param_list), proc);
      FEW_ARGS (cons_p (cdr (param_list)), proc);
      if (cons_p (cdr (cdr (param_list))))
	{
	  MANY_ARGS (!cons_p (cdr (cdr (cdr (param_list)))), proc);
	  err = ((func_2_1_0) func_ptr (proc))
	    (env, car (param_list), car (cdr (param_list)),
	     car (cdr (cdr (param_list))), result);
	}
      else
	  err = ((func_2_1_0) func_ptr (proc))
	    (env, car (param_list), car (cdr (param_list)),
	     zzz_undefined, result);
      break;

    case argv_1_0_1:
      FEW_ARGS (cons_p (param_list), proc);
      err = ((func_1_1_0) func_ptr (proc))
	(env, car (param_list), cdr (param_list), result);
      break;

    case argv_2_0_1:
      FEW_ARGS (cons_p (param_list), proc);
      FEW_ARGS (cons_p (cdr (param_list)), proc);
      err = ((func_2_1_0) func_ptr (proc))
	(env, car (param_list), car (cdr (param_list)),
	 cdr (cdr (param_list)), result);
      break;

    case argv_0_2_0:
      {
	zzz_scm_t param0, param1;

	param0 = zzz_undefined;
	param1 = zzz_undefined;
	if (cons_p (param_list))
	  {
	    param0 = car (param_list);
	    if (cons_p (cdr (param_list)))
	      {
		MANY_ARGS (!cons_p
			   (cdr (cdr (param_list))), proc);
		param1 = car (cdr (param_list));
	      }
	  }
	err = ((func_0_2_0) func_ptr (proc)) (env, param0, param1, result);
      }
      break;

    case argv_1_2_0:
      {
	zzz_scm_t param2, param3;

	FEW_ARGS (cons_p (param_list), proc);
	param2 = zzz_undefined;
	param3 = zzz_undefined;
	if (cons_p (cdr (param_list)))
	  {
	    param2 = car (cdr (param_list));
	    if (cons_p (cdr (cdr (param_list))))
	      {
		MANY_ARGS
		  (!cons_p (cdr (cdr (cdr (param_list)))), proc);
		param3 = car (cdr (cdr (param_list)));
	      }
	  }
	err = ((func_1_2_0) func_ptr (proc))
	  (env, car (param_list), param2, param3, result);
      }
      break;

    case argv_2_2_0:
      {
	zzz_scm_t param2, param3;

	FEW_ARGS (cons_p (param_list), proc);
	FEW_ARGS (cons_p (cdr (param_list)), proc);
	param2 = zzz_undefined;
	param3 = zzz_undefined;
	if (cons_p (cdr (cdr (param_list))))
	  {
	    param2 = car (cdr (cdr (param_list)));
	    if (cons_p (cdr (cdr (cdr (param_list)))))
	      {
		MANY_ARGS
		  (!cons_p (cdr (cdr (cdr (cdr (param_list))))), proc);
		param3 = car (cdr (cdr (cdr (param_list))));
	      }
	  }
	err = ((func_2_2_0) func_ptr (proc))
	  (env, car (param_list), car (cdr (param_list)), param2,
	   param3, result);
      }
      break;

    case argv_3_3_0:
      {
	zzz_scm_t param3, param4, param5;

	FEW_ARGS (cons_p (param_list), proc);
	FEW_ARGS (cons_p (cdr (param_list)), proc);
	FEW_ARGS (cons_p (cdr (cdr (param_list))), proc);
	param3 = zzz_undefined;
	param4 = zzz_undefined;
	param5 = zzz_undefined;
	if (cons_p (cdr (cdr (cdr (param_list)))))
	  {
	    param3 = car (cdr (cdr (cdr (param_list))));
	    if (cons_p (cdr (cdr (cdr (cdr (param_list))))))
	      {
		param4 = car (cdr (cdr (cdr (cdr (param_list)))));
		if (cons_p (cdr (cdr (cdr (cdr (cdr (param_list)))))))
		  {
		    MANY_ARGS
		      (!cons_p (cdr (cdr (cdr (cdr (cdr
						    (cdr (param_list))))))),
		       proc);
		    param5 = car (cdr (cdr (cdr (cdr (cdr (param_list))))));
		  }
	      }
	  }
	err = ((func_3_3_0) func_ptr (proc))
	  (env, car (param_list), car (cdr (param_list)),
	   car (cdr (cdr (param_list))), param3, param4, param5, result);
      }
      break;

    case argv_1_3_0:
      {
	zzz_scm_t param1, param2, param3;

	FEW_ARGS (cons_p (param_list), proc);
	param1 = zzz_undefined;
	param2 = zzz_undefined;
	param3 = zzz_undefined;
	if (cons_p (cdr (param_list)))
	  {
	    param1 = car (cdr (param_list));
	    if (cons_p (cdr (cdr (param_list))))
	      {
		param2 = car (cdr (cdr (param_list)));
		if (cons_p (cdr (cdr (cdr (param_list)))))
		  {
		    MANY_ARGS
		      (!cons_p (cdr (cdr (cdr (cdr (param_list))))),
		       proc);
		    param3 = car (cdr (cdr (cdr (param_list))));
		  }
	      }
	  }
	err = ((func_1_3_0) func_ptr (proc))
	  (env, car (param_list), param1, param2, param3, result);
      }
      break;

    case argv_2_4_0:
      {
	zzz_scm_t param2, param3, param4, param5;

	FEW_ARGS (cons_p (param_list), proc);
	FEW_ARGS (cons_p (cdr (param_list)), proc);
	param2 = zzz_undefined;
	param3 = zzz_undefined;
	param4 = zzz_undefined;
	param5 = zzz_undefined;
	if (cons_p (cdr (cdr (param_list))))
	  {
	    param2 = car (cdr (cdr (param_list)));
	    if (cons_p (cdr (cdr (cdr (param_list)))))
	      {
		param3 = car (cdr (cdr (cdr (param_list))));
		if (cons_p (cdr (cdr (cdr (cdr (param_list))))))
		  {
		    param4 = car (cdr (cdr (cdr (cdr (param_list)))));
		    if (cons_p (cdr (cdr (cdr (cdr (cdr (param_list)))))))
		      {
			MANY_ARGS
			  (!cons_p (cdr (cdr (cdr (cdr
						   (cdr
						    (cdr (param_list))))))),
			   proc);
			param5 = car (cdr (cdr (cdr (cdr
						     (cdr (param_list))))));
		      }
		  }
	      }
	  }
	err = ((func_2_4_0) func_ptr (proc))
	  (env, car (param_list), car (cdr (param_list)),
	   param2, param3, param4, param5, result);
      }
      break;

    case argv_2_3_0:
      {
	zzz_scm_t param2, param3, param4;

	FEW_ARGS (cons_p (param_list), proc);
	FEW_ARGS (cons_p (cdr (param_list)), proc);
	param2 = zzz_undefined;
	param3 = zzz_undefined;
	param4 = zzz_undefined;
	if (cons_p (cdr (cdr (param_list))))
	  {
	    param2 = car (cdr (cdr (param_list)));
	    if (cons_p (cdr (cdr (cdr (param_list)))))
	      {
		param3 = car (cdr (cdr (cdr (param_list))));
		if (cons_p (cdr (cdr (cdr (cdr (param_list))))))
		  {
		    MANY_ARGS
		      (!cons_p (cdr (cdr (cdr
					  (cdr
					   (cdr (param_list)))))),
		       proc);
		    param4 = car (cdr (cdr (cdr (cdr (param_list)))));
		  }
	      }
	  }
	err = ((func_2_3_0) func_ptr (proc))
	  (env, car (param_list), car (cdr (param_list)),
	   param2, param3, param4, result);
      }
      break;

    default:
      fprintf (stderr, "inconsistency in eval.c:call_builtin_func()\n");
      abort ();
    }
#if ENABLE_TRACE
  if (func_traced_p (proc))
    {
      trace_indent--;
      print_trace_indent (zzz_current_err_port);
      zzz_port_puts (zzz_current_err_port,
		     "- ",
		     2,
		     &res);
      zzz_port_print (zzz_current_err_port,
		      func_name (proc),
		      &zzz_print_state,
		      &res);
      zzz_port_puts (zzz_current_err_port, " -> ", 4, &res);
      zzz_port_print (zzz_current_err_port,
		      *result,
		      &zzz_print_state,
		      &res);
      zzz_port_putc ('\n', zzz_current_err_port, &res);
    }
#endif
  return err;
}

/* Apply the (builtin or user-defined) function @var{proc} to the
   argument list @var{param_list} and store the result in the location
   pointed to by @var{result}.  Evaluation takes place in the
   environment @var{env}.  */
result_t
zzz_apply (zzz_scm_t env, zzz_scm_t proc, zzz_scm_t param_list,
	   zzz_scm_t * result)
{
  zzz_scm_t body;
  result_t err;

 restart_apply:
  /* Immediate codes should never get a chance to get here!  */
  assert (!immediate_p (proc));

  /* Check for interrupts and kick off pending signals.  */
  ZZZ_TICK ();

  if (form_p (proc))
    {
      *result = zzz_make_misc_error_exception
	(zzz_make_string
	 (_("apply can not be used with syntactic forms"), -1));
      return RESULT_EXCEPTION;
    }

  /* Call builtin procedures via the function defined above.  */
  if (func_p (proc))
    {
      err = call_builtin_func (proc, env, param_list, result);
      if (err == RESULT_TAILAPPLY)
	{
	  env = car (*result);
	  proc = car (cdr (*result));
	  param_list = cdr (cdr (*result));
	  goto restart_apply;
	}
      else
	return err;
    }

  /* When we reach this, we have to call a closure.  Bind the
     parameters and evaluate the procedure body inline.  */
  {
    zzz_scm_t arg;
    zzz_scm_t param;
    zzz_scm_t cl_env;

    cl_env = closure_env (proc);
    proc = closure_proc (proc);

    env = zzz_make_environment (ENVIRONMENT_SIZE, cl_env, 0, 0);
    /* Save and rebind formal parameters.  */
    arg = lambda_args (proc);
    param = param_list;
    while (cons_p (arg) && cons_p (param))
      {
	if ((err = zzz_define_symbol_value (env, car (arg), car (param),
					    result)) != RESULT_SUCCESS)
	  return err;
	arg = cdr (arg);
	param = cdr (param);
      }
    if (!null_p (arg))
      {
	/* Some magic for handling variable parameter lists.  */
	if (symbol_p (arg))
	  {
	    if ((err = zzz_define_symbol_value (env, arg, param, result))
		!= RESULT_SUCCESS)
	      return err;
	  }
	else
	  {
	    if (!null_p (lambda_name (proc)))
	      *result = zzz_make_wna_exception 
		(zzz_make_list
		 (zzz_make_string (_("too few parameters in call to `"), -1),
		  lambda_name (proc),
		  zzz_make_string ("'", -1),
		  NULL));
	    else
	      *result = zzz_make_wna_exception 
		(zzz_make_string
		 (_("too few parameters in anonymous lambda call "), -1));
	    return RESULT_EXCEPTION;
	  }
      }
    else if (!null_p (param))
      {
	if (!null_p (lambda_name (proc)))
	  *result = zzz_make_wna_exception 
	    (zzz_make_list
	     (zzz_make_string (_("too many parameters in call to `"), -1),
	      lambda_name (proc),
	      zzz_make_string ("'", -1),
	      NULL));
	else
	  *result = zzz_make_wna_exception 
	    (zzz_make_string
	     (_("too many parameters in anonymous lambda call "), -1));
	return RESULT_EXCEPTION;
      }
    body = lambda_body (proc);
    err = RESULT_SUCCESS;
    *result = zzz_unspecified;
    while (cons_p (body))
      {
	if ((err = zzz_evaluate_car (env, body, result)) != RESULT_SUCCESS)
	  return err;
	body = cdr (body);
      }
    return RESULT_SUCCESS;
  }
}

/* This function is the heart of the evaluator, and regarding its
   length, it is a real monster.  Unfortunately, this is the only
   possibility to get it reasonably fast while supporting proper tail
   calls.  

   Note: When hacking on this function, make sure to read the comments
   at all goto labels, especially `tail_recurse:', `return_success:',
   `return_any_error:' and `evaluate_body:' and `apply_closure:',
   because they list the preconditions for jumping there.  */
result_t
zzz_evaluate (zzz_scm_t env, zzz_scm_t expr, zzz_scm_t * result)
{
  zzz_scm_t orig_backtrace = zzz_backtrace;
  zzz_scm_t proc = NULL;
  zzz_scm_t tmp;
  zzz_scm_t list;
  zzz_scm_t body;
  zzz_scm_t pair;
  zzz_scm_t new_env;
  result_t err;

  /* Check for evaluation stack overflow.  
     PORTABILITY-NOTE: This depends on the stack to grow downwards. */
  if (&env < zzz_top_of_c_stack - max_evaluate_stack)
    {
      *result = zzz_make_exception
	(stack_overflow_exception,
	 zzz_make_string (_("set %max-evaluate-stack% to larger value"), -1));
      err = RESULT_EXCEPTION;
      goto return_any_error;
    }

  PROFILE_COUNT(zzz_evaluate_calls);

  /* When jumping here, make sure that the variables ENV and EXPR are
     initialized to proper values.  They are when we first get here
     because they are function parameters.  */
 tail_recurse:

  /* Immediate values like '() and fixnums evaluate to themselves.  */
  if (imm_p (expr))
    {
      *result = expr;
      goto return_success;
    }
  if (!cons_p (expr)) 
    {
      /* Local variables must get fetched from the environment they were
	 defined in.  */
      if (lloc_p (expr))
	{
	  zzz_signed_object_t env_ofs = fixnum_val (lloc_env (expr));
	  zzz_signed_object_t offset = fixnum_val (lloc_slot (expr));
	  zzz_scm_t c;

	  /* First, descend to the environment where the variable was
             defined.  */
	  while (env_ofs-- > 0)
	    env = env_link (env);
	  /* Fetch the association list which holds the variable
             binding.  */
	  c = env_val (env);
	  /* Descend the association list to reach the correct
             binding.  */
	  while (offset-- > 0)
	    c = cdr (c);
	  /* Return the bound value.  */
	  *result = cdr (car (c));
	  PROFILE_COUNT(zzz_lloc_accesses);
	  goto return_success;
	}
      /* Global variables hold the address where their value is stored.  */
      if (gloc_p (expr))
	{
	  *result = *gloc_val (expr);
	  PROFILE_COUNT(zzz_gloc_accesses);
	  goto return_success;
	}
      /* Symbols need to get looked up.  */
      if (symbol_p (expr))
	{
	  err = zzz_get_symbol_value (env, expr, result);
	  PROFILE_COUNT(zzz_global_accesses);
	  if (err == RESULT_SUCCESS)
	    goto return_success;
	  else
	    goto return_any_error;
	}

      /* R5RS says that vectors are not self-evaluating. */
      if (vector_p (expr))
	{
	  *result = zzz_make_misc_error_exception
	    (zzz_make_string (_("vectors do not evaluate to themselves"), -1));
	  err = RESULT_EXCEPTION;
	  goto return_any_error;
	}

      /* All non-conses left (tagged types) evaluate to themselves.  */
      *result = expr;
      goto return_success;
    }

  /* Handle user interrupts and kick of pending signals.  */
  ZZZ_TICK();

  /* Now we know that we have to evaluate a procedure application. */

  /* First, check for immediate forms and evaluate them inline.  */
  if (immediate_p (car (expr)))
    {
      PROFILE_COUNT(zzz_immediate_calls);

      switch (immediate_val (car (expr)))
	{
	case imm_begin:
	  body = cdr (expr);
	  goto evaluate_body;
	  break;

	case imm_quote:
	  *result = car (cdr (expr));
	  goto return_success;

# if 0
	case imm_quasiquote:
	  err = zzz_do_quasiquote (env, car (cdr (expr)), result, 1);
	  if (err == RESULT_SUCCESS)
	    goto return_success;
	  else
	    goto return_any_error;
#endif
	case imm_lambda:
	  *result = zzz_make_closure (cdr (expr), env);
	  goto return_success;

	case imm_if_then:
	  expr = cdr (expr);
	  if ((err = zzz_evaluate (env, car (expr), &tmp)) != RESULT_SUCCESS)
	    {
	      *result = tmp;
	      goto return_any_error;
	    }
	  if (tmp != zzz_false_value)
	    {
	      expr = car (cdr (expr));
	      PROFILE_COUNT(zzz_tail_calls);
	      goto tail_recurse;
	    }
	  else
	    {
	      *result = zzz_unspecified;
	      goto return_success;
	    }
	  break;

	case imm_if_then_else:
	  expr = cdr (expr);
	  if ((err = zzz_evaluate (env, car (expr), &tmp)) != RESULT_SUCCESS)
	    {
	      *result = tmp;
	      goto return_any_error;
	    }
	  if (tmp != zzz_false_value)
	    expr = car (cdr (expr));
	  else
	    expr = car (cdr (cdr (expr)));
	  PROFILE_COUNT(zzz_tail_calls);
	  goto tail_recurse;
	  break;

	case imm_let:
	  new_env = zzz_make_environment (ENVIRONMENT_SIZE, env, 0, 0);

	  /* Now bind all symbols to the given values.  */
	  list = car (cdr (expr));
	  while (cons_p (list))
	    {
	      pair = car (list);
	      tmp = NULL;
	      if ((err = zzz_evaluate (env, car (cdr (pair)), &tmp)) !=
		  RESULT_SUCCESS)
		{
		  *result = tmp;
		  goto return_any_error;
		}
	      if ((err = zzz_define_symbol_value (new_env, car (pair), tmp,
						  result)) != RESULT_SUCCESS)
		{
		  goto return_any_error;
		}
	      if (closure_p (tmp))
		lambda_name (closure_proc (tmp)) = car (pair);

	      list = cdr (list);
	    }
	  env = new_env;
	  new_env = NULL;
	  body = cdr (cdr (expr));
	  goto evaluate_body;
	  break;
	  
	case imm_named_let:
	  {
	    zzz_scm_t formals = NULL, init_args = NULL;
	    zzz_scm_t * pformals = &formals, * pinit_args = &init_args;
	    zzz_scm_t lambda = NULL;

	    new_env = zzz_make_environment (ENVIRONMENT_SIZE, env, 0, 0);
	    
	    lambda = car (cdr (expr));
	    list = cdr (cdr (expr));
	    while (cons_p (list))
	      {
		if ((err = zzz_evaluate (env, car (list), &tmp)) !=
		    RESULT_SUCCESS)
		  {
		    *result = tmp;
		    goto return_any_error;
		  }
		*pinit_args = zzz_cons (tmp, NULL);
		pinit_args = cdr_addr (*pinit_args);
		list = cdr (list);
	      }

	    list = init_args;
	    proc = zzz_make_closure (lambda, new_env);
	    if ((err = zzz_define_symbol_value (new_env, lambda_name (lambda),
						proc, result))
		!= RESULT_SUCCESS)
	      {
		goto return_any_error;
	      }
	    env = new_env;
	    goto apply_closure;
	  }

	case imm_letrec:
	  new_env = zzz_make_environment (ENVIRONMENT_SIZE, env, 0, 0);

	  /* Now bind all symbols to the given values.  */
	  list = car (cdr (expr));
	  while (cons_p (list))
	    {
	      pair = car (list);
	      tmp = NULL;
	      if ((err = zzz_evaluate (new_env, car (cdr (pair)), &tmp)) !=
		  RESULT_SUCCESS)
		{
		  *result = tmp;
		  goto return_any_error;
		}
	      if ((err = zzz_define_symbol_value (new_env, car (pair), tmp,
						  result))
		  != RESULT_SUCCESS)
		{
		  goto return_any_error;
		}
	      if (closure_p (tmp))
		lambda_name (closure_proc (tmp)) = car (pair);
	      list = cdr (list);
	    }
	  env = new_env;
	  new_env = NULL;
	  body = cdr (cdr (expr));
	  goto evaluate_body;
	  break;

	case imm_letstar:
	  new_env = zzz_make_environment (ENVIRONMENT_SIZE, env, 0, 0);
	  
	  /* Now bind all symbols to the given values.  */
	  list = car (cdr (expr));
	  while (cons_p (list))
	    {
	      pair = car (list);
	      tmp = NULL;
	      if ((err = zzz_evaluate (new_env, car (cdr (pair)), &tmp)) !=
		  RESULT_SUCCESS)
		{
		  *result = tmp;
		  goto return_any_error;
		}
	      if ((err = zzz_define_symbol_value (new_env, car (pair), tmp,
						  result)) != RESULT_SUCCESS)
		{
		  goto return_any_error;
		}
	      if (closure_p (tmp))
		lambda_name (closure_proc (tmp)) = car (pair);

	      list = cdr (list);
	    }
	  env = new_env;
	  new_env = NULL;
	  body = cdr (cdr (expr));
	  goto evaluate_body;
	  break;
	  
	case imm_set_x:
	  expr = cdr (expr);
	  if ((err = zzz_evaluate (env, car (cdr (expr)), &tmp)) !=
	      RESULT_SUCCESS)
	    {
	      *result = tmp;
	      goto return_any_error;
	    }
	  if ((err = zzz_set_symbol_value (env, car (expr), tmp, result)) !=
	      RESULT_SUCCESS)
	    {
	      goto return_any_error;
	    }
	  if (closure_p (tmp) && null_p (lambda_name (closure_proc (tmp))))
	    lambda_name (closure_proc (tmp)) = car (expr);
	  *result = zzz_unspecified;
	  goto return_success;

	case imm_define:
	  expr = cdr (expr);
	  if ((err = zzz_evaluate (env, car (cdr (expr)), &tmp)) !=
	      RESULT_SUCCESS)
	    {
	      *result = tmp;
	      goto return_any_error;
	    }
	  if ((err = zzz_define_symbol_value (env, car (expr), tmp, result)) !=
	      RESULT_SUCCESS)
	    {
	      goto return_any_error;
	    }
	  if (closure_p (tmp))
	    lambda_name (closure_proc (tmp)) = car (expr);
	  *result = zzz_unspecified;
	  goto return_success;

	case imm_definefunc:
	  {
	    zzz_scm_t proc;
	    proc = zzz_make_closure (cdr (cdr (expr)), env);
	    if ((err = zzz_define_symbol_value (env, car (cdr (expr)), proc,
						result)) != RESULT_SUCCESS)
	      {
		goto return_any_error;
	      }
	    *result = zzz_unspecified;
	    goto return_success;
	  }
	case imm_and:
	  body = cdr (expr);
	  while (cons_p (body) && !null_p (cdr (body)))
	    {
	      if ((err = zzz_evaluate (env, car (body), result))
		  != RESULT_SUCCESS)
		{
		  goto return_any_error;
		}
	      if (*result == zzz_false_value)
		{
		  goto return_success;
		}
	      body = cdr (body);
	    }
	  if (!null_p (body))
	    {
	      expr = car (body);
	      PROFILE_COUNT(zzz_tail_calls);
	      goto tail_recurse;
	    }
	  *result = zzz_true_value;
	  goto return_success;

	case imm_or:
	  body = cdr (expr);
	  while (cons_p (body) && !null_p (cdr (body)))
	    {
	      if ((err = zzz_evaluate (env, car (body), result))
		  != RESULT_SUCCESS)
		{
		  goto return_any_error;
		}
	      if (*result != zzz_false_value)
		{
		  goto return_success;
		}
	      body = cdr (body);
	    }
	  if (!null_p (body))
	    {
	      expr = car (body);
	      PROFILE_COUNT(zzz_tail_calls);
	      goto tail_recurse;
	    }
	  *result = zzz_false_value;
	  goto return_success;
	  break;

	case imm_cond:
	  {
	    zzz_scm_t clause = NULL;
	    zzz_scm_t tmp2 = NULL;

	    expr = cdr (expr);
	    while (cons_p (expr))
	      {
		tmp = NULL;
		clause = car (expr);
		if (zzz_eq (car (clause), zzz_else_sym))
		  break;
		if ((err = zzz_evaluate (env, car (clause), &tmp))
		    != RESULT_SUCCESS)
		  {
		    *result = tmp;
		    goto return_any_error;
		  }
		if (tmp != zzz_false_value)
		  break;
		expr = cdr (expr);
	      }
	    if (cons_p (expr))
	      {
		clause = cdr (clause);
		if (!cons_p (clause))
		  {
		    *result = tmp;
		    goto return_success;
		  }
		else if (car (clause) == zzz_arrow_sym)
		  {
		    clause = cdr (clause);
		    if ((err = zzz_evaluate (env, car (clause), &tmp2)) !=
			RESULT_SUCCESS)
		      {
			*result = tmp2;
			goto return_any_error;
		      }
		    err = zzz_apply (env, tmp2, zzz_cons (tmp, NULL), result);
		    if (err == RESULT_SUCCESS)
		      goto return_success;
		    else
		      goto return_any_error;
		  }
		else 
		  {
		    body = clause;
		    goto evaluate_body;
		  }
	      }
	    else
	      {
		*result = zzz_unspecified;
		goto return_success;
	      }
	    abort ();		/* Never reached.  Sanity check.  */
	  }

	case imm_case:
	  {
	    zzz_scm_t key = NULL;
	    zzz_scm_t clause = NULL;
	    zzz_scm_t val_list = NULL;

	    key = car (cdr (expr)); /* Get key to switch on. */
	    expr = cdr (cdr (expr)); /* Point EXPR to clause list. */
	    /* Evaluate the key to switch on. */
	    if ((err = zzz_evaluate (env, key, &tmp)) != RESULT_SUCCESS)
	      {
		*result = tmp;
		goto return_any_error;
	      }

	    /* Compare the key to all clauses. */
	    while (cons_p (expr))
	      {
		clause = car (expr);
		if (zzz_eq (car (clause), zzz_else_sym))
		  break;
		val_list = car (clause);
		while (cons_p (val_list))
		  {
		    if (zzz_eqv (car (val_list), tmp))
		      break;
		    val_list = cdr (val_list);
		  }
		if (cons_p (val_list))
		  break;
		expr = cdr (expr);
	      }
	    if (cons_p (expr))
	      {
		body = cdr (clause);
		goto evaluate_body;
	      }
	    else
	      *result = zzz_unspecified;
	    goto return_success;
	  }
	  
	case imm_do:
	  {
	    zzz_scm_t var_clause = NULL;
	    zzz_scm_t test_clause = NULL;
	    zzz_scm_t variables = NULL;
	    zzz_scm_t steps = NULL;
	    zzz_scm_t clause = NULL;
	    zzz_scm_t new_env = NULL;
	    zzz_scm_t v = NULL, s = NULL;
	    zzz_scm_t body_list = NULL;

	    var_clause = car (cdr (expr));
	    test_clause = car (cdr (cdr (expr)));
	    expr = cdr (cdr (cdr (expr)));

	    new_env = zzz_make_environment (ENVIRONMENT_SIZE, env, 0, 0);

	    /* Initialize induction variables and collect variables and step
	       expressions in separate lists. */
	    while (cons_p (var_clause))
	      {
		clause = car (var_clause);
		if ((err = zzz_evaluate (env, car (cdr (clause)), &tmp)) !=
		    RESULT_SUCCESS)
		  {
		    *result = tmp;
		    goto return_any_error;
		  }
		if ((err = zzz_define_symbol_value (new_env, car (clause), tmp,
						    result))
		    != RESULT_SUCCESS)
		  {
		    goto return_any_error;
		  }
		variables = zzz_cons (car (clause), variables);
		if (cons_p (cdr (cdr (clause))))
		  steps = zzz_cons (car (cdr (cdr (clause))), steps);
		else
		  steps = zzz_cons (car (clause), steps);
		var_clause = cdr (var_clause);
	      }
  
	    /* Execute loop body by first testing termination
	       expression and the executing loop body expressions. */
	    if ((err = zzz_evaluate (new_env, car (test_clause), &tmp)) !=
		RESULT_SUCCESS)
	      {
		*result = tmp;
		goto return_any_error;
	      }
	    while (tmp == zzz_false_value)
	      {
		ZZZ_TICK();

		body_list = expr;
		while (cons_p (body_list))
		  {
		    if ((err = zzz_evaluate (new_env, car (body_list), &tmp))
			!= RESULT_SUCCESS)
		      {
			*result = tmp;
			goto return_any_error;
		      }
		    body_list = cdr (body_list);
		  }
		v = variables;
		s = steps;
		while (cons_p (v))
		  {
		    if ((err = zzz_evaluate (new_env, car (s), &tmp))
			!= RESULT_SUCCESS)
		      {
			*result = tmp;
			goto return_any_error;
		      }
		    if ((err = zzz_set_symbol_value (new_env, car (v), tmp,
						     result)) !=
			RESULT_SUCCESS)
		      {
			goto return_any_error;
		      }
		    v = cdr (v);
		    s = cdr (s);
		  }
		if ((err = zzz_evaluate (new_env, car (test_clause), &tmp)) !=
		    RESULT_SUCCESS)
		  {
		    *result = tmp;
		    goto return_any_error;
		  }
	      }
	    if (!cons_p (cdr (test_clause)))
	      {
		*result = tmp;
		goto return_success;
	      }
	    /* Evaluate all loop exit expressions. */
	    body = cdr (test_clause);
	    env = new_env;
	    new_env = NULL;
	    goto evaluate_body;
	  }

	case imm_undefine:
	  if ((err = zzz_undefine_symbol(env, car (cdr (expr)), result)) !=
	      RESULT_SUCCESS)
	    {
	      goto return_any_error;
	    }
	  *result = zzz_unspecified;
	  goto return_success;
	  
	case imm_defineconst:
	  {
	    zzz_scm_t res;

	    expr = cdr (expr);
	    if ((err = zzz_evaluate_car (env, cdr (expr), &res)) !=
		RESULT_SUCCESS)
	      {
		*result = res;
		goto return_any_error;
	      }
	    res = zzz_make_constant (res);
	    if ((err = zzz_define_symbol_value(env, car (expr), res, result))
		!= RESULT_SUCCESS)
	      goto return_any_error;

	    if (closure_p (res) && null_p (lambda_name (closure_proc (res))))
	      lambda_name (closure_proc (res)) = car (expr);
	    *result = zzz_unspecified;
	    goto return_success;
	  }

	case imm_delay:
	  *result = zzz_make_promise (env, car (cdr (expr)));
	  goto return_success;
	  
	default:
	  fprintf (stderr, "inconsistency in eval.c:zzz_evaluate()\n");
	  abort ();
	  break;
	}
    }
  /* Normal application, so we have to evaluate the car of the list to
     get the procedure.  */
  if ((err = zzz_evaluate_car (env, expr, &proc)) != RESULT_SUCCESS)
    {
      *result = proc;
      goto return_any_error;
    }

  if (!procedure_p (proc))
    {
      if (macro_p (proc))
	{
	  if ((err = zzz_expand_macro (env, proc, cdr (expr), result)) !=
	      RESULT_SUCCESS)
	    {
	      goto return_any_error;
	    }
	  if (cons_p (*result))
	    {
	      set_car (expr, car (*result));
	      set_cdr (expr, cdr (*result));
	    }
	  else
	    expr = *result;
	  *result = NULL;
	  goto tail_recurse;
	}
#if ENABLE_R5RS_MACROS
      if (syntax_p (proc))
	{
	  if ((err = zzz_expand_syntax (env, proc, expr, result)) !=
	      RESULT_SUCCESS)
	    {
	      goto return_any_error;
	    }
	  if (cons_p (*result))
	    {
	      set_car (expr, car (*result));
	      set_cdr (expr, cdr (*result));
	    }
	  else
	    expr = *result;
	  *result = NULL;
	  goto tail_recurse;
	}
#endif /* ENABLE_R5RS_MACROS */
      
      /* Signal an error if the first member of the list does not evaluate
	 to a procedure.  */
      *result = zzz_make_misc_error_exception
	(zzz_make_list
	 (zzz_make_string (_("not a procedure: "), -1), proc, NULL));
      err = RESULT_EXCEPTION;
      goto return_any_error;
    }

  /* Forms are evaluated without evaluating their arguments.  */
  if (form_p (proc))
    {
      PROFILE_COUNT(zzz_syntactic_calls);
      err = func_ptr (proc) (env, expr, result);
      /* Check whether this form already executed the code or only
         rewrote the evaluation tree.  */
      if (err == RESULT_SUCCESS && tagged_info (proc) == argv_prep_form)
	{
	  goto tail_recurse;
	}
      if (err == RESULT_SUCCESS)
	goto return_success;
      else
	goto return_any_error;
    }

  if (eval_save_backtrace)
    zzz_backtrace = zzz_cons (zzz_cons (expr, NULL), zzz_backtrace);
  
  /* Now only functions and lambda expressions are left, so we have to
     evaluate the parameter list. */
  if ((err = evaluate_list (env, cdr (expr), &list)) != RESULT_SUCCESS)
    {
      *result = list;
      goto return_any_error;
    }

  /* Remember the expression in the error_expression variable, in case
     it causes an error on evaluation.  */
  error_expression = expr;

  /* When jumping here, make sure that
     1. `proc' is either a primitive procedure or a closure.
     2. `list' is a proper list.
     3. `env' is the correct environment for the application.  */
 apply_func:

  /* Functions are evaluated by simply calling the C primitive.  */
  if (func_p (proc))
    {
      err = call_builtin_func (proc, env, list, result);
      if (err == RESULT_SUCCESS)
	goto return_success;
      else if (err == RESULT_TAILAPPLY)
	{
	  env = car (*result);
	  proc = car (cdr (*result));
	  list = cdr (cdr (*result));
	  goto apply_func;
	}
      else
	goto return_any_error;
    }

 apply_closure:

  /* When we get here, we are evaluating a closure.  Do it
     tail-recursively.  */
  PROFILE_COUNT(zzz_closure_calls);
  {
    zzz_scm_t arg = NULL;
    zzz_scm_t param = NULL;
    zzz_scm_t cl_env;

    cl_env = closure_env (proc);
    proc = closure_proc (proc);

#if ENABLE_TRACE
    if (lambda_traced_p (proc))
      {
	zzz_scm_t res;
	print_trace_indent (zzz_current_err_port);
	zzz_port_puts (zzz_current_err_port,
		       "+ ",
		       2,
		       &res);
	zzz_port_print (zzz_current_err_port,
			lambda_name (proc),
			&zzz_print_state,
			&res);
	zzz_port_puts (zzz_current_err_port, " <- ", 4, &res);
	zzz_port_print (zzz_current_err_port,
			list,
			&zzz_print_state,
			&res);
	zzz_port_putc ('\n', zzz_current_err_port, &res);
	trace_indent++;
      }
#endif
    env = zzz_make_environment (ENVIRONMENT_SIZE, cl_env, 0, 0);

    /* Save and rebind formal parameters.  */
    arg = lambda_args (proc);
    param = list;
    list = NULL;
    while (cons_p (arg) && cons_p (param))
      {
	if ((err = zzz_define_symbol_value (env, car (arg), car (param),
					    result))
	    != RESULT_SUCCESS)
	  {
	    goto return_any_error;
	  }
	arg = cdr (arg);
	param = cdr (param);
      }
    if (!null_p (arg))
      {
	/* Some magic for handling variable parameter lists.  */
	if (symbol_p (arg))
	  {
	    if ((err = zzz_define_symbol_value (env, arg, param, result))
		!= RESULT_SUCCESS)
	      {
		goto return_any_error;
	      }
	  }
	else
	  {
	    if (!null_p (lambda_name (proc)))
	      *result = zzz_make_wna_exception 
		(zzz_make_list
		 (zzz_make_string (_("too few parameters in call to `"), -1),
		  lambda_name (proc),
		  zzz_make_string ("'", -1),
		  NULL));
	    else
	      *result = zzz_make_wna_exception 
		(zzz_make_string
		 (_("too few parameters in anonymous lambda call "), -1));
	    err = RESULT_EXCEPTION;
	    goto return_any_error;
	  }
      }
    else if (!null_p (param))
      {
	if (!null_p (lambda_name (proc)))
	  *result = zzz_make_wna_exception 
	    (zzz_make_list
	     (zzz_make_string (_("too many parameters in call to `"), -1),
	      lambda_name (proc),
	      zzz_make_string ("'", -1),
	      NULL));
	else
	  *result = zzz_make_wna_exception 
	    (zzz_make_string
	     (_("too many parameters in anonymous lambda call "), -1));
	err = RESULT_EXCEPTION;
	goto return_any_error;
      }
    body = lambda_body (proc);

    /* Whoever jumps here should make sure that
       a) BODY is a list of expressions to evaluate in sequence and 
          tail-recursively.
       b) ENV holds the correct environment in which the expressions
          should get evaluated.  */
  evaluate_body:
    /* Make sure the body has at least one expression.  Otherwise, its
       value is unspecified.  */
    if (cons_p (body))
      {
	/* Evaluate all expressions in the body except the last one.  */
	while (cons_p (cdr (body)))
	  {
	    if ((err = zzz_evaluate_car (env, body, result)) != RESULT_SUCCESS)
	      goto return_any_error;
	    body = cdr (body);
	  }
	/* Try to memoize the last expression in the value, it may be
           a symbol.  */
	zzz_memoize_car (env, body);
	/* The last expression in the body is stored in the variable
           `expr' and then we jump back to the beginning of this
           procedure, thus its value will be returned back to the
           caller.  Note that the variable `env' is already properly
           set, so the precondition for jumping to `tail_recurse:' is
           met.  */
	expr = car (body);
	PROFILE_COUNT(zzz_tail_calls);
	goto tail_recurse;
      }
    *result = zzz_unspecified;
    goto return_success;
  }

  /* The following labels are necessary to reduce code clutter and
     error possibilities in regard to backtrace and debug frame
     handling.  All places in the above code which want to return from
     the evaluation procedure should jump to one of these labels, with
     a correctly setup return value in the location pointed to by
     RESULT.  In case of the first label, the variable ERR should be
     provided with the correct result code also.  */

  /* Jump here to return with the result code in ERR from this
     evaluation.  Make sure RESULT points to an appropriate result
     value.  */
 return_any_error:
  return err;

  /* Jump here to complete a successful evaluation.  Make sure RESULT
     points to a correct return value if you jump here.  */
 return_success:
  zzz_backtrace = orig_backtrace;
  return RESULT_SUCCESS;
}

/* Print the procedure backtrace saved in the variable ERROR_BACKTRACE.  */
static void
print_backtrace (zzz_scm_t port, int interactive)
{
  zzz_scm_t result = NULL;
  zzz_scm_t temp = error_backtrace;
  struct zzz_print_state state = {/*  0,  */0};
  char buf[64];
  int len;
  int i = 0;
  char * s;

  if (eval_save_backtrace)
    {
      s = _("Procedure backtrace:\n");
      zzz_port_puts (port, s, strlen (s), &result);
      if (null_p (temp))
	{
	  s = _("backtrace is empty\n");
	  result = NULL;
	  zzz_port_puts (port, s, strlen (s), &result);
	}
      else
	while (cons_p (temp) && i < eval_print_backtrace_limit)
	  {
	    len = sprintf (buf, "#%d: ", i);
	    zzz_port_puts (port, buf, len, &result);
	    zzz_port_print (port, car (car (temp)), 
			    &zzz_state.print_state,
			    &result);
	    {
	      zzz_scm_t location = zzz_get_source_location (car (car (temp)));

	      if (!zzz_eq (location, zzz_false_value))
		{
		  zzz_port_putc ('\t', port, &result);
		  zzz_port_putc ('[', port, &result);
		  zzz_port_print (port, car (location), &state, &result);
		  zzz_port_putc (':', port, &result);
		  zzz_port_print (port, car (cdr (location)), &state, &result);
		  zzz_port_putc (':', port, &result);
		  zzz_port_print (port, car (cdr (cdr (location))), &state,
				  &result);
		  zzz_port_putc (']', port, &result);
		}
	    }
	    zzz_port_putc ('\n', port, &result);
	    temp = cdr (temp);
	    i++;
	  }
    }
  else
    {
      s = _("no backtrace available\n\
evaluate `(set! %save-backtrace% #t)' if you want backtraces\n");
      result = NULL;
      zzz_port_puts (port, s, strlen (s), &result);
    }
}

/* Standard signal handler for the interactive read-eval-print loop.  */
static void
interrupt_signal (int signum)
{
  zzz_interrupt_requested++;
  signal (SIGINT, interrupt_signal);
}

/* Report the error ERROR to the error port.  ERR is the result type
   and INTERACTIVE is true if this is called from an interactive
   read-eval-print loop.  */
void
zzz_report_error (result_t err, zzz_scm_t error, int interactive)
{
  zzz_scm_t temp;
  char * s;

  switch (err)
    {
    case RESULT_TOPLEVEL:
      if (interactive || eval_print_result)
	{
	  s = _("back to top level\n");
	  zzz_port_puts (zzz_stdout_port, s, strlen (s), &temp);
	}
      break;
    case RESULT_QUIT:
      break;
    case RESULT_INTERRUPT:
      if (interactive || eval_print_result)
	{
	  s = _("user interrupt\n");
	  zzz_port_puts (zzz_stderr_port, s, strlen (s), &temp);
	  zzz_interrupt_requested = 0;
	}
      break;
    case RESULT_ERROR:
    case RESULT_EXCEPTION:
      if (err == RESULT_ERROR && error_expression != NULL)
      {
	zzz_scm_t location = zzz_get_source_location (error_expression);
	if (location != zzz_false_value)
	  zzz_set_error_reference (error, location);
      }
      if (err == RESULT_EXCEPTION && error_expression != NULL)
      {
	zzz_scm_t location = zzz_get_source_location (error_expression);
	if (location != zzz_false_value)
	  zzz_set_exception_reference (error, location);
      }
      if (interactive && port_p (zzz_transcript_port))
	{
	  zzz_port_print (zzz_transcript_port, error,
			  &zzz_state.print_state, &temp);
	  zzz_port_putc ('\n', zzz_transcript_port, &temp);
	}
      zzz_port_print (zzz_stderr_port, error, &zzz_state.print_state,
		      &temp);
      zzz_port_putc ('\n', zzz_stderr_port, &temp);
      if (!eval_backtrace_hint_given && interactive)
	{
	  if (!eval_save_backtrace)
	    {
	      if (!eval_save_backtrace_hint_given)
		{
		  s = _("no backtrace available\n\
evaluate `(set! %save-backtrace% #t)' if you want backtraces\n");
		  zzz_port_puts (zzz_stderr_port, s, strlen (s), &temp);
		  eval_save_backtrace_hint_given = 1;
		}
	    }
	  else
	    {
	      eval_backtrace_hint_given = 1;
	      s =_("evaluate `(backtrace)' to show the procedure backtrace\n");
	      zzz_port_puts (zzz_stderr_port, s, strlen (s), &temp);
	    }
	}
      break;
    default:
      abort ();
      break;
    }
}

/* Evaluate the expression @var{expr} and return the result in the
   location pointed to by @var{result}.  @code{RESULT_SUCCESS} is
   returned on success, an error code otherwise.  */
static result_t
evaluate_one_expression (zzz_scm_t env, zzz_scm_t expr, zzz_scm_t * result)
{
  zzz_scm_t temp;
  int err;
#if HAVE_TIMES
  struct tms begin_tms, end_tms;
#endif
  

  /* Print out what we want to evaluate, for debugging purposes. */  
  if (eval_print_read)
    {
      zzz_port_print (zzz_stdout_port, expr, &zzz_state.print_state,
		      &expr);
      zzz_port_putc ('\n', zzz_stdout_port, &expr);
    }
#if HAVE_TIMES
  times (&begin_tms);
#endif
  if ((err = zzz_evaluate (env, expr, result)) != RESULT_SUCCESS)
    {
      switch (err)
	{
	case RESULT_TOPLEVEL:
	case RESULT_QUIT:
	  break;
	case RESULT_INTERRUPT:
	case RESULT_ERROR:
	case RESULT_EXCEPTION:
	  error_backtrace = zzz_backtrace;
	  break;
	default:
	  abort ();
	  break;
	}
    }
  else if (!zzz_eq (*result, zzz_unspecified) && eval_print_result)
    {
      zzz_port_print (zzz_stdout_port, *result, &zzz_state.print_state, &temp);
      zzz_port_putc ('\n', zzz_stdout_port, &temp);
    }
  zzz_backtrace = NULL;
#if HAVE_TIMES
  times (&end_tms);
  zzz_eval_time_taken += (end_tms.tms_utime + end_tms.tms_stime)
    - (begin_tms.tms_utime + begin_tms.tms_stime);
#endif
  return err;
}

/* Print the result of an evaluation, which is @var{value}, to the
   output port @var{port}.  */
static void
print_repl_result (zzz_scm_t port, zzz_scm_t value)
{
  zzz_scm_t list, temp;

  assert (port_p (port));
  /* In a REPL, we treat multiple values differently, so that printing
     is more useful.  FIXME: Think about making this a general rule
     and modify the multiple values printer; or think up general
     scheme for printing in a REPL.  */
  if (values_p (value))
    {
      list = values_val (value);
      while (cons_p (list))
	{
	  zzz_port_print (port, car (list), &zzz_state.print_state,
			  &temp);
	  zzz_port_putc ('\n', port, &temp);
	  list = cdr (list);
	}
    }
  else
    {
      zzz_port_print (port, value, &zzz_state.print_state, &temp);
      zzz_port_putc ('\n', port, &temp);
    }
}

int
zzz_read_eval_print (void)
{
  zzz_scm_t expr;
  zzz_scm_t temp;
  zzz_scm_t result = zzz_unspecified;
  result_t err = RESULT_SUCCESS;
  void (*old_int)(int);

  zzz_interaction_mode = 1;
/*    zzz_state.current_input_file_name = NULL; */

  old_int = signal (SIGINT, interrupt_signal);
  do
    {
      /* Reset the error expression.  Maybe there is a better place
         for doing this?  */
      error_expression = NULL;

      expr = NULL;

      if ((err = zzz_read_cell (zzz_current_in_port, &expr)) != RESULT_SUCCESS)
	{
	  if (err == RESULT_INTERRUPT)
	    {
	      expr = zzz_eof_object;
	    }
	  else
	    {
	      zzz_report_error (err, expr, 1);
	    }
	}
      else if (!zzz_eq (expr, zzz_eof_object))
	{
	  if (port_p (zzz_transcript_port))
	    {
	      zzz_port_print (zzz_transcript_port, expr,
			      &zzz_state.print_state,
			      &temp);
	      zzz_port_puts (zzz_transcript_port, " =>\n", 4, &temp);
	    }
	  result = NULL;
	  if ((err = evaluate_one_expression (zzz_current_environment, expr,
					      &result)) != RESULT_SUCCESS)
	    {
	      zzz_report_error (err, result, 1);
	      if (eval_print_backtrace)
		{
		  print_backtrace (zzz_stdout_port, 1);
		}
	    }
	  else if (!zzz_eq (result, zzz_unspecified))
	    {
	      zzz_scm_t tmp;
	      if (port_p (zzz_transcript_port))
		{
		  print_repl_result (zzz_transcript_port, result);
		}
	      print_repl_result (zzz_stdout_port, result);
	      
	      /* Make the result of the last evaluation available
                 under the name `$$'.  */
	      zzz_define_symbol_value (zzz_interaction_environment,
				       zzz_make_symbol ("$$", -1),
				       result, &tmp);
	    }
	  zzz_port_flush (zzz_stdout_port, &result);
	}
    }
  while (!zzz_eq (expr, zzz_eof_object) && err != RESULT_QUIT);
  if (err != RESULT_QUIT)
    {
      expr = NULL;
      zzz_port_puts (zzz_stdout_port, "(exit)\n", 7, &expr);
    }
  /* Close transcript port on exit, if any.  */
  if (port_p (zzz_transcript_port))
    {
      transcript_off_func (zzz_current_environment, &temp);
    }
  signal (SIGINT, old_int);
  
  zzz_interaction_mode = 0;

  if (err == RESULT_QUIT)
    return integer_val (result);
  else
    return 0;
}

/* Load successive sexps from the stream F and evaluate them one after
  the other. Script version.  */
result_t
zzz_load_port (zzz_scm_t env, zzz_scm_t port, zzz_scm_t * result)
{
  zzz_scm_t last_module = zzz_current_module;
  zzz_scm_t check_module = zzz_current_module;
  zzz_scm_t last_env = zzz_current_environment;
  zzz_scm_t expr;
  int err = RESULT_SUCCESS;

  zzz_state.remember_source_locations++;
  do
    {
      /* FIXME: HACK-ALERT: This is here to keep the current
         environment up to date while importing modules.  */
      if (zzz_current_module != check_module)
	{
	  env = module_private (zzz_current_module);
	  check_module = zzz_current_module;
	}

      expr = NULL;
      if ((err = zzz_read_cell (port, &expr)) != RESULT_SUCCESS)
	{
	  *result = expr;
	  zzz_current_environment = last_env;
	  zzz_current_module = last_module;
	  return err;
	}
      else if (!zzz_eq (expr, zzz_eof_object))
	{
	  err = evaluate_one_expression (env, expr, result);
	}
    }
  while (!zzz_eq (expr, zzz_eof_object) && err == RESULT_SUCCESS);
  zzz_current_environment = last_env;
  zzz_current_module = last_module;
  zzz_state.remember_source_locations--;
  return err;
}

/*:doc
  primitive-load
  (primitive-load filename) => *unspecified*
  Load the file named @var{filename} and evaluate its contents in the toplevel
  environment.
  doc:*/
#define FUNC_NAME "primitive-load"
static result_t
primitive_load_func (zzz_scm_t env, zzz_scm_t filename, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t port;
  int rc_file;
/*    zzz_scm_t old_name = zzz_state.current_input_file_name; */
  result_t err;

  CHECK_TYPE (1, string_p (filename), zzz_string_type_name);
  CHECK_SAFE_FILENAME (1, filename, zzz_safe_filename_type_name);
  rc_file = open (string_val (filename), O_RDONLY | O_BINARY);
  if (rc_file < 0)
    {
      *result = zzz_make_exception (zzz_file_not_found_exception, filename);
      return RESULT_EXCEPTION;
    }

  port = zzz_make_fdport (rc_file, 1, 0);
  port_filename (port) = filename;
/*    zzz_state.current_input_file_name = filename; */
  err = zzz_load_port (zzz_current_environment, port, result);
/*    zzz_state.current_input_file_name = old_name; */

  return err;
}
#undef FUNC_NAME

/*:doc
  primitive-load-path
  (primitive-load-path filename) => *unspecified*
  Load the file named @var{filename} and evaluate its contents in the toplevel
  environment. This procedure is similar to @code{primitive-load}, but when
  @var{filename} is not an absolute file name, it is searched in the current
  directory as well as in all directories listed in the variable
  @var{%load-path}.
  doc:*/
#define FUNC_NAME "primitive-load-path"
result_t
zzz_primitive_load_path (zzz_scm_t env, zzz_scm_t filename,
			 zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t port;
  int rc_file;
/*    zzz_scm_t old_name = zzz_state.current_input_file_name; */
  result_t err;

  CHECK_TYPE (1, string_p (filename), zzz_string_type_name);
  CHECK_SAFE_FILENAME (1, filename, zzz_safe_filename_type_name);
  CHECK_TYPE (1, string_len (filename) > 0, _("non-empty string"));

  rc_file = open (string_val (filename), O_RDONLY | O_BINARY);
  if (rc_file < 0 && string_val (filename)[0] == '/')
    {
      *result = zzz_make_exception (zzz_file_not_found_exception, filename);
      return RESULT_EXCEPTION;
    }
  while (rc_file < 0)
    {
      char * buf;
      int buf_len;
      zzz_scm_t temp;
      if (zzz_get_symbol_value (env, zzz_make_symbol ("%load-path", -1),
				&temp) == RESULT_SUCCESS)
	{
	  rc_file = -1;
	  while (cons_p (temp))
	    {
	      if (string_p (car (temp)))
		{
		  buf_len = string_len (car (temp)) +
		    string_len (filename) + 2;
		  buf = zzz_malloc (buf_len);
		  strcpy (buf, string_val (car (temp)));
		  if (strlen (buf) > 0 && buf[strlen (buf) - 1] != '/')
		    strcat (buf, "/");
		  strcat (buf, string_val (filename));
		  rc_file = open (buf, O_RDONLY | O_BINARY);
		  if (rc_file >= 0)
		    {
		      zzz_free (buf, buf_len);
		      break;
		    }
		  zzz_free (buf, buf_len);
		}
	      temp = cdr (temp);
	      rc_file = -1;
	    }
	  if (rc_file < 0)
	    {
	      *result = zzz_make_exception (zzz_file_not_found_exception,
					    filename);
	      return RESULT_EXCEPTION;
	    }
	}
      else
	{
	  *result = zzz_make_exception (zzz_file_not_found_exception,
					filename);
	  return RESULT_EXCEPTION;
	}
    }

  port = zzz_make_fdport (rc_file, 1, 0);
  port_filename (port) = filename;
/*    zzz_state.current_input_file_name = filename; */
  err = zzz_load_port (zzz_current_environment, port, result);
/*    zzz_state.current_input_file_name = old_name; */

  return err;
}
#undef FUNC_NAME

/*:doc
  backtrace
  (backtrace) => *unspecified*
  Print the current error backtrace to the current error port.
  doc:*/
#define FUNC_NAME "backtrace"
static result_t
backtrace_func (zzz_scm_t env, zzz_scm_t * result)
{
  print_backtrace (zzz_stderr_port, 1);
  *result = zzz_unspecified;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  transcript-on
  (transcript-on filename) => *unspecified*
  Start transcription to the file called @var{filename}.  All following
  expression read at the read-eval-print loop will be printed to the file
  together with their evaluation result(s).
  doc:*/
#define FUNC_NAME "transcript-on"
static result_t
transcript_on_func (zzz_scm_t env, zzz_scm_t filename, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  int f;

  CHECK_TYPE (1, string_p (filename), zzz_string_type_name);
  CHECK_SAFE_FILENAME (1, filename, zzz_safe_filename_type_name);
  if ((f = open (string_val (filename), 
		 O_WRONLY | O_CREAT | O_TRUNC | O_BINARY,
		 zzz_default_file_mode)) < 0)
    {
      *result = zzz_make_exception (zzz_file_creation_exception, filename);
      return RESULT_EXCEPTION;
    }
  zzz_transcript_port = zzz_make_fdport (f, 0, 1);
  *result = zzz_unspecified;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  transcript-off
  (transcript-off) => *unspecified*
  Turn off the transcription started with @code{transcript-off}.
  doc:*/
#define FUNC_NAME "transcript-off"
static result_t
transcript_off_func (zzz_scm_t env, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  result_t err;
  
  if (port_p (zzz_transcript_port))
    {
      if ((err = zzz_port_flush (zzz_transcript_port, result)) !=
	  RESULT_SUCCESS)
	return err;
      if ((err = zzz_port_close (zzz_transcript_port, result)) !=
	  RESULT_SUCCESS)
	return err;
      zzz_transcript_port = NULL;
    }
  *result = zzz_unspecified;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  trace
  (trace proc on/off) => *unspecified*
  If @var{on/off} is true, start tracing procedure @var{proc}, otherwise,
  switch tracing for @var{proc} off.
  doc:*/
#define FUNC_NAME "trace"
static result_t
trace_func (zzz_scm_t env, zzz_scm_t proc, zzz_scm_t on_off,
	    zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

  CHECK_TYPE (1, procedure_p (proc), zzz_procedure_type_name);
  if (zzz_eq (on_off, zzz_false_value))
    {
      if (func_p (proc))
	{
	  func_traced_p (proc) = 0;
	}
      else if (closure_p (proc))
	{
	  lambda_traced_p (closure_proc (proc)) = 0;
	}
    }
  else
    {
      if (func_p (proc))
	{
	  func_traced_p (proc) = 1;
	}
      else if (closure_p (proc))
	{
	  lambda_traced_p (closure_proc (proc)) = 1;
	}
    }
  *result = zzz_unspecified;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

result_t
zzz_init_eval (void)
{
  /* Initialize some global variables.  */
  zzz_interaction_mode = 0;
  eval_backtrace_hint_given = 0;
  eval_save_backtrace_hint_given = 0;
  error_backtrace = NULL;
  error_expression = NULL;
  max_evaluate_stack = MAX_EVALUATE_STACK;
  zzz_eval_time_taken = 0;
  eval_print_read = 0;
  eval_print_result = 0;
  eval_save_backtrace = 0;
  eval_print_backtrace = 0;
  eval_print_backtrace_limit = 20;
  zzz_interrupt_requested = 0;
  zzz_transcript_port = NULL;

  /*:doc
    stack-overflow
    Exception
    This is thrown when an evaluation is nested so deep that the stack
    grows larger than specified  by the variable @var{%max-evaluate-stack%}.
    If you encounter this exception, you can set that variable to a larger
    value.
    doc:*/
  zzz_protect_global (&stack_overflow_exception);
  stack_overflow_exception = zzz_make_symbol ("stack-overflow", -1);

  /*:doc
    wrong-number-args
    Exception
    This is thrown when a procedure is applied to a number of arguments
    not supported by the arity of the procedure.
    doc:*/
  zzz_protect_global (&wrong_number_args_exception);
  wrong_number_args_exception = zzz_make_symbol ("wrong-number-args", -1);

  /*:doc
    wrong-type-argument
    Exception
    This is thrown when a procedure receives an argument of the wrong type.
    doc:*/
  zzz_protect_global (&wrong_type_argument_exception);
  wrong_type_argument_exception = zzz_make_symbol ("wrong-type-argument", -1);

  /*:doc
    misc-error
    Exception
    This is thrown when a miscellaneous error happens.
    doc:*/
  zzz_protect_global (&misc_error_exception);
  misc_error_exception = zzz_make_symbol ("misc-error", -1);

  /* Save the static zzz_scm_t variables for this module from being
     reclaimed during garbage collection.  */
  zzz_protect_global (&zzz_transcript_port);
  zzz_protect_global (&error_backtrace);
  zzz_protect_global (&error_expression);

  /*:doc
    %max-evaluate-stack%
    Integer variable
    Limits the size the evaluation stack can grow to.  Set this to a larger
    value if you encounter @code{stack-overflow} exceptions.
    doc:*/
  zzz_bind_int_variable ("%max-evaluate-stack%", &max_evaluate_stack, 0);
  /*:doc
    %eval-time-taken%
    Integer variable
    The time spent in evaluation in clock ticks.  This is a read-only variable.
    Only contains a sane value if the times() C library call is available.
    doc:*/
  zzz_bind_int_variable ("%eval-time-taken%", &zzz_eval_time_taken, 1);
  /*:doc
    %print-read%
    Boolean variable
    If this is @var{#t}, all expressions read from the current input port
    will be printed to the current output port before evaluation.
    doc:*/
  zzz_bind_bool_variable ("%print-read%", &eval_print_read, 0);
  /*:doc
    %print-result%
    Boolean variable
    If this is @var{#t}, evaluation results will be printed to the current
    output port even if a script is being evaluated.
    doc:*/
  zzz_bind_bool_variable ("%print-result%", &eval_print_result, 0);
  /*:doc
    %save-backtrace%
    Boolean variable
    If this is @var{#t}, the evaluator will save a backtrace of procedure
    applications.  This is needed if you want to have procedure backtraces
    on errors.
    doc:*/
  zzz_bind_bool_variable ("%save-backtrace%", &eval_save_backtrace, 0);
  /*:doc
    %print-backtrace%
    Boolean variable
    If set to @var{#t}, a procedure backtrace will be printed immediately
    whenever an error or exception is encountered.  If @var{#f}, you have to
    call the procedure @code{backtrace} to get a procedure backtrace.
    doc:*/
  zzz_bind_bool_variable ("%print-backtrace%", &eval_print_backtrace, 0);
  /*:doc
    %print-backtrace-limit%
    Integer variable
    This variable limits the lines which will be printed in procedure
    backtraces.
    doc:*/
  zzz_bind_int_variable ("%print-backtrace-limit%",
			 &eval_print_backtrace_limit, 0);
  zzz_define_function ("backtrace", (zzz_prim_t) backtrace_func, argv_0_0_0);
  zzz_define_function ("primitive-load", (zzz_prim_t) primitive_load_func,
		       argv_1_0_0);
  zzz_define_function ("primitive-load-path",
		       (zzz_prim_t) zzz_primitive_load_path,
		       argv_1_0_0);
  zzz_define_function ("load",
		       (zzz_prim_t) zzz_primitive_load_path,
		       argv_1_0_0);
  zzz_define_function ("transcript-on", (zzz_prim_t) transcript_on_func,
		       argv_1_0_0);
  zzz_define_function ("transcript-off", (zzz_prim_t) transcript_off_func,
		       argv_0_0_0);
  zzz_define_function ("trace", (zzz_prim_t) trace_func,
		       argv_2_0_0);
  return RESULT_SUCCESS;
}
