/* libsizzle/node.c - basic data types
 
  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 

#include <assert.h>
#include <stdlib.h>
#include <stdarg.h>
#define _GNU_SOURCE
#include <stdio.h>
#include <string.h>
#if ENABLE_NLS
# include <libintl.h>
# define _(String) gettext(String)
#else
# define _(String) (String)
#endif

#include <version.h>

#include "alloc.h"
#include "node.h"
#include "gc.h"
#include "libpath.h"
#include "eval.h"
#include "number.h"
#include "list.h"
#include "read.h"
#include "stringfun.h"
#include "char.h"
#include "vector.h"
#include "port.h"
#include "values.h"
#include "promise.h"
#include "cvar.h"
#include "fport.h"
#include "fdport.h"
#include "sport.h"
#include "posix.h"
#include "symbol.h"
#include "boolean.h"
#if ENABLE_REGEXP && HAVE_REGCOMP
#include "regexp.h"
#endif /* ENABLE_REGEXP */
#include "hashtab.h"
#include "capi.h"
#include "macros.h"
#include "misc.h"
#if ENABLE_MAXIMUM_FUNCTIONALITY
#include "net.h"
#endif /* ENABLE_MAXIMUM_FUNCTIONALITY */
#if ENABLE_DL
#include "dynlib.h"
#endif /* ENABLE_DL */
#include "scmport.h"
#if ENABLE_UVECTOR
#include "uvector.h"
#endif /* ENABLE_UVECTOR */
#include "doc.h"
#include "iofun.h"
#include "sig.h"
#include "modules.h"
#include "control.h"
#include "syntax.h"
#include "profile.h"
#include "pointer.h"
#include "box.h"

/* Some of the current state of the interpreter.  */
struct zzz_state zzz_state;

/* Constant and predefined cell values.  */

/* The symbol `else'.  */
zzz_scm_t zzz_else_sym;

 /* The symbol `quote'.  */
zzz_scm_t zzz_quote_sym;

/* The symbol `quasiquote.  */
zzz_scm_t zzz_quasiquote_sym;

/* The symbol `unquote'.  */
zzz_scm_t zzz_unquote_sym;

/* The symbol `unquote-splicing'.  */
zzz_scm_t zzz_unquote_splicing_sym;

/* The symbol `.'.  Used in dotted-pair notation.  */
zzz_scm_t zzz_dot_sym;

/* The symbol `...'.  Used in macro definitions with `syntax-rules'.  */
zzz_scm_t zzz_dots_sym;

/* The symbol `=>'.  Used in `cond' forms and in hash table literals.  */
zzz_scm_t zzz_arrow_sym;

/* This holds the symbol `not-available', which is used in exceptions
   thrown for primitives not available on the current system.  */
zzz_scm_t zzz_not_available_exception;

/* A table for holding all 256 character values defined in extended
   ASCII.  */
zzz_scm_t zzz_char_values[256];

/* All symbols read are stored in this table.  */
zzz_scm_t zzz_symbol_table;

/* All keywords read are store in the keyword table.  */
zzz_scm_t zzz_keyword_table;

/* The environment for storing library definitions loaded at startup.  */
zzz_scm_t zzz_library_environment;

/* The environment currently used for definitions.  Normally, this is
   the same as zzz_interaction_env, but may differ when defining
   modules.  */
zzz_scm_t zzz_current_environment;

/* The environment where all definitions from the repl are stored.  */
zzz_scm_t zzz_interaction_environment;

/* The currently active module.  May be changed from the Scheme level
   with (define-module (blu ...) :use-modules (bla ...) ...) etc.  */
zzz_scm_t zzz_current_module;

/* This holds a list of command line arguments available to Scheme
   code via the procedure @code{command-line}.  */
zzz_scm_t zzz_command_line_list;

/* Function call backtrace */
zzz_scm_t zzz_backtrace;

#if 0
/* Global print state variable which can be used in calls to
   `zzz_port_print()' when full quoting is desired.  */
struct zzz_print_state zzz_print_state = {/*  0,  */PRINT_ESCAPE | PRINT_QUOTE};

/* If true, glocs and llocs make themselves visible on printing.  */
static int print_memoized = 0;

/* If true, procedures are printed with their procedure bodies.  */
static int print_func_bodies = 0;
#endif

/* Data structure to build lists of hooks.  */
typedef struct hook * zzz_hook_t;
struct hook
{
  zzz_hook_t next;
  hook_func_t func;
  void * data;
};

/* Hook list for hooks to be called on shutdown.  */
static zzz_hook_t shutdown_hook_root;

/* Hook list for hooks to be called after the mark phase of GC.  */
static zzz_hook_t after_mark_hook_root;

/* Hook list for hooks to be called after the mark sweep of GC.  */
static zzz_hook_t after_sweep_hook_root;

/* These two defines control the space used for the symbol- and the
   keyword table.  */
#define SYMBOL_TABLE_SIZE (1017)
#define KEYWORD_TABLE_SIZE (637)



/* Type management.  Prototypes of type management functions and
   management data structures.  */

/* Forward declaration of all type management functions which are
   included in the type dispatch table below. */
static void * string_constructor (zzz_tagged_t tagged, void * data0,
				  void * data1, void * data2);
static void string_print (zzz_scm_t port, zzz_tagged_t tagged,
			  zzz_print_state_t state);
static void string_free (zzz_tagged_t tagged);
static void string_mark (zzz_tagged_t tagged);
static int string_equal (zzz_tagged_t tagged0, zzz_tagged_t tagged1);
static void char_print (zzz_scm_t port, zzz_tagged_t tagged,
			zzz_print_state_t state);
static int char_equal (zzz_tagged_t tagged0, zzz_tagged_t tagged1);
static void * float_constructor (zzz_tagged_t tagged, void * data0,
				 void * data1, void * data2);
static void float_print (zzz_scm_t port, zzz_tagged_t tagged,
			 zzz_print_state_t state);
static int float_equal (zzz_tagged_t tagged0, zzz_tagged_t tagged1);
static void symbol_print (zzz_scm_t port, zzz_tagged_t tagged,
			  zzz_print_state_t state);
static void * func_constructor (zzz_tagged_t tagged, void * data0,
				void * data1, void * data2);
static void func_print (zzz_scm_t port, zzz_tagged_t tagged,
			zzz_print_state_t state);
static void func_free (zzz_tagged_t tagged);
static void func_mark (zzz_tagged_t tagged);
static void * lambda_constructor (zzz_tagged_t tagged, void * data0,
				  void * data1, void * data2);
static void lambda_print (zzz_scm_t port, zzz_tagged_t tagged,
			  zzz_print_state_t state);
static void lambda_free (zzz_tagged_t tagged);
static void lambda_mark (zzz_tagged_t tagged);
static void closure_print (zzz_scm_t port, zzz_tagged_t tagged,
			  zzz_print_state_t state);
static void error_print (zzz_scm_t port, zzz_tagged_t tagged,
			 zzz_print_state_t state);
static void except_print (zzz_scm_t port, zzz_tagged_t tagged,
			  zzz_print_state_t state);
static void long_print (zzz_scm_t port, zzz_tagged_t tagged,
			zzz_print_state_t state);
static void environment_print (zzz_scm_t port, zzz_tagged_t tagged,
			       zzz_print_state_t state);
static void location_print (zzz_scm_t port, zzz_tagged_t tagged,
			    zzz_print_state_t state);
static void lloc_print (zzz_scm_t port, zzz_tagged_t tagged,
			zzz_print_state_t state);
static void gloc_print (zzz_scm_t port, zzz_tagged_t tagged,
			zzz_print_state_t state);
static void constant_print (zzz_scm_t port, zzz_tagged_t tagged,
			    zzz_print_state_t state);
static void keyword_print (zzz_scm_t port, zzz_tagged_t tagged,
			   zzz_print_state_t state);
static void pointer_print (zzz_scm_t port, zzz_tagged_t tagged,
			   zzz_print_state_t state);
static void pointer_free (zzz_tagged_t tagged);

struct zzz_type_descriptor zzz_type_descriptors[256] =
{
  {NULL, NULL, NULL, NULL, NULL},	/* First entry *must* be
                                           empty, because 0 is the
                                           type tag used in free
                                           cells.  */
  {string_constructor, string_print, string_free, string_mark, string_equal},
  {zzz_simple_constructor, char_print, NULL, NULL, char_equal},
  {float_constructor, float_print, NULL, NULL, float_equal},
  {zzz_simple_constructor, symbol_print, NULL, zzz_simple_mark, NULL},
  {func_constructor, func_print, func_free, func_mark, NULL},
  {func_constructor, func_print, func_free, func_mark, NULL},
  {lambda_constructor, lambda_print, lambda_free, lambda_mark, NULL},
  {zzz_simple_constructor, error_print, NULL, zzz_simple_mark, NULL},
  {zzz_simple_constructor, except_print, NULL, zzz_simple_mark, NULL},
  {zzz_simple_constructor, long_print, NULL, NULL, NULL},
  {zzz_simple_constructor, environment_print, NULL, zzz_simple_mark, NULL},
  {zzz_simple_constructor, location_print, NULL, zzz_simple_mark, NULL},
  {zzz_simple_constructor, lloc_print, NULL, zzz_simple_mark, NULL},
  {zzz_simple_constructor, gloc_print, NULL, zzz_simple_mark, NULL},
  {zzz_simple_constructor, constant_print, NULL, zzz_simple_mark, NULL},
  {zzz_simple_constructor, keyword_print, NULL, zzz_simple_mark, NULL},
  {zzz_simple_constructor, closure_print, NULL, zzz_simple_mark, NULL},
  {zzz_simple_constructor, pointer_print, pointer_free, NULL, NULL}
};

#define MAX_TYPE_DESCRIPTORS \
  (sizeof (zzz_type_descriptors) / sizeof (zzz_type_descriptors[0]))

/* Various pre-defined tag values.
 
  Note: these constants correspond to array indices in
  @var{type_descriptors} above. */
zzz_object_t zzz_tagged_type_free        = 0;
zzz_object_t zzz_tagged_type_string      = 1;
zzz_object_t zzz_tagged_type_char        = 2;
zzz_object_t zzz_tagged_type_float       = 3;
zzz_object_t zzz_tagged_type_symbol      = 4;
zzz_object_t zzz_tagged_type_func        = 5;
zzz_object_t zzz_tagged_type_form        = 6;
zzz_object_t zzz_tagged_type_lambda      = 7;
zzz_object_t zzz_tagged_type_error       = 8;
zzz_object_t zzz_tagged_type_except      = 9;
zzz_object_t zzz_tagged_type_long        = 10;
zzz_object_t zzz_tagged_type_environment = 11;
zzz_object_t zzz_tagged_type_location    = 12;
zzz_object_t zzz_tagged_type_lloc        = 13;
zzz_object_t zzz_tagged_type_gloc        = 14;
zzz_object_t zzz_tagged_type_constant    = 15;
zzz_object_t zzz_tagged_type_keyword     = 16;
zzz_object_t zzz_tagged_type_closure     = 17;
zzz_object_t zzz_tagged_type_pointer     = 18;

/* This one must be the last type tag above plus one. */
zzz_object_t zzz_type_descriptor_count   = 19;



/* Register a new tagged type, which will have the passed functions as
   its constructor, rint, free, mark and equal functions.  The
   constructor and print functions may not be NULL, the others may.
   Returned is a new tag type number, to be used for
   zzz_create_tagged_cell().  */
zzz_object_t
zzz_define_tagged_type (constructor_func_t constructor_func,
			print_func_t print_func,
			free_func_t free_func,
			mark_func_t mark_func,
			equal_func_t equal_func)
{
  assert (zzz_type_descriptor_count < MAX_TYPE_DESCRIPTORS);
  assert (constructor_func != NULL);
  assert (print_func != NULL);

  zzz_type_descriptors[zzz_type_descriptor_count].constructor_func =
    constructor_func;
  zzz_type_descriptors[zzz_type_descriptor_count].print_func = print_func;
  zzz_type_descriptors[zzz_type_descriptor_count].free_func = free_func;
  zzz_type_descriptors[zzz_type_descriptor_count].mark_func = mark_func;
  zzz_type_descriptors[zzz_type_descriptor_count].equal_func = equal_func;
  zzz_type_descriptor_count++;
  return zzz_type_descriptor_count - 1;
}



/* The functions on this page are debugging replacements for the
   macros for accessing the fields of a cons cell.  They are only
   compiled in if the macros are not defined.  Use them only when
   debugging, because they are a lot slower than the macro versions.  */

#ifndef car
zzz_scm_t
car (zzz_scm_t cons)
{
  assert (cons != NULL);
  assert ((((zzz_object_t) cons) & 7) == 0);
  return cons->ccar;
}
#endif

#ifndef cdr
zzz_scm_t
cdr (zzz_scm_t cons)
{
  assert (cons != NULL);
  assert ((((zzz_object_t) cons) & 7) == 0);
  return cons->ccdr;
}
#endif

#ifndef set_car
void
set_car (zzz_scm_t cons, zzz_scm_t val)
{
  assert (cons != NULL);
  assert ((((zzz_object_t) cons) & 7) == 0);
  cons->ccar = val;
}
#endif

#ifndef set_cdr
void
set_cdr (zzz_scm_t cons, zzz_scm_t val)
{
  assert (cons != NULL);
  assert ((((zzz_object_t) cons) & 7) == 0);
  cons->ccdr = val;
}
#endif

#ifndef car_addr
zzz_scm_t *
car_addr (zzz_scm_t cons)
{
  assert (cons != NULL);
  assert ((((zzz_object_t) cons) & 7) == 0);
  return &(cons->ccar);
}
#endif

#ifndef cdr_addr
zzz_scm_t *
cdr_addr (zzz_scm_t cons)
{
  assert (cons != NULL);
  assert ((((zzz_object_t) cons) & 7) == 0);
  return &(cons->ccdr);
}
#endif




zzz_scm_t
zzz_make_list (zzz_scm_t first, ...)
{
  zzz_scm_t cell = NULL;
  zzz_scm_t * next = &cell;
  va_list args;
  int safety_check = 0;

  va_start (args, first);
  while (!null_p (first))
    {
      *next =  zzz_cons (first, NULL);
      next = cdr_addr (*next);
      first = va_arg (args, zzz_scm_t);

      /* Just a check to make sure that the parameter list is
         terminated with a NULL pointer.  Increase the constant if you
         have the need for *really* long lists.  */
#if !NDEBUG
      safety_check++;
      assert (safety_check < 100);
#endif /* !NDEBUG */
    }
  va_end (args);
  return cell;
}

zzz_scm_t
zzz_make_n_list (int n, zzz_scm_t first, ...)
{
  zzz_scm_t cell = NULL;
  zzz_scm_t * next = &cell;
  va_list args;

  va_start (args, first);
  while (n-- > 0)
    {
      *next =  zzz_cons (first, NULL);
      next = cdr_addr (*next);
      first = va_arg (args, zzz_scm_t);
    }
  va_end (args);
  return cell;
}

zzz_scm_t
zzz_copy_list (zzz_scm_t list)
{
  zzz_scm_t res = NULL;
  zzz_scm_t * resp = &res;

  while (cons_p (list))
    {
      *resp = zzz_cons (car (list), NULL);
      resp = cdr_addr (*resp);
      list = cdr (list);
    }
  return res;
}

zzz_scm_t
zzz_copy_tree (zzz_scm_t tree)
{
  zzz_scm_t res;
  if (vector_p (tree))
    {
      unsigned i;
      res = zzz_make_vector (vector_len (tree));
      for (i = 0; i < vector_len (tree); i++)
	{
	  zzz_vector_put (res, i, zzz_copy_tree (zzz_vector_get (tree, i)));
	}
      return res;
    }
  else if (cons_p (tree))
    {
      zzz_scm_t * resp = &res;
      res = NULL;
      while (cons_p (tree))
	{
	  *resp = zzz_cons (zzz_copy_tree (car (tree)), NULL);
	  resp = cdr_addr (*resp);
	  tree = cdr (tree);
	}
      *resp = zzz_copy_tree (tree);
      return res;
    }
  else
    return tree;
}

#ifndef zzz_make_fixnum
zzz_scm_t
zzz_make_fixnum (long number)
{
  zzz_scm_t int_cell;

  int_cell = int_to_cell (number);
  return int_cell;
}
#endif /* !defined(zzz_make_fixnum) */

zzz_scm_t
zzz_make_string (char * s, int len)
{
  if (len < 0)
    len = strlen (s);
  return zzz_create_tagged_cell (zzz_tagged_type_string, s, 
				 (void *) ((long) len),
				 NULL);
}

zzz_scm_t
zzz_make_nstring (int len)
{
  return zzz_create_tagged_cell (zzz_tagged_type_string, NULL, 
				 (void *) ((long) len),
				 NULL);
}

zzz_scm_t
zzz_make_ro_string (char * s, int len)
{
  if (len < 0)
    len = strlen (s);
  return zzz_create_tagged_cell (zzz_tagged_type_string | tagged_info_ro,
				 s, (void *) ((long) len), NULL);
}

zzz_scm_t
zzz_make_ro_nstring (int len)
{
  return zzz_create_tagged_cell (zzz_tagged_type_string | tagged_info_ro,
				 NULL, (void *) ((long) len), NULL);
}

zzz_scm_t
zzz_make_bool (long b)
{
  return b ? zzz_true_value : zzz_false_value;
}

zzz_scm_t
zzz_make_char (long b)
{
  return zzz_char_values[b & 0xff];
}

zzz_scm_t
zzz_make_float (double d)
{
  return zzz_create_tagged_cell (zzz_tagged_type_float, &d, NULL, NULL);
}

/* Return a hash value of the string pointed to by S with length LEN.  */
static zzz_object_t 
hash_string (char * s, int len)
{
  zzz_object_t h = 0xdeadbeef ^ len;
  
  while (len-- > 0)
    {
      h = (h << 1) ^ ((zzz_object_t) *s++);
    }
  return h;
}

zzz_scm_t
zzz_make_symbol (char * s, int len)
{
  zzz_object_t hash_val;
  zzz_scm_t c, sym = NULL;
  zzz_scm_t name;
  unsigned real_len;

  if (len < 0)
    real_len = strlen (s);
  else
    real_len = len;
  hash_val = hash_string (s, real_len) % SYMBOL_TABLE_SIZE;

  c = zzz_vector_get (zzz_symbol_table, hash_val);
  while (cons_p (c))
    {
      sym = car (c);
      name = tagged_data0 (sym);
      if (string_len (name) == real_len &&
	  !memcmp (string_val (name), s, real_len))
	break;
      c = cdr (c);
    }
  if (!cons_p (c))
    {
      name = zzz_make_ro_string (s, real_len);
      sym = zzz_create_tagged_cell (zzz_tagged_type_symbol, name,
				    zzz_undefined, NULL);
      c = zzz_cons (sym, zzz_vector_get (zzz_symbol_table, hash_val));
      zzz_vector_put (zzz_symbol_table, hash_val, c);
    }
  return sym;
}

zzz_scm_t
zzz_make_func (zzz_prim_t func, char * name, int form,
	       int param_format)
{
  zzz_scm_t function = NULL, sym = NULL;

  sym = zzz_make_symbol (name, strlen (name));

  function = zzz_create_tagged_cell
    ((form ? zzz_tagged_type_form : zzz_tagged_type_func) | param_format, 
     (void *) func, sym, (void *) ((long) form)); 
  return function;
}

zzz_scm_t
zzz_make_lambda (zzz_scm_t expr)
{
  return zzz_create_tagged_cell (zzz_tagged_type_lambda, expr, NULL, NULL);
}

zzz_scm_t
zzz_make_closure (zzz_scm_t proc, zzz_scm_t env)
{
  return zzz_create_tagged_cell (zzz_tagged_type_closure, proc, env, NULL);
}

zzz_scm_t
zzz_make_error (zzz_scm_t msg, zzz_scm_t reference)
{
  zzz_scm_t res;

  res = zzz_create_tagged_cell (zzz_tagged_type_error,
				zzz_cons (msg, reference), NULL, NULL);
  return res;
}

void
zzz_set_error_reference (zzz_scm_t error, zzz_scm_t reference)
{
  zzz_scm_t pair = tagged_data0 (error);
  set_cdr (pair, reference);
}

zzz_scm_t
zzz_make_exception (zzz_scm_t exception, zzz_scm_t msg)
{
  zzz_scm_t res;

  exception = zzz_cons (exception, msg);
  res = zzz_create_tagged_cell (zzz_tagged_type_except, exception, NULL,
				NULL);
  return res;
}

void
zzz_set_exception_reference (zzz_scm_t exception, zzz_scm_t reference)
{
  (to_tagged_ptr(exception))->fill[2] = (zzz_object_t) reference;
}

zzz_scm_t
zzz_make_integer (long value)
{
  zzz_scm_t res;
 
  if (value >= MIN_FIXNUM && value <= MAX_FIXNUM)
    res = zzz_make_fixnum (value);
  else
    res = zzz_create_tagged_cell (zzz_tagged_type_long, (void *) value,
				  NULL, NULL);
  return res;
}

zzz_scm_t
zzz_make_environment (unsigned size, zzz_scm_t static_link, int final,
		      int read_only)
{
  zzz_object_t tag = zzz_tagged_type_environment;

  if (final)
    tag |= tagged_info_final;
  if (read_only)
    tag |= tagged_info_ro_chain;
  return zzz_create_tagged_cell (tag, NULL, static_link, NULL);
}

zzz_scm_t
zzz_make_location (zzz_scm_t * location, int read_only)
{
  return zzz_create_tagged_cell (read_only ?
				 zzz_tagged_type_location | tagged_info_ro:
				 zzz_tagged_type_location,
				 (void *) location,
				 NULL, NULL);
}

zzz_scm_t
zzz_make_lloc (zzz_scm_t symbol, int env_ofs, int offset)
{
  return zzz_create_tagged_cell (zzz_tagged_type_lloc, 
				 zzz_make_fixnum (env_ofs),
				 zzz_make_fixnum (offset),
				 symbol);
}

zzz_scm_t
zzz_make_gloc (zzz_scm_t name, zzz_scm_t * address)
{
  return zzz_create_tagged_cell (zzz_tagged_type_gloc, name, address, NULL);
}

zzz_scm_t
zzz_make_constant (zzz_scm_t value)
{
  return zzz_create_tagged_cell (zzz_tagged_type_constant, value, NULL, NULL);
}

zzz_scm_t
zzz_make_keyword (char * s, int len)
{
  zzz_object_t hash_val;
  zzz_scm_t c, key = NULL;
  zzz_scm_t sym = zzz_make_symbol (s, len);

  if (len < 0)
    len = strlen (s);
  hash_val = hash_string (s, len) % KEYWORD_TABLE_SIZE;

  c = zzz_vector_get (zzz_keyword_table, hash_val);
  while (cons_p (c))
    {
      key = car (c);
      if (zzz_eq (keyword_name (key), sym))
	break;
      key = NULL;
      c = cdr (c);
    }
  if (!key)
    {
      key = zzz_create_tagged_cell (zzz_tagged_type_keyword, sym, NULL, NULL);
      c = zzz_cons (key, zzz_vector_get (zzz_keyword_table, hash_val));
      zzz_vector_put (zzz_keyword_table, hash_val, c);
    }
  return key;
}

zzz_scm_t
zzz_make_pointer (void * address)
{
  return zzz_create_tagged_cell (zzz_tagged_type_pointer, address, 
				 (void *) 0,
				 (void *) 1);
}

zzz_scm_t
zzz_make_pointer_n (void * address, unsigned n)
{
  return zzz_create_tagged_cell (zzz_tagged_type_pointer, address, 
				 (void *) ((long) n),
				 (void *) 1);
}



void *
zzz_simple_constructor (zzz_tagged_t tagged, void * data0,
			void * data1, void * data2)
{
  tagged->fill[1] = (zzz_object_t) data0;
  tagged->fill[2] = (zzz_object_t) data1;
  tagged->fill[3] = (zzz_object_t) data2;
  return tagged;
}

void
zzz_simple_mark (zzz_tagged_t tagged)
{
  zzz_mark_cell ((zzz_scm_t) tagged_data0 (tagged));
  zzz_mark_cell ((zzz_scm_t) tagged_data1 (tagged));
  zzz_mark_cell ((zzz_scm_t) tagged_data2 (tagged));
}



/* String constructor function.  Expects a character pointer (or NULL)
   in DATA0 and the string length to allocate as an int in DATA1.  */
static void *
string_constructor (zzz_tagged_t tagged, void * data0,
		    void * data1, void * data2)
{
  char * p = (char *) data0;
  int len =  (int) ((long) data1);
  void * ret;

  ret = zzz_malloc (len + 1);	/* +1 for terminating '\0'.  */
  if (p)
    memmove ((char *) ret, p, len);
  ((char *) ret)[len] = '\0';
  tagged->fill[1] = (zzz_object_t) ret;
  tagged->fill[2] = (zzz_object_t) len;
  return tagged;
}

/* Print the representation for string object DATA to PORT.  */
static void
string_print (zzz_scm_t port, zzz_tagged_t tagged, zzz_print_state_t state)
{
  zzz_scm_t result;
  char * p = tagged_data0 (tagged);
  int len = (long) tagged_data1 (tagged);

  assert (len >= 0);
  if (!(state->flags & (PRINT_ESCAPE | PRINT_QUOTE)))
    zzz_port_puts (port, p, len, &result); /* Fast path for `display'.  */
  else
    {
      if (state->flags & PRINT_QUOTE)
	zzz_port_putc ('"', port, &result);
      while (len-- > 0)
	{
	  if ((state->flags & PRINT_ESCAPE) && (*p == '\\' || *p == '"'))
	    zzz_port_putc ('\\', port, &result);
	  zzz_port_putc (*p, port, &result);
	  p++;
	}
      if (state->flags & PRINT_QUOTE)
	zzz_port_putc ('"', port, &result);
    }
}

/* Free the memory allocated for the string object TAGGED.  */
static void
string_free (zzz_tagged_t tagged)
{
  int len =  (long) tagged_data1 (tagged);
  zzz_free (tagged_data0 (tagged), len + 1); /* + 1 for terminating '\0' */
}

#if 1
static void
string_mark (zzz_tagged_t tagged)
{
  char * p = tagged_data0 (tagged);
  int len = (long) tagged_data1 (tagged);

}
#endif 

/* Returns 1 if the two string objects TAGGED0 and TAGGED1 are equal.  */
static int
string_equal (zzz_tagged_t tagged0, zzz_tagged_t tagged1)
{
  char * p1 = tagged_data0 (tagged0);
  char * p2 = tagged_data0 (tagged1);
  int len1 = (long) tagged_data1 (tagged0);
  int len2 = (long) tagged_data1 (tagged1);

  if (len1 != len2)
    return 0;
  if (len1 == 0)
    return 1;

  len1 = memcmp (p1, p2, len1);
  if (len1)
    return 0;
  else
    return 1;
}



/* Print the representation for character object DATA to PORT.  */
static void
char_print (zzz_scm_t port, zzz_tagged_t tagged, zzz_print_state_t state)
{
  zzz_scm_t result;

  if (state->flags & PRINT_QUOTE)
    {
      zzz_port_putc ('#', port, &result);
      zzz_port_putc ('\\', port, &result);
    }
  zzz_port_putc ((zzz_object_t) tagged_data0 (tagged), port, &result);
}

/* Returns 1 if the two character objects TAGGED0 and TAGGED1 are
   equal.  */
static int
char_equal (zzz_tagged_t tagged0, zzz_tagged_t tagged1)
{
  return tagged_data0 (tagged0) == tagged_data0 (tagged1);
}



static void *
float_constructor (zzz_tagged_t tagged, void * data0,
		   void * data1, void * data2)
{
  *((double *) (tagged->fill + 2)) = *((double *) data0);
  return tagged;
}

/* Print the representation for floating point object DATA to PORT.  */
static void
float_print (zzz_scm_t port, zzz_tagged_t tagged, zzz_print_state_t state)
{
  zzz_scm_t result;

  char buffer[64];
  int len;

  len = sprintf (buffer, "%g", *((double *) (tagged->fill + 2)));
  zzz_port_puts (port, buffer, len, &result);
}

static int
float_equal (zzz_tagged_t tagged0, zzz_tagged_t tagged1)
{
  return *((double *) (tagged0->fill + 2)) ==
    *((double *) (tagged1->fill + 2));
}



/* Print the representation for the symbol DATA to PORT.  */
static void
symbol_print (zzz_scm_t port, zzz_tagged_t tagged, zzz_print_state_t state)
{
  zzz_scm_t result;
  zzz_scm_t name = tagged_data0 (tagged);
  int len = string_len (name);
  char * p = string_val (name);

  while (len-- > 0)
    {
      switch (*p)
	{
	case '(':
	case ')':
	case ';':
	case '"':
	case ' ':
	case '\n':
	case '\r':
	case '\t':
	  zzz_port_putc ('\\', port, &result);
	  zzz_port_putc (*p, port, &result);
	  break;
	default:
	  zzz_port_putc (*p, port, &result);
	  break;
	}
      p++;
    }
}



static void *
func_constructor (zzz_tagged_t tagged, void * data0,
		  void * data1, void * data2)
{
  zzz_func_desc_t desc;

  desc = zzz_malloc (sizeof (struct zzz_func_descriptor));
  desc->func = (zzz_prim_t) data0;
  desc->name = (zzz_scm_t) data1;
  desc->is_form = (int) ((zzz_object_t) data2);
  desc->traced_p = 0;
  desc->documentation = NULL;
  tagged->fill[1] = (zzz_object_t) desc;
  return tagged;
}

/* Print the representation for the primitive function or special form
   DATA to PORT.  */
static void
func_print (zzz_scm_t port, zzz_tagged_t tagged, zzz_print_state_t state)
{
  zzz_scm_t result;
  zzz_func_desc_t desc = (zzz_func_desc_t) tagged_data0 (tagged);

  zzz_port_putc ('#', port, &result);
  zzz_port_putc ('<', port, &result);
  if (desc->is_form)
    zzz_port_puts (port, "macro", 5, &result);
  else
    zzz_port_puts (port, "primitive-procedure", 19, &result);
  zzz_port_putc (' ', port, &result);
  zzz_port_print (port, desc->name, state, &result);
  if (desc->traced_p)
      {
	  zzz_port_puts (port, " traced", 7, &result);
      }
  zzz_port_putc ('>', port, &result);
}

static void
func_free (zzz_tagged_t tagged)
{
  zzz_free (tagged_data0 (tagged), sizeof (struct zzz_func_descriptor));
}

static void
func_mark (zzz_tagged_t tagged)
{
  zzz_func_desc_t desc = tagged_data0 (tagged);

  zzz_mark_cell (desc->documentation);
  zzz_mark_cell (desc->name);
}



static void *
lambda_constructor (zzz_tagged_t tagged, void * data0,
		    void * data1, void * data2)
{
  zzz_scm_t cell = (zzz_scm_t) data0;
  zzz_lambda_desc_t desc;

  desc = zzz_malloc (sizeof (struct zzz_lambda_descriptor));
  desc->name = NULL;
  desc->args = car (cell);
  desc->body = cdr (cell);
  desc->printing = 0;
  desc->traced_p = 0;
  desc->documentation = NULL;
  tagged->fill[1] = (zzz_object_t) desc;
  return tagged;
}

/* Print the representation for the closure DATA to PORT.  */
static void
lambda_print (zzz_scm_t port, zzz_tagged_t tagged, zzz_print_state_t state)
{
  zzz_scm_t result;
  zzz_lambda_desc_t desc = (zzz_lambda_desc_t) tagged_data0 (tagged);
  zzz_scm_t cell;

  zzz_port_puts (port, "#<procedure ", 12, &result);
  if (desc->name)
    {
      zzz_port_print (port, desc->name, state, &result);
      zzz_port_putc (' ', port, &result);
    }
  zzz_port_print (port, desc->args, state, &result);
  if (desc->traced_p)
      {
	  zzz_port_puts (port, " traced", 7, &result);
      }
  if (zzz_state.print_func_bodies)
    {
      cell = desc->body;
      while (cons_p (cell))
	{
	  zzz_port_putc (' ', port, &result);
	  zzz_port_print (port, car (cell), state, &result);
	  cell = cdr (cell);
	}
    }
  zzz_port_putc ('>', port, &result);
}

static void
lambda_free (zzz_tagged_t tagged)
{
  zzz_free (tagged_data0 (tagged), sizeof (struct zzz_lambda_descriptor));
}

static void
lambda_mark (zzz_tagged_t tagged)
{
  zzz_lambda_desc_t desc = tagged_data0 (tagged);

  zzz_mark_cell (desc->name);
  zzz_mark_cell (desc->args);
  zzz_mark_cell (desc->body);
  zzz_mark_cell (desc->documentation);
}



/* Print the representation for the error object DATA to PORT.  */
static void
error_print (zzz_scm_t port, zzz_tagged_t tagged, zzz_print_state_t state)
{
  zzz_scm_t result;
  zzz_scm_t cell = car ((zzz_scm_t) tagged_data0 (tagged));
  zzz_scm_t ref = cdr ((zzz_scm_t) tagged_data0 (tagged));
  struct zzz_print_state ps = {0};

  if (!null_p (ref))
    {
      while (cons_p (ref))
	{
	  zzz_port_print (port, car (ref), &ps, &result);
	  ref = cdr (ref);
	  zzz_port_puts (port, ":", 1, &result);
	}
      if (!null_p (ref))
	{
	  zzz_port_print (port, ref, &ps, &result);
	  zzz_port_puts (port, ":", 1, &result);
	}
    }
  else
    zzz_port_puts (port, "error:", 6, &result);
  zzz_port_puts (port, " ", 1, &result);
  while (cons_p (cell))
    {
      zzz_port_print (port, car (cell), &ps, &result);
      cell = cdr (cell);
    }
  if (!null_p (cell))
    zzz_port_print (port, cell, &ps, &result);
}



/* Print the representation for the exception DATA to PORT.  */
static void
except_print (zzz_scm_t port, zzz_tagged_t tagged, zzz_print_state_t state)
{
  zzz_scm_t result;
  zzz_scm_t cell = (zzz_scm_t) tagged_data0 (tagged);
  zzz_scm_t ref = (zzz_scm_t) tagged_data1 (tagged);
  struct zzz_print_state ps = {0};
  zzz_scm_t exception;

  exception = car (cell);
  cell = cdr (cell);
  if (!null_p (ref))
    {
      while (cons_p (ref))
	{
	  zzz_port_print (port, car (ref), &ps, &result);
	  ref = cdr (ref);
	  zzz_port_puts (port, ":", 1, &result);
	}
      if (!null_p (ref))
	{
	  zzz_port_print (port, ref, &ps, &result);
	  zzz_port_puts (port, ":", 1, &result);
	}
    }
  else
    zzz_port_puts (port, "exception:", 11, &result);
  zzz_port_putc (' ', port, &result);
  zzz_port_print (port, exception, &ps, &result);
  if (!null_p (cell))
    {
      zzz_port_puts (port, ": ", 2, &result);
      while (cons_p (cell))
	{
	  zzz_port_print (port, car (cell), &ps, &result);
	  cell = cdr (cell);
	}
      if (!null_p (cell))
	zzz_port_print (port, cell, &ps, &result);
    }
}



/* Print the representation for the long value DATA to PORT.  */
static void
long_print (zzz_scm_t port, zzz_tagged_t tagged, zzz_print_state_t state)
{
  zzz_scm_t result;
  char buf[32];
  int len;

  len = sprintf (buf, "%ld", (long) tagged_data0 (tagged));
  zzz_port_puts (port, buf, len, &result);
}



/* Print the representation for the environment DATA to PORT.  */
static void
environment_print (zzz_scm_t port, zzz_tagged_t tagged,
		   zzz_print_state_t state)
{
  zzz_scm_t result;
  char buf[32];
  int len;

  len = sprintf (buf, "%8p", tagged_data0 (tagged));
  zzz_port_puts (port, "#<environment ", 14, &result);
  zzz_port_puts (port, buf, len, &result);
  if (tagged_info (tagged) & tagged_info_final)
    zzz_port_puts (port, " final", 6, &result);
  if (tagged_info (tagged) & tagged_info_ro_chain)
    zzz_port_puts (port, " ro-chain", 9, &result);
  zzz_port_print (port, (zzz_scm_t) tagged_data0 (tagged), state, &result);
  zzz_port_puts (port, ">", 1, &result);
}



/* Print the representation for the LOCATION object DATA to PORT.  */
static void
location_print (zzz_scm_t port, zzz_tagged_t tagged, zzz_print_state_t state)
{
  zzz_scm_t result;
  char buf[32];
  int len;

  len = sprintf (buf, "%8p", tagged_data0 (tagged));
  zzz_port_puts (port, "#<location ", 11, &result);
  zzz_port_puts (port, buf, len, &result);
  zzz_port_puts (port, ">", 1, &result);
}



/* Print the representation for the LLOC object DATA to PORT.  */
static void
lloc_print (zzz_scm_t port, zzz_tagged_t tagged, zzz_print_state_t state)
{
  zzz_scm_t result;

  if (zzz_state.print_memoized)
    zzz_port_puts (port, "#<lloc ", 7, &result);
  zzz_port_print (port, lloc_symbol (tagged), state, &result);
  if (zzz_state.print_memoized)
    zzz_port_puts (port, ">", 1, &result);
}



/* Print the representation for the GLOC object DATA to PORT.  */
static void
gloc_print (zzz_scm_t port, zzz_tagged_t tagged, zzz_print_state_t state)
{
  zzz_scm_t result;
  char buf[32];
  int len;

  if (zzz_state.print_memoized)
    {
      len = sprintf (buf, "%p", (void *) tagged->fill[2]);
      zzz_port_puts (port, "#<gloc ", 7, &result);
      zzz_port_puts (port, buf, len, &result);
      zzz_port_puts (port, " ", 1, &result);
    }
  zzz_port_print (port, (zzz_scm_t) tagged_data0 (tagged), state, &result);
  if (zzz_state.print_memoized)
    zzz_port_puts (port, ">", 1, &result);
}



/* Print the representation for the constant object @var{data} to
   @var{port}.  */
static void
constant_print (zzz_scm_t port, zzz_tagged_t tagged, zzz_print_state_t state)
{
  zzz_scm_t result;

  zzz_port_puts (port, "#<constant ", 11, &result);
  zzz_port_print (port, (zzz_scm_t) tagged_data0 (tagged), state, &result);
  zzz_port_puts (port, ">", 1, &result);
}



/* Print the representation for the keyword @var{data} to @var{port}.  */
static void
keyword_print (zzz_scm_t port, zzz_tagged_t tagged, zzz_print_state_t state)
{
  zzz_scm_t name = tagged_data0 (tagged);
  zzz_scm_t result;
  zzz_port_puts (port, "#:", 2, &result);
  zzz_port_print (port, name, state, &result);
}



/* Print the representation for the pointer object @var{data} to
   @var{port}.  */
static void
pointer_print (zzz_scm_t port, zzz_tagged_t tagged, zzz_print_state_t state)
{
  zzz_scm_t result;
  char buf[64];
  int len;

  zzz_port_puts (port, "#<pointer ", 10, &result);
  len = sprintf (buf, "%p [%ld]", pointer_val (tagged), pointer_len (tagged));
  zzz_port_puts (port, buf, len, &result);
  if (!pointer_valid (tagged))
    zzz_port_puts (port, " (invalid)", 10, &result);
  zzz_port_puts (port, ">", 1, &result);
}

static void
pointer_free (zzz_tagged_t tagged)
{
  if (pointer_len (tagged) > 0)
    zzz_free (pointer_val (tagged), pointer_len (tagged));
}



/* Print the representation for the closure @var{tagged} to
   @var{port}.  */
static void
closure_print (zzz_scm_t port, zzz_tagged_t tagged, zzz_print_state_t state)
{
  zzz_scm_t result;
  zzz_scm_t proc = (zzz_scm_t) tagged_data0 (tagged);
  zzz_scm_t env =  (zzz_scm_t) tagged_data1 (tagged);
  int len;
  char buf[32];

  zzz_port_puts (port, "#<closure ", 10, &result);
  zzz_port_print (port, proc, state, &result);
  zzz_port_putc (' ', port, &result);
  len = sprintf (buf, "%p", env);
  zzz_port_puts (port, buf, len, &result);
  zzz_port_putc ('>', port, &result);
}



#ifndef zzz_eq
int
zzz_eq (zzz_scm_t first, zzz_scm_t second)
{
  /* Now that I think of it: Values passed in here should never have
    the GC mark bit set.  So barf if they do though.  */
  assert ((((zzz_object_t) first & 4) == 0) &&
	  (((zzz_object_t) second & 4) == 0));
  return first == second;
}
#endif /* !defined (zzz_eq) */

int
zzz_eqv (zzz_scm_t first, zzz_scm_t second)
{
  if (zzz_eq (first, second))
    return 1;
  
  if (float_p (first))
    {
      if (float_p (second) && float_val (first) == float_val (second))
	return 1;
      if (integer_p (second) &&
	  float_val (first) == (double) integer_val (second))
	return 1;
    }

  if (integer_p (first))
    {
      if (integer_p (second) && integer_val (first) == integer_val (second))
	return 1;
      if (float_p (second) &&
	  (double) integer_val (first) == float_val (second))
	return 1;
    }

  return 0;
}

int
zzz_equal (zzz_scm_t first, zzz_scm_t second)
{
  if (zzz_eqv (first, second))
    return 1;
  if (imm_p (first))
    {
      if (imm_p (second))
	return zzz_eq (first, second);
      else
	return 0;
    }
  else if (cons_p (first))
    {
      if (cons_p (second))
	return zzz_equal (car (first), car (second)) &&
	  zzz_equal (cdr (first), cdr (second));
      else
	return 0;
    }
  else 
    {
      if (imm_p (second) || cons_p (second))
	return 0;
      if (zzz_type_descriptors[tagged_type (first)].equal_func)
	{
	  /* Make sure the two values are comparable.  */
	  if (zzz_type_descriptors[tagged_type (first)].equal_func !=
	      zzz_type_descriptors[tagged_type (second)].equal_func)
	    return 0;
	  return zzz_type_descriptors[tagged_type (first)].
	    equal_func (to_tagged_ptr (first), to_tagged_ptr (second));
	}
      else
	return 0;
    }
}



result_t
zzz_get_symbol_value_ext (zzz_scm_t env, zzz_scm_t symbol, zzz_scm_t * value,
			  int all)
{
  zzz_scm_t last_env = NULL;
  zzz_scm_t val = NULL;
  zzz_scm_t c = NULL;

  /* First, try to locate the symbol in the current environment and
     all environments statically chained onto it.  */
  while (!null_p (env))
    {
      c = env_val (env);
      while (cons_p (c) && !zzz_eq (car (car (c)), symbol))
	c = cdr (c);
      if (cons_p (c))
	break;

      /* Environments marked as final tell us not to descend further
         in the chain, and not to look into the global symbol table.  */
      if (tagged_info (env) & tagged_info_final)
	{
	  *value = zzz_make_misc_error_exception
	    (zzz_cons (zzz_make_string (_("unbound variable: "), -1),
		       zzz_cons (symbol, NULL)));
	  return RESULT_EXCEPTION;
	}
      last_env = env;
      env = env_link (env);
    }

  if (!cons_p (c))
    {
      if (all && symbol_value (symbol) != zzz_undefined)
	{
	  val = symbol_value (symbol);
	}
      else
	{
	  *value = zzz_make_misc_error_exception
	    (zzz_cons (zzz_make_string (_("unbound variable: "), -1),
		       zzz_cons (symbol, NULL)));
	  return RESULT_EXCEPTION;
	}
    }
  else
    val = cdr (car (c));

  if (tagged_p (val))
    {
      zzz_object_t tag = tagged_type (val);
      if (tag == zzz_tagged_type_magic_var)
	{
	  int res;
	  *value = NULL;
	  res = magic_var_handler (val)(MAGIC_MODE_GET, magic_var_data (val),
					value);
	  if (res != 0)
	    {
	      /* Provide a useful error object if the handler did not
                 set any.  */
	      if (!*value)
		{
		  *value = zzz_make_misc_error_exception
		    (zzz_make_list
		     (zzz_make_string
		      (_("error calling getter for variable `"), -1),
		      symbol,
		      zzz_make_string ("'", -1),
		      NULL));
		}
	      return RESULT_EXCEPTION;
	    }
	  if (*value == zzz_undefined)
	    {
	      *value = zzz_make_misc_error_exception
		(zzz_make_list
		 (zzz_make_string (_("unbound variable: "),
				   -1),
		  symbol,
		  NULL));
	      return RESULT_EXCEPTION;
	    }
	}
      else if (location_p (val))
	*value = *location_address (val);
      else if (constant_p (val))
	*value = constant_val (val);
      else
	*value = val;
    }
  else 
    *value = val;
  return RESULT_SUCCESS;
}

result_t
zzz_get_symbol_value (zzz_scm_t env, zzz_scm_t symbol, zzz_scm_t * value)
{
  return zzz_get_symbol_value_ext (env, symbol, value, 1);
}

zzz_scm_t
zzz_get_variable_location (zzz_scm_t env, zzz_scm_t symbol)
{
  zzz_scm_t last_env = NULL;
  zzz_scm_t val = NULL;
  zzz_scm_t c = NULL;
  int env_cnt = 0;
  int offset = 0;

  while (!null_p (env))
    {
      c = env_val (env);
      offset = 0;
      while (cons_p (c) && !zzz_eq (car (car (c)), symbol))
	{
	  offset++;
	  c = cdr (c);
	}
      if (cons_p (c))
	break;

      /* Environments marked as final tell us not to descend further
         in the chain, and not to look into the global symbol table.  */
      if (tagged_info (env) & tagged_info_final)
	return symbol;
      last_env = env;
      env = env_link (env);
      env_cnt++;
    }
  if (cons_p (c))
    {
      val = cdr (car (c));
      if (tagged_p (val))
	{
	  zzz_object_t tag = tagged_type (val);
	  if (tag == zzz_tagged_type_magic_var)
	    return symbol;
	  else if (location_p (val))
	    return zzz_make_gloc (NULL, location_address (val));
	  else if (constant_p (val))
	    return constant_val (val);
	  else
	    return zzz_make_lloc (symbol, env_cnt, offset);
	}
      else
	return zzz_make_lloc (symbol, env_cnt, offset);
    }
  else
    {
      if (symbol_value (symbol) != zzz_undefined)
	{
	  val = symbol_value (symbol);
	  if (tagged_p (val))
	    {
	      zzz_object_t tag = tagged_type (val);
	      if (tag == zzz_tagged_type_magic_var)
		return symbol;
	      else if (location_p (val))
		return zzz_make_gloc (NULL, location_address (val));
	      else if (constant_p (val))
		return constant_val (val);
	      else
		{
		  return zzz_make_gloc (symbol, symbol_value_addr (symbol));
		}
	    }
	  else
	    {
	      return zzz_make_gloc (symbol, symbol_value_addr (symbol));
	    }
	}
      else
	return symbol;
    }
}

result_t
zzz_set_symbol_value (zzz_scm_t env, zzz_scm_t symbol, zzz_scm_t value,
		      zzz_scm_t * result)
{
  zzz_scm_t c = NULL;

  /* Search the environment ENV and all environments chained through
     the static link of the environment. */
  while (!null_p (env))
    {
      c = env_val (env);
      while (cons_p (c) && !zzz_eq (car (car (c)), symbol))
	c = cdr (c);
      if (cons_p (c))
	break;

      /* Environments marked as final tell us not to descend further
         in the chain, and not to look into the global symbol table.  */
      if (tagged_info (env) & tagged_info_final)
	{
	  *result = zzz_make_misc_error_exception
	    (zzz_cons (zzz_make_string (_("undefined variable: "), -1),
		       zzz_cons (symbol, NULL)));
	  return RESULT_EXCEPTION;
	}
      /* Environments below an environment which has a read-only
         marked chain entry must not descent further for set!
         operations.  */
      if (tagged_info (env) & tagged_info_ro_chain)
	{
	  *result = zzz_make_misc_error_exception
	    (zzz_make_list
	     (zzz_make_string (_("attempt to modify read-only variable `"),
			       -1),
	      symbol,
	      zzz_make_string ("'", -1),
	      NULL));
	  return RESULT_EXCEPTION;
	}
      env = env_link (env);
    }
  if (!cons_p (c))
    {
      if (symbol_value (symbol) != zzz_undefined)
	{
	  zzz_scm_t val;

	  val = symbol_value (symbol);
	  if (magic_var_p (val))
	    {
	      int res;
	      if (ro_magic_var_p (val))
		{
		  *result = zzz_make_misc_error_exception
		    (zzz_make_list
		     (zzz_make_string
		      (_("attempt to modify read-only variable `"), -1),
		      symbol, 
		      zzz_make_string ("'", -1),
		      NULL));
		  return RESULT_EXCEPTION;
		}
	      *result = value;
	      res = magic_var_handler (val)(MAGIC_MODE_SET,
					    magic_var_data (val), result);
	      if (res != 0)
		{
		  /* Make sure we get a useful error object, if the user
		     forgot to provide any.  */
		  if (!*result || *result == value)
		    {
		      *result = zzz_make_misc_error_exception
			(zzz_make_list
			 (zzz_make_string
			  (_("error when calling setter for variable `"), -1),
			  symbol, 
			  zzz_make_string ("'", -1),
			  NULL));
		    }
		  return RESULT_EXCEPTION;
		}
	    }
	  else if (location_p (val))
	    {
	      if (ro_location_p (val))
		{
		  *result = zzz_make_misc_error_exception
		    (zzz_cons
		     (zzz_make_string
		      (_("attempt to modify read-only variable `"), -1),
		      zzz_cons (symbol, 
				zzz_cons (zzz_make_string ("'", -1), NULL))));
		  return RESULT_EXCEPTION;
		}
	      *location_address (val) = value;
	    }
	  else if (constant_p (val))
	    {
	      *result = zzz_make_misc_error_exception
		(zzz_cons
		 (zzz_make_string
		  (_("attempt to modify read-only variable `"), -1),
		  zzz_cons (symbol, 
			    zzz_cons (zzz_make_string ("'", -1), NULL))));
	      return RESULT_EXCEPTION;
	    }
	  else
	    set_symbol_value (symbol, value); 
	  return RESULT_SUCCESS;
	}
      else
	{
	  *result = zzz_make_misc_error_exception
	    (zzz_cons (zzz_make_string (_("undefined variable: "), -1),
		       zzz_cons (symbol, NULL)));
	  return RESULT_EXCEPTION;
	}
    }
  else
    {
      if (constant_p (cdr (car (c))))
	{
	  *result = zzz_make_misc_error_exception
	    (zzz_cons
	     (zzz_make_string
	      (_("attempt to modify read-only variable `"), -1),
	      zzz_cons (symbol, 
			zzz_cons (zzz_make_string ("'", -1), NULL))));
	  return RESULT_EXCEPTION;
	}
    }
  /* Set the variable value in the environment.  */
  set_cdr (car (c), value);

  return RESULT_SUCCESS;
}

result_t
zzz_define_symbol_value (zzz_scm_t env, zzz_scm_t symbol, zzz_scm_t value,
			 zzz_scm_t * result)
{
  zzz_scm_t c;

  c = env_val (env);
  while (cons_p (c) && !zzz_eq (car (car (c)), symbol))
    c = cdr (c);
  if (!cons_p (c))
    {
      c = env_val (env);
      if (cons_p (c))
	{
	  while (cons_p (cdr (c)))
	    c = cdr (c);
	  set_cdr (c, zzz_cons (zzz_cons (symbol, value), NULL));
	}
      else
	to_tagged_ptr(env)->fill[1] =
	  (zzz_object_t) zzz_cons (zzz_cons (symbol, value), NULL);
    }
  else
    {
      set_cdr (car (c), value);
      return RESULT_SUCCESS;
    }
  return RESULT_SUCCESS;
}

result_t
zzz_undefine_symbol (zzz_scm_t env, zzz_scm_t symbol, zzz_scm_t * result)
{
  zzz_scm_t c;

  c = env_val (env);
  while (cons_p (c) && !zzz_eq (car (car (c)), symbol))
    {
      c = cdr (c);
    }
  if (!cons_p (c))
    {
      set_symbol_value (symbol, zzz_undefined);
    }
  else
    {
      /* When using constant offsets in the environment lists, we
         cannot delete name/value pairs from the chain, because the
         offsets would then be off-by-one.  So change the symbol slot
         to '(), so that it will not be found on lookup anymore.
         Memoized llocs will continue to work.  Maybe this is a bug.

	 Update: This strange zzz_cons() is needed because the
	 association pair might be shared between modules, so we
	 simply replace the whole pair in the current environment,
	 thus not affecting any other modules.  */
      set_car (c, zzz_cons (NULL, cdr (car (c))));
    }
  return RESULT_SUCCESS;
}



static void
run_hooks (zzz_hook_t hook)
{
  while (hook)
    {
      zzz_hook_t tmp = hook;
      hook = hook->next;
      tmp->func (tmp->data);
    }
}

static void
free_hooks (zzz_hook_t * root)
{
  zzz_hook_t hook = *root;
  *root = NULL;
  while (hook)
    {
      zzz_hook_t tmp = hook;
      hook = hook->next;
      zzz_free (tmp, sizeof (struct hook));
    }
}

void
zzz_install_hook (zzz_hook_t * root, hook_func_t hook, void * data)
{
  zzz_hook_t h = zzz_malloc (sizeof (struct hook));
  h->next = *root;
  h->func = hook;
  h->data = data;
  *root = h;
}

void
zzz_install_shutdown_hook (hook_func_t hook, void * data)
{
  zzz_install_hook (&shutdown_hook_root, hook, data);
}

void
zzz_install_after_mark_hook (hook_func_t hook, void * data)
{
  zzz_install_hook (&after_mark_hook_root, hook, data);
}

void
zzz_install_after_sweep_hook (hook_func_t hook, void * data)
{
  zzz_install_hook (&after_sweep_hook_root, hook, data);
}

void
zzz_run_after_mark_hook (void)
{
  run_hooks (after_mark_hook_root);
}

void
zzz_run_after_sweep_hook (void)
{
  run_hooks (after_sweep_hook_root);
}



zzz_scm_t
zzz_make_not_available_exception (zzz_scm_t args)
{
  return zzz_make_exception (zzz_not_available_exception, args);
}



static void
initialize_modules (void)
{
  zzz_init_nls ();
  zzz_init_reader ();
  zzz_init_symbol ();
  zzz_init_control ();
  zzz_init_syntax ();
  zzz_init_modules ();
  zzz_init_list ();
  zzz_init_stringfun ();
  zzz_init_vector ();
  zzz_init_number ();
  zzz_init_char ();
  zzz_init_boolean ();
  zzz_init_hash ();
  zzz_init_values ();
  zzz_init_promise ();
  zzz_init_cvar ();
  zzz_init_port ();
  zzz_init_sport ();
  zzz_init_fport ();
  zzz_init_fdport ();
  zzz_init_scmport ();
  zzz_init_standard_ports ();
  zzz_init_iofun ();
  zzz_init_posix ();
#if ENABLE_REGEXP && HAVE_REGCOMP
  zzz_init_regexp ();
#endif /* ENABLE_REGEXP */
  zzz_init_eval ();
  zzz_init_macro ();
#if ENABLE_MAXIMUM_FUNCTIONALITY
  zzz_init_net ();
#endif /* ENABLE_MAXIMUM_FUNCTIONALITY */
#if ENABLE_DL
  zzz_init_dynlib ();
#endif /* ENABLE_DL */
#if ENABLE_UVECTOR
  zzz_init_uvector ();
#endif /* ENABLE_UVECTOR */
  zzz_init_doc ();
  zzz_init_sig ();
  zzz_init_profile ();
  zzz_init_pointer ();
  zzz_init_box ();
  /* Note: the following line *must* come last, because it relies that
     the syntactic form and procedure bindings for `safe' procedures
     are already made.  */
  zzz_init_misc ();
}

static void
initialize_variables (void)
{
  char * path, * p;
  zzz_scm_t load_path;

  zzz_state.print_memoized = 0;
  zzz_state.print_func_bodies = 0;
  zzz_state.print_state.flags = PRINT_ESCAPE | PRINT_QUOTE;
  zzz_state.parentheses_nesting = 0;
  zzz_state.remember_source_locations = 0;
  zzz_state.support_mzscheme_brackets = 1;

  /* Initialize global variables.  */
  zzz_state.string_buf_size = 0;
  zzz_state.string_buf_len = 0;
  zzz_state.string_buf = NULL;

/*    zzz_protect_global (&zzz_state.current_input_file_name); */
/*    zzz_state.current_input_file_name = NULL; */

  zzz_protect_global (&zzz_state.source_locations);
  zzz_state.source_locations = zzz_make_hashtable (131);


  zzz_bind_bool_variable ("%print-memoized%",
			  &zzz_state.print_memoized, 0);
  zzz_bind_bool_variable ("%print-func-bodies%",
			  &zzz_state.print_func_bodies, 0);

  zzz_define_constant ("%sizzle-version%",
		       zzz_make_ro_string (__sizzle_version, -1));
  load_path = zzz_make_list (zzz_make_ro_string (SITE_DIR, -1),
			     zzz_make_ro_string (LIBRARY_DIR, -1),
			     zzz_make_ro_string (PKGDATA_DIR, -1),
			     NULL);
  path = getenv ("SIZZLE_LOAD_PATH");
  if (path)
    {
      zzz_scm_t lp = NULL;
      zzz_scm_t * lpp = &lp;
      while (*path)
	{
	  p = path;
	  while (*p && *p != ':')
	    p++;
	  if (p > path)
	    {
	      *lpp = zzz_cons (zzz_make_ro_string (path, p - path), NULL);
	      lpp = cdr_addr (*lpp);
	    }
	  if (*p)
	    p++;
	  path = p;
	}
      *lpp = load_path;
      load_path = lp;
    }
  zzz_define_variable ("%load-path", load_path);
}

static void
finalize_variables (void)
{
  if (zzz_state.string_buf)
    {
      zzz_free (zzz_state.string_buf, zzz_state.string_buf_size);
      zzz_state.string_buf = NULL;
      zzz_state.string_buf_size = 0;
    }
}

void
zzz_initialize (void)
{
  unsigned i;

  zzz_init_gc ();

  /* Predefine some builtin values like character values. */
  for (i = 0; i < 256; i++)
    zzz_char_values[i] = zzz_create_tagged_cell (zzz_tagged_type_char,
						 (void *) ((zzz_object_t) i),
						 NULL, NULL);
  /* The vector module has two init functions, and the first one has
     to be called very early, because the symbol and keyword tables
     depend on the vector data type.  */
  zzz_init_vector_type ();

  /* Create global symbol table and environments. */
  zzz_symbol_table = zzz_make_vector (SYMBOL_TABLE_SIZE);
  zzz_keyword_table = zzz_make_vector (KEYWORD_TABLE_SIZE);

  zzz_protect_global (&zzz_library_environment);
  zzz_protect_global (&zzz_interaction_environment);
  zzz_protect_global (&zzz_current_environment);

  zzz_library_environment = zzz_make_environment (631, NULL, 0, 0);
  zzz_interaction_environment = zzz_make_environment (137,
						      zzz_library_environment,
						      0, 0);
  zzz_current_environment = zzz_interaction_environment;
  
  zzz_protect_global (&zzz_backtrace);

  zzz_protect_global (&zzz_command_line_list);
  zzz_command_line_list = NULL;

  zzz_protect_global (&zzz_else_sym);
  zzz_protect_global (&zzz_quote_sym);
  zzz_protect_global (&zzz_quasiquote_sym);
  zzz_protect_global (&zzz_unquote_sym);
  zzz_protect_global (&zzz_unquote_splicing_sym);
  zzz_protect_global (&zzz_dot_sym);
  zzz_protect_global (&zzz_dots_sym);
  zzz_protect_global (&zzz_arrow_sym);

  /* Predefine some symbols which have a special meaning in Scheme.
     They are needed by the evaluator (`else', `=>', etc.) and the
     reader (`quote', `qasiquote', `.', etc.)  */
  zzz_else_sym = zzz_make_symbol ("else", -1);
  zzz_quote_sym = zzz_make_symbol ("quote", -1);
  zzz_quasiquote_sym = zzz_make_symbol ("quasiquote", -1);
  zzz_unquote_sym = zzz_make_symbol ("unquote", -1);
  zzz_unquote_splicing_sym = zzz_make_symbol ("unquote-splicing", -1);
  zzz_dot_sym = zzz_make_symbol (".", -1);
  zzz_dots_sym = zzz_make_symbol ("...", -1);
  zzz_arrow_sym = zzz_make_symbol ("=>", -1);

  /*:doc
    not-available
    Exception
    Thrown when a primitive is not properly implemented on the current
    system.
    doc:*/
  zzz_protect_global (&zzz_not_available_exception);
  zzz_not_available_exception = zzz_make_symbol ("not-available", -1);

  /* Initialize all modules.  This will let them register additional
     tagged types and the primitives they provide.  */
  initialize_modules ();

  zzz_protect_global (&zzz_current_module);
  zzz_current_module = zzz_make_module
    (zzz_make_list
     (zzz_make_symbol ("system", -1), zzz_make_symbol ("sizzle", -1), NULL));
  module_private (zzz_current_module) = zzz_interaction_environment;
  
  /* Bind some Sizzle variables and constants to global C
     variables. */
  zzz_init_gc_variables ();
  initialize_variables ();

  /* This needs explanation: On ia64, the gcc does not properly
     support setjmp()/longjmp(), so conservative garbage collection is
     not able to find all GC roots which may be in registers at GC
     invocation.  So for now, we simply disable garbage collection
     until the problem is fixed :( 2000-11-08/mgrabmue */
#ifdef __ia64__
  zzz_gc_lock ();
#endif
}

void
zzz_finalize (void)
{
  run_hooks (shutdown_hook_root);

  free_hooks (&shutdown_hook_root);
  free_hooks (&after_mark_hook_root);
  free_hooks (&after_sweep_hook_root);

  /* The signal module needs to restore signal settings.  */
  zzz_finalize_sig ();

  finalize_variables ();

  /* Free all dynamically allocated memory the reader may have
     allocated.  */
  zzz_finalize_reader ();
  /* Free the cons and tagged cell heaps.  */
  zzz_finalize_gc ();
}

int
zzz_run (int (* main)(int argc, char * argv[]), int argc, char * argv[])
{
  zzz_scm_t dummy;
  int ret_val;

  /* Remember this stack position so that we know where we have to
     start our search for live Sizzle values on the C stack. */
  zzz_set_top_of_stack (&dummy);

  zzz_initialize ();
  ret_val = main (argc, argv);
  zzz_finalize ();
  return ret_val;
}

void
zzz_set_arguments (int argc, char * argv0, char * argv[])
{
  zzz_scm_t command_line = NULL;
  zzz_scm_t * pp = &command_line;
  int i = 0;

  while (argc-- > 0)
    {
      *pp = zzz_cons (zzz_make_ro_string (argv[i], -1), NULL);
      pp = cdr_addr (*pp);
      i++;		    
    }
  zzz_command_line_list = zzz_cons (zzz_make_ro_string (argv0, -1),
				    command_line);
}
