code:
/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 2008 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 2.1 of the License, or (at your option) any later version.
 *
 * This library 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
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 */

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

#include <assert.h>

#include "libguile/_scm.h"
#include "libguile/eval.h"
#include "libguile/alist.h"
#include "libguile/fluids.h"
#include "libguile/ports.h"
#include "libguile/smob.h"

#include "libguile/dynwind.h"

/* {Dynamic wind}

   Things that can be on the wind list:

   #<frame>
   #<winder>
   (enter-proc . leave-proc)     dynamic-wind
   (tag . jmpbuf)                catch
   (tag . pre-unwind-data)       throw-handler / lazy-catch
     tag is either a symbol or a boolean

*/

SCM_DEFINE (scm_dynamic_wind, "dynamic-wind", 3, 0, 0,
           (SCM in_guard, SCM thunk, SCM out_guard),
	    "All three arguments must be 0-argument procedures.\n"
	    "@var{in_guard} is called, then @var{thunk}, then\n"
	    "@var{out_guard}.\n"
	    "\n"
	    "If, any time during the execution of @var{thunk}, the\n"
	    "continuation of the @code{dynamic_wind} expression is escaped\n"
	    "non-locally, @var{out_guard} is called.  If the continuation of\n"
	    "the dynamic-wind is re-entered, @var{in_guard} is called.  Thus\n"
	    "@var{in_guard} and @var{out_guard} may be called any number of\n"
	    "times.\n"
	    "@lisp\n"
	    "(define x 'normal-binding)\n"
	    "@result{} x\n"
	    "(define a-cont  (call-with-current-continuation\n"
	    "		  (lambda (escape)\n"
	    "		     (let ((old-x x))\n"
	    "		       (dynamic-wind\n"
	    "			  ;; in-guard:\n"
	    "			  ;;\n"
	    "			  (lambda () (set! x 'special-binding))\n"
	    "\n"
	    "			  ;; thunk\n"
	    "			  ;;\n"
	    "		 	  (lambda () (display x) (newline)\n"
	    "				     (call-with-current-continuation escape)\n"
	    "				     (display x) (newline)\n"
	    "				     x)\n"
	    "\n"
	    "			  ;; out-guard:\n"
	    "			  ;;\n"
	    "			  (lambda () (set! x old-x)))))))\n"
	    "\n"
	    ";; Prints:\n"
	    "special-binding\n"
	    ";; Evaluates to:\n"
	    "@result{} a-cont\n"
	    "x\n"
	    "@result{} normal-binding\n"
	    "(a-cont #f)\n"
	    ";; Prints:\n"
	    "special-binding\n"
	    ";; Evaluates to:\n"
	    "@result{} a-cont  ;; the value of the (define a-cont...)\n"
	    "x\n"
	    "@result{} normal-binding\n"
	    "a-cont\n"
	    "@result{} special-binding\n"
	    "@end lisp")
#define FUNC_NAME s_scm_dynamic_wind
{
  SCM ans, old_winds;
  SCM_ASSERT (scm_is_true (scm_thunk_p (out_guard)),
	      out_guard,
	      SCM_ARG3, FUNC_NAME);
  scm_call_0 (in_guard);
  old_winds = scm_i_dynwinds ();
  scm_i_set_dynwinds (scm_acons (in_guard, out_guard, old_winds));
  ans = scm_call_0 (thunk);
  scm_i_set_dynwinds (old_winds);
  scm_call_0 (out_guard);
  return ans;
}
#undef FUNC_NAME

SCM
scm_internal_dynamic_wind (scm_t_guard before,
			   scm_t_inner inner,
			   scm_t_guard after,
			   void *inner_data,
			   void *guard_data)
{
  SCM ans;

  scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
  scm_dynwind_rewind_handler (before, guard_data, SCM_F_WIND_EXPLICITLY);
  scm_dynwind_unwind_handler (after, guard_data, SCM_F_WIND_EXPLICITLY);
  ans = inner (inner_data);
  scm_dynwind_end ();
  return ans;
}

/* Frames and winders. */

static scm_t_bits tc16_frame;
#define FRAME_P(f)     SCM_SMOB_PREDICATE (tc16_frame, (f))

#define FRAME_F_REWINDABLE    (1 << 0)
#define FRAME_REWINDABLE_P(f) (SCM_SMOB_FLAGS(f) & FRAME_F_REWINDABLE)

static scm_t_bits tc16_winder;
#define WINDER_P(w)     SCM_SMOB_PREDICATE (tc16_winder, (w))
#define WINDER_PROC(w)  ((void (*)(void *))SCM_SMOB_DATA (w))
#define WINDER_DATA(w)  ((void *)SCM_SMOB_DATA_2 (w))

#define WINDER_F_EXPLICIT    (1 << 0)
#define WINDER_F_REWIND      (1 << 1)
#define WINDER_F_MARK        (1 << 2)
#define WINDER_EXPLICIT_P(w) (SCM_SMOB_FLAGS(w) & WINDER_F_EXPLICIT)
#define WINDER_REWIND_P(w)   (SCM_SMOB_FLAGS(w) & WINDER_F_REWIND)
#define WINDER_MARK_P(w)     (SCM_SMOB_FLAGS(w) & WINDER_F_MARK)

void
scm_dynwind_begin (scm_t_dynwind_flags flags)
{
  SCM f;
  SCM_NEWSMOB (f, tc16_frame, 0);
  if (flags & SCM_F_DYNWIND_REWINDABLE)
    SCM_SET_SMOB_FLAGS (f, FRAME_F_REWINDABLE);
  scm_i_set_dynwinds (scm_cons (f, scm_i_dynwinds ()));
}

void
scm_dynwind_end (void)
{
  SCM winds;

  /* Unwind upto and including the next frame entry.  We can only
     encounter #<winder> entries on the way.
   */

  winds = scm_i_dynwinds ();
  while (scm_is_pair (winds))
    {
      SCM entry = SCM_CAR (winds);
      winds = SCM_CDR (winds);

      scm_i_set_dynwinds (winds);

      if (FRAME_P (entry))
	return;

      assert (WINDER_P (entry));
      if (!WINDER_REWIND_P (entry) && WINDER_EXPLICIT_P (entry))
	WINDER_PROC(entry) (WINDER_DATA (entry));
    }

  assert (0);
}

static SCM
winder_mark (SCM w)
{
  if (WINDER_MARK_P (w))
    return SCM_PACK (WINDER_DATA (w));
  return SCM_BOOL_F;
}

void
scm_dynwind_unwind_handler (void (*proc) (void *), void *data,
			    scm_t_wind_flags flags)
{
  SCM w;
  SCM_NEWSMOB2 (w, tc16_winder,	(scm_t_bits) proc, (scm_t_bits) data);
  if (flags & SCM_F_WIND_EXPLICITLY)
    SCM_SET_SMOB_FLAGS (w, WINDER_F_EXPLICIT);
  scm_i_set_dynwinds (scm_cons (w, scm_i_dynwinds ()));
}

void
scm_dynwind_rewind_handler (void (*proc) (void *), void *data,
			    scm_t_wind_flags flags)
{
  SCM w;
  SCM_NEWSMOB2 (w, tc16_winder,	(scm_t_bits) proc, (scm_t_bits) data);
  SCM_SET_SMOB_FLAGS (w, WINDER_F_REWIND);
  scm_i_set_dynwinds (scm_cons (w, scm_i_dynwinds ()));
  if (flags & SCM_F_WIND_EXPLICITLY)
    proc (data);
}

void
scm_dynwind_unwind_handler_with_scm (void (*proc) (SCM), SCM data,
				     scm_t_wind_flags flags)
{
  SCM w;
  scm_t_bits fl = ((flags&SCM_F_WIND_EXPLICITLY)? WINDER_F_EXPLICIT : 0);
  SCM_NEWSMOB2 (w, tc16_winder,	(scm_t_bits) proc, SCM_UNPACK (data));
  SCM_SET_SMOB_FLAGS (w, fl | WINDER_F_MARK);
  scm_i_set_dynwinds (scm_cons (w, scm_i_dynwinds ()));
}

void
scm_dynwind_rewind_handler_with_scm (void (*proc) (SCM), SCM data,
				     scm_t_wind_flags flags)
{
  SCM w;
  SCM_NEWSMOB2 (w, tc16_winder, (scm_t_bits) proc, SCM_UNPACK (data));
  SCM_SET_SMOB_FLAGS (w, WINDER_F_REWIND | WINDER_F_MARK);
  scm_i_set_dynwinds (scm_cons (w, scm_i_dynwinds ()));
  if (flags & SCM_F_WIND_EXPLICITLY)
    proc (data);
}

void
scm_dynwind_free (void *mem)
{
  scm_dynwind_unwind_handler (free, mem, SCM_F_WIND_EXPLICITLY);
}

#ifdef GUILE_DEBUG
SCM_DEFINE (scm_wind_chain, "wind-chain", 0, 0, 0,
            (),
	    "Return the current wind chain. The wind chain contains all\n"
	    "information required by @code{dynamic-wind} to call its\n"
	    "argument thunks when entering/exiting its scope.")
#define FUNC_NAME s_scm_wind_chain
{
  return scm_i_dynwinds ();
}
#undef FUNC_NAME
#endif

void
scm_swap_bindings (SCM vars, SCM vals)
{
  SCM tmp;
  while (SCM_NIMP (vals))
    {
      tmp = SCM_VARIABLE_REF (SCM_CAR (vars));
      SCM_VARIABLE_SET (SCM_CAR (vars), SCM_CAR (vals));
      SCM_SETCAR (vals, tmp);
      vars = SCM_CDR (vars);
      vals = SCM_CDR (vals);
    }
}

void
scm_dowinds (SCM to, long delta)
{
  scm_i_dowinds (to, delta, NULL, NULL);
}

void
scm_i_dowinds (SCM to, long delta, void (*turn_func) (void *), void *data)
{
 tail:
  if (scm_is_eq (to, scm_i_dynwinds ()))
    {
      if (turn_func)
	turn_func (data);
    }
  else if (delta < 0)
    {
      SCM wind_elt;
      SCM wind_key;

      scm_i_dowinds (SCM_CDR (to), 1 + delta, turn_func, data);
      wind_elt = SCM_CAR (to);

      if (FRAME_P (wind_elt))
	{
	  if (!FRAME_REWINDABLE_P (wind_elt))
	    scm_misc_error ("dowinds",
			    "cannot invoke continuation from this context",
			    SCM_EOL);
	}
      else if (WINDER_P (wind_elt))
	{
	  if (WINDER_REWIND_P (wind_elt))
	    WINDER_PROC (wind_elt) (WINDER_DATA (wind_elt));
	}
      else
	{
	  wind_key = SCM_CAR (wind_elt);
	  /* key = #t | symbol | thunk | list of variables */
	  if (SCM_NIMP (wind_key))
	    {
	      if (scm_is_pair (wind_key))
		{
		  if (SCM_VARIABLEP (SCM_CAR (wind_key)))
		    scm_swap_bindings (wind_key, SCM_CDR (wind_elt));
		}
	      else if (SCM_TYP3 (wind_key) == scm_tc3_closure)
		scm_call_0 (wind_key);
	    }
	}

      scm_i_set_dynwinds (to);
    }
  else
    {
      SCM wind;
      SCM wind_elt;
      SCM wind_key;

      wind = scm_i_dynwinds ();
      wind_elt = SCM_CAR (wind);
      scm_i_set_dynwinds (SCM_CDR (wind));

      if (FRAME_P (wind_elt))
	{
	  /* Nothing to do. */
	}
      else if (WINDER_P (wind_elt))
	{
	  if (!WINDER_REWIND_P (wind_elt))
	    WINDER_PROC (wind_elt) (WINDER_DATA (wind_elt));
	}
      else
	{
	  wind_key = SCM_CAR (wind_elt);
	  if (SCM_NIMP (wind_key))
	    {
	      if (scm_is_pair (wind_key))
		{
		  if (SCM_VARIABLEP (SCM_CAR (wind_key)))
		    scm_swap_bindings (wind_key, SCM_CDR (wind_elt));
		}
	      else if (SCM_TYP3 (wind_key) == scm_tc3_closure)
		scm_call_0 (SCM_CDR (wind_elt));
	    }
	}

      delta--;
      goto tail;		/* scm_dowinds(to, delta-1); */
    }
}

void
scm_init_dynwind ()
{
  tc16_frame = scm_make_smob_type ("frame", 0);

  tc16_winder = scm_make_smob_type ("winder", 0);
  scm_set_smob_mark (tc16_winder, winder_mark);

#include "libguile/dynwind.x"
}

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/


code:
/* classes: h_files */

#ifndef SCM_DYNWIND_H
#define SCM_DYNWIND_H

/* Copyright (C) 1995,1996,1998,1999,2000,2003,2004, 2006 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 2.1 of the License, or (at your option) any later version.
 *
 * This library 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
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 */

#include "libguile/__scm.h"

typedef void (*scm_t_guard) (void *);
typedef SCM (*scm_t_inner) (void *);

SCM_API SCM scm_dynamic_wind (SCM thunk1, SCM thunk2, SCM thunk3);
SCM_API SCM scm_internal_dynamic_wind (scm_t_guard before,
				       scm_t_inner inner,
				       scm_t_guard after,
				       void *inner_data,
				       void *guard_data);
SCM_API void scm_dowinds (SCM to, long delta);
SCM_API void scm_i_dowinds (SCM to, long delta,
			    void (*turn_func) (void *), void *data);
SCM_API void scm_init_dynwind (void);

SCM_API void scm_swap_bindings (SCM vars, SCM vals);

typedef enum {
  SCM_F_DYNWIND_REWINDABLE = (1 << 0)
} scm_t_dynwind_flags;

typedef enum {
  SCM_F_WIND_EXPLICITLY = (1 << 0)
} scm_t_wind_flags;

SCM_API void scm_dynwind_begin (scm_t_dynwind_flags);
SCM_API void scm_dynwind_end (void);

SCM_API void scm_dynwind_unwind_handler (void (*func) (void *), void *data,
					 scm_t_wind_flags);
SCM_API void scm_dynwind_rewind_handler (void (*func) (void *), void *data,
					 scm_t_wind_flags);

SCM_API void scm_dynwind_unwind_handler_with_scm (void (*func) (SCM), SCM data,
						  scm_t_wind_flags);
SCM_API void scm_dynwind_rewind_handler_with_scm (void (*func) (SCM), SCM data,
						  scm_t_wind_flags);

SCM_API void scm_dynwind_free (void *mem);

#ifdef GUILE_DEBUG
SCM_API SCM scm_wind_chain (void);
#endif /*GUILE_DEBUG*/

#endif  /* SCM_DYNWIND_H */

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/

license: unknown


code:
/* Copyright (C) 1999,2000,2001, 2003, 2006, 2008 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 2.1 of the License, or (at your option) any later version.
 *
 * This library 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
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 */

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

#include "libguile/_scm.h"
#include "libguile/alist.h"
#include "libguile/eval.h"
#include "libguile/gh.h"
#include "libguile/hash.h"
#include "libguile/list.h"
#include "libguile/ports.h"
#include "libguile/smob.h"
#include "libguile/symbols.h"
#include "libguile/vectors.h"
#include "libguile/weaks.h"

#include "libguile/environments.h"

scm_t_bits scm_tc16_environment;
scm_t_bits scm_tc16_observer;
#define DEFAULT_OBARRAY_SIZE 31

SCM scm_system_environment;

/* error conditions */

/*
 * Throw an error if symbol is not bound in environment func
 */
void
scm_error_environment_unbound (const char *func, SCM env, SCM symbol)
{
  /* Dirk:FIXME:: Should throw an environment:unbound type error */
  char error[] = "Symbol `~A' not bound in environment `~A'.";
  SCM arguments = scm_cons2 (symbol, env, SCM_EOL);
  scm_misc_error (func, error, arguments);
}

/*
 * Throw an error if func tried to create (define) or remove
 * (undefine) a new binding for symbol in env
 */
void
scm_error_environment_immutable_binding (const char *func, SCM env, SCM symbol)
{
  /* Dirk:FIXME:: Should throw an environment:immutable-binding type error */
  char error[] = "Immutable binding in environment ~A (symbol: `~A').";
  SCM arguments = scm_cons2 (env, symbol, SCM_EOL);
  scm_misc_error (func, error, arguments);
}

/*
 * Throw an error if func tried to change an immutable location.
 */
void
scm_error_environment_immutable_location (const char *func, SCM env, SCM symbol)
{
  /* Dirk:FIXME:: Should throw an environment:immutable-location type error */
  char error[] = "Immutable location in environment `~A' (symbol: `~A').";
  SCM arguments = scm_cons2 (env, symbol, SCM_EOL);
  scm_misc_error (func, error, arguments);
}

/* generic environments */

/* Create an environment for the given type.  Dereferencing type twice must
 * deliver the initialized set of environment functions.  Thus, type will
 * also determine the signature of the underlying environment implementation.
 * Dereferencing type once will typically deliver the data fields used by the
 * underlying environment implementation.
 */
SCM
scm_make_environment (void *type)
{
  return scm_cell (scm_tc16_environment, (scm_t_bits) type);
}

SCM_DEFINE (scm_environment_p, "environment?", 1, 0, 0,
	    (SCM obj),
	    "Return @code{#t} if @var{obj} is an environment, or @code{#f}\n"
	    "otherwise.")
#define FUNC_NAME s_scm_environment_p
{
  return scm_from_bool (SCM_ENVIRONMENT_P (obj));
}
#undef FUNC_NAME

SCM_DEFINE (scm_environment_bound_p, "environment-bound?", 2, 0, 0,
	    (SCM env, SCM sym),
	    "Return @code{#t} if @var{sym} is bound in @var{env}, or\n"
	    "@code{#f} otherwise.")
#define FUNC_NAME s_scm_environment_bound_p
{
  SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
  SCM_ASSERT (scm_is_symbol (sym), sym, SCM_ARG2, FUNC_NAME);

  return scm_from_bool (SCM_ENVIRONMENT_BOUND_P (env, sym));
}
#undef FUNC_NAME

SCM_DEFINE (scm_environment_ref, "environment-ref", 2, 0, 0,
	    (SCM env, SCM sym),
	    "Return the value of the location bound to @var{sym} in\n"
	    "@var{env}. If @var{sym} is unbound in @var{env}, signal an\n"
	    "@code{environment:unbound} error.")
#define FUNC_NAME s_scm_environment_ref
{
  SCM val;

  SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
  SCM_ASSERT (scm_is_symbol (sym), sym, SCM_ARG2, FUNC_NAME);

  val = SCM_ENVIRONMENT_REF (env, sym);

  if (!SCM_UNBNDP (val))
    return val;
  else
    scm_error_environment_unbound (FUNC_NAME, env, sym);
}
#undef FUNC_NAME

/* This C function is identical to environment-ref, except that if symbol is
 * unbound in env, it returns the value SCM_UNDEFINED, instead of signalling
 * an error.
 */
SCM
scm_c_environment_ref (SCM env, SCM sym)
{
  SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, "scm_c_environment_ref");
  SCM_ASSERT (scm_is_symbol (sym), sym, SCM_ARG2, "scm_c_environment_ref");
  return SCM_ENVIRONMENT_REF (env, sym);
}

static SCM
environment_default_folder (SCM proc, SCM symbol, SCM value, SCM tail)
{
  return scm_call_3 (proc, symbol, value, tail);
}

SCM_DEFINE (scm_environment_fold, "environment-fold", 3, 0, 0,
	    (SCM env, SCM proc, SCM init),
	    "Iterate over all the bindings in @var{env}, accumulating some\n"
	    "value.\n"
	    "For each binding in @var{env}, apply @var{proc} to the symbol\n"
	    "bound, its value, and the result from the previous application\n"
	    "of @var{proc}.\n"
	    "Use @var{init} as @var{proc}'s third argument the first time\n"
	    "@var{proc} is applied.\n"
	    "If @var{env} contains no bindings, this function simply returns\n"
	    "@var{init}.\n"
	    "If @var{env} binds the symbol sym1 to the value val1, sym2 to\n"
	    "val2, and so on, then this procedure computes:\n"
	    "@lisp\n"
	    "  (proc sym1 val1\n"
	    "        (proc sym2 val2\n"
	    "              ...\n"
	    "              (proc symn valn\n"
	    "                    init)))\n"
	    "@end lisp\n"
	    "Each binding in @var{env} will be processed exactly once.\n"
	    "@code{environment-fold} makes no guarantees about the order in\n"
	    "which the bindings are processed.\n"
	    "Here is a function which, given an environment, constructs an\n"
	    "association list representing that environment's bindings,\n"
	    "using environment-fold:\n"
	    "@lisp\n"
	    "  (define (environment->alist env)\n"
	    "    (environment-fold env\n"
	    "                      (lambda (sym val tail)\n"
	    "                        (cons (cons sym val) tail))\n"
	    "                      '()))\n"
	    "@end lisp")
#define FUNC_NAME s_scm_environment_fold
{
  SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
  SCM_ASSERT (scm_is_true (scm_procedure_p (proc)),
	      proc, SCM_ARG2, FUNC_NAME);

  return SCM_ENVIRONMENT_FOLD (env, environment_default_folder, proc, init);
}
#undef FUNC_NAME

/* This is the C-level analog of environment-fold. For each binding in ENV,
 * make the call:
 *   (*proc) (data, symbol, value, previous)
 * where previous is the value returned from the last call to *PROC, or INIT
 * for the first call. If ENV contains no bindings, return INIT.
 */
SCM
scm_c_environment_fold (SCM env, scm_environment_folder proc, SCM data, SCM init)
{
  SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, "scm_c_environment_fold");

  return SCM_ENVIRONMENT_FOLD (env, proc, data, init);
}

SCM_DEFINE (scm_environment_define, "environment-define", 3, 0, 0,
	    (SCM env, SCM sym, SCM val),
	    "Bind @var{sym} to a new location containing @var{val} in\n"
	    "@var{env}. If @var{sym} is already bound to another location\n"
	    "in @var{env} and the binding is mutable, that binding is\n"
	    "replaced.  The new binding and location are both mutable. The\n"
	    "return value is unspecified.\n"
	    "If @var{sym} is already bound in @var{env}, and the binding is\n"
	    "immutable, signal an @code{environment:immutable-binding} error.")
#define FUNC_NAME s_scm_environment_define
{
  SCM status;

  SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
  SCM_ASSERT (scm_is_symbol (sym), sym, SCM_ARG2, FUNC_NAME);

  status = SCM_ENVIRONMENT_DEFINE (env, sym, val);

  if (scm_is_eq (status, SCM_ENVIRONMENT_SUCCESS))
    return SCM_UNSPECIFIED;
  else if (scm_is_eq (status, SCM_ENVIRONMENT_BINDING_IMMUTABLE))
    scm_error_environment_immutable_binding (FUNC_NAME, env, sym);
  else
    abort();
}
#undef FUNC_NAME

SCM_DEFINE (scm_environment_undefine, "environment-undefine", 2, 0, 0,
	    (SCM env, SCM sym),
	    "Remove any binding for @var{sym} from @var{env}. If @var{sym}\n"
	    "is unbound in @var{env}, do nothing.  The return value is\n"
	    "unspecified.\n"
	    "If @var{sym} is already bound in @var{env}, and the binding is\n"
	    "immutable, signal an @code{environment:immutable-binding} error.")
#define FUNC_NAME s_scm_environment_undefine
{
  SCM status;

  SCM_ASSERT(SCM_ENVIRONMENT_P(env), env, SCM_ARG1, FUNC_NAME);
  SCM_ASSERT(scm_is_symbol(sym), sym, SCM_ARG2, FUNC_NAME);

  status = SCM_ENVIRONMENT_UNDEFINE (env, sym);

  if (scm_is_eq (status, SCM_ENVIRONMENT_SUCCESS))
    return SCM_UNSPECIFIED;
  else if (scm_is_eq (status, SCM_ENVIRONMENT_BINDING_IMMUTABLE))
    scm_error_environment_immutable_binding (FUNC_NAME, env, sym);
  else
    abort();
}
#undef FUNC_NAME

SCM_DEFINE (scm_environment_set_x, "environment-set!", 3, 0, 0,
	    (SCM env, SCM sym, SCM val),
	    "If @var{env} binds @var{sym} to some location, change that\n"
	    "location's value to @var{val}.  The return value is\n"
	    "unspecified.\n"
	    "If @var{sym} is not bound in @var{env}, signal an\n"
	    "@code{environment:unbound} error.  If @var{env} binds @var{sym}\n"
	    "to an immutable location, signal an\n"
	    "@code{environment:immutable-location} error.")
#define FUNC_NAME s_scm_environment_set_x
{
  SCM status;

  SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
  SCM_ASSERT (scm_is_symbol (sym), sym, SCM_ARG2, FUNC_NAME);

  status = SCM_ENVIRONMENT_SET (env, sym, val);

  if (scm_is_eq (status, SCM_ENVIRONMENT_SUCCESS))
    return SCM_UNSPECIFIED;
  else if (SCM_UNBNDP (status))
    scm_error_environment_unbound (FUNC_NAME, env, sym);
  else if (scm_is_eq (status, SCM_ENVIRONMENT_LOCATION_IMMUTABLE))
    scm_error_environment_immutable_binding (FUNC_NAME, env, sym);
  else
    abort();
}
#undef FUNC_NAME

SCM_DEFINE (scm_environment_cell, "environment-cell", 3, 0, 0,
	    (SCM env, SCM sym, SCM for_write),
	    "Return the value cell which @var{env} binds to @var{sym}, or\n"
	    "@code{#f} if the binding does not live in a value cell.\n"
	    "The argument @var{for-write} indicates whether the caller\n"
	    "intends to modify the variable's value by mutating the value\n"
	    "cell.  If the variable is immutable, then\n"
	    "@code{environment-cell} signals an\n"
	    "@code{environment:immutable-location} error.\n"
	    "If @var{sym} is unbound in @var{env}, signal an\n"
	    "@code{environment:unbound} error.\n"
	    "If you use this function, you should consider using\n"
	    "@code{environment-observe}, to be notified when @var{sym} gets\n"
	    "re-bound to a new value cell, or becomes undefined.")
#define FUNC_NAME s_scm_environment_cell
{
  SCM location;

  SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
  SCM_ASSERT (scm_is_symbol (sym), sym, SCM_ARG2, FUNC_NAME);
  SCM_ASSERT (scm_is_bool (for_write), for_write, SCM_ARG3, FUNC_NAME);

  location = SCM_ENVIRONMENT_CELL (env, sym, scm_is_true (for_write));
  if (!SCM_IMP (location))
    return location;
  else if (SCM_UNBNDP (location))
    scm_error_environment_unbound (FUNC_NAME, env, sym);
  else if (scm_is_eq (location, SCM_ENVIRONMENT_LOCATION_IMMUTABLE))
    scm_error_environment_immutable_location (FUNC_NAME, env, sym);
  else /* no cell */
    return location;
}
#undef FUNC_NAME

/* This C function is identical to environment-cell, with the following
 * exceptions:   If symbol is unbound in env, it returns the value
 * SCM_UNDEFINED, instead of signalling an error.  If symbol is bound to an
 * immutable location but the cell is requested for write, the value
 * SCM_ENVIRONMENT_LOCATION_IMMUTABLE is returned.
 */
SCM
scm_c_environment_cell(SCM env, SCM sym, int for_write)
{
  SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, "scm_c_environment_cell");
  SCM_ASSERT (scm_is_symbol (sym), sym, SCM_ARG2, "scm_c_environment_cell");

  return SCM_ENVIRONMENT_CELL (env, sym, for_write);
}

static void
environment_default_observer (SCM env, SCM proc)
{
  scm_call_1 (proc, env);
}

SCM_DEFINE (scm_environment_observe, "environment-observe", 2, 0, 0,
	    (SCM env, SCM proc),
	    "Whenever @var{env}'s bindings change, apply @var{proc} to\n"
	    "@var{env}.\n"
	    "This function returns an object, token, which you can pass to\n"
	    "@code{environment-unobserve} to remove @var{proc} from the set\n"
	    "of procedures observing @var{env}.  The type and value of\n"
	    "token is unspecified.")
#define FUNC_NAME s_scm_environment_observe
{
  SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);

  return SCM_ENVIRONMENT_OBSERVE (env, environment_default_observer, proc, 0);
}
#undef FUNC_NAME

SCM_DEFINE (scm_environment_observe_weak, "environment-observe-weak", 2, 0, 0,
	    (SCM env, SCM proc),
	    "This function is the same as environment-observe, except that\n"
	    "the reference @var{env} retains to @var{proc} is a weak\n"
	    "reference. This means that, if there are no other live,\n"
	    "non-weak references to @var{proc}, it will be\n"
	    "garbage-collected, and dropped from @var{env}'s\n"
	    "list of observing procedures.")
#define FUNC_NAME s_scm_environment_observe_weak
{
  SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);

  return SCM_ENVIRONMENT_OBSERVE (env, environment_default_observer, proc, 1);
}
#undef FUNC_NAME

/* This is the C-level analog of the Scheme functions environment-observe and
 * environment-observe-weak.  Whenever env's bindings change, call the
 * function proc, passing it env and data. If weak_p is non-zero, env will
 * retain only a weak reference to data, and if data is garbage collected, the
 * entire observation will be dropped.  This function returns a token, with
 * the same meaning as those returned by environment-observe and
 * environment-observe-weak.
 */
SCM
scm_c_environment_observe (SCM env, scm_environment_observer proc, SCM data, int weak_p)
#define FUNC_NAME "scm_c_environment_observe"
{
  SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);

  return SCM_ENVIRONMENT_OBSERVE (env, proc, data, weak_p);
}
#undef FUNC_NAME

SCM_DEFINE (scm_environment_unobserve, "environment-unobserve", 1, 0, 0,
	    (SCM token),
	    "Cancel the observation request which returned the value\n"
	    "@var{token}.  The return value is unspecified.\n"
	    "If a call @code{(environment-observe env proc)} returns\n"
	    "@var{token}, then the call @code{(environment-unobserve token)}\n"
	    "will cause @var{proc} to no longer be called when @var{env}'s\n"
	    "bindings change.")
#define FUNC_NAME s_scm_environment_unobserve
{
  SCM env;

  SCM_ASSERT (SCM_OBSERVER_P (token), token, SCM_ARG1, FUNC_NAME);

  env = SCM_OBSERVER_ENVIRONMENT (token);
  SCM_ENVIRONMENT_UNOBSERVE (env, token);

  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

static SCM
environment_mark (SCM env)
{
  return (*(SCM_ENVIRONMENT_FUNCS (env)->mark)) (env);
}

static size_t
environment_free (SCM env)
{
  (*(SCM_ENVIRONMENT_FUNCS (env)->free)) (env);
  return 0;
}

static int
environment_print (SCM env, SCM port, scm_print_state *pstate)
{
  return (*(SCM_ENVIRONMENT_FUNCS (env)->print)) (env, port, pstate);
}

/* observers */

static SCM
observer_mark (SCM observer)
{
  scm_gc_mark (SCM_OBSERVER_ENVIRONMENT (observer));
  scm_gc_mark (SCM_OBSERVER_DATA (observer));
  return SCM_BOOL_F;
}

static int
observer_print (SCM type, SCM port, scm_print_state *pstate SCM_UNUSED)
{
  SCM address = scm_from_size_t (SCM_UNPACK (type));
  SCM base16 = scm_number_to_string (address, scm_from_int (16));

  scm_puts ("#<observer ", port);
  scm_display (base16, port);
  scm_puts (">", port);

  return 1;
}

/* obarrays
 *
 * Obarrays form the basic lookup tables used to implement most of guile's
 * built-in environment types.  An obarray is implemented as a hash table with
 * symbols as keys.  The content of the data depends on the environment type.
 */

/*
 * Enter symbol into obarray.  The symbol must not already exist in obarray.
 * The freshly generated (symbol . data) cell is returned.
 */
static SCM
obarray_enter (SCM obarray, SCM symbol, SCM data)
{
  size_t hash = scm_i_symbol_hash (symbol) % SCM_HASHTABLE_N_BUCKETS (obarray);
  SCM entry = scm_cons (symbol, data);
  SCM slot = scm_cons (entry, SCM_HASHTABLE_BUCKET (obarray, hash));
  SCM_SET_HASHTABLE_BUCKET  (obarray, hash, slot);
  SCM_HASHTABLE_INCREMENT (obarray);
  if (SCM_HASHTABLE_N_ITEMS (obarray) > SCM_HASHTABLE_UPPER (obarray))
    scm_i_rehash (obarray, scm_i_hash_symbol, 0, "obarray_enter");

  return entry;
}

/*
 * Enter symbol into obarray.  An existing entry for symbol is replaced.  If
 * an entry existed, the old (symbol . data) cell is returned, #f otherwise.
 */
static SCM
obarray_replace (SCM obarray, SCM symbol, SCM data)
{
  size_t hash = scm_i_symbol_hash (symbol) % SCM_HASHTABLE_N_BUCKETS (obarray);
  SCM new_entry = scm_cons (symbol, data);
  SCM lsym;
  SCM slot;

  for (lsym = SCM_HASHTABLE_BUCKET (obarray, hash);
       !scm_is_null (lsym);
       lsym = SCM_CDR (lsym))
    {
      SCM old_entry = SCM_CAR (lsym);
      if (scm_is_eq (SCM_CAR (old_entry), symbol))
	{
	  SCM_SETCAR (lsym, new_entry);
	  return old_entry;
	}
    }

  slot = scm_cons (new_entry, SCM_HASHTABLE_BUCKET (obarray, hash));
  SCM_SET_HASHTABLE_BUCKET (obarray, hash, slot);
  SCM_HASHTABLE_INCREMENT (obarray);
  if (SCM_HASHTABLE_N_ITEMS (obarray) > SCM_HASHTABLE_UPPER (obarray))
    scm_i_rehash (obarray, scm_i_hash_symbol, 0, "obarray_replace");

  return SCM_BOOL_F;
}

/*
 * Look up symbol in obarray
 */
static SCM
obarray_retrieve (SCM obarray, SCM sym)
{
  size_t hash = scm_i_symbol_hash (sym) % SCM_HASHTABLE_N_BUCKETS (obarray);
  SCM lsym;

  for (lsym = SCM_HASHTABLE_BUCKET (obarray, hash);
       !scm_is_null (lsym);
       lsym = SCM_CDR (lsym))
    {
      SCM entry = SCM_CAR (lsym);
      if (scm_is_eq (SCM_CAR (entry), sym))
	return entry;
    }

  return SCM_UNDEFINED;
}

/*
 * Remove entry from obarray.  If the symbol was found and removed, the old
 * (symbol . data) cell is returned, #f otherwise.
 */
static SCM
obarray_remove (SCM obarray, SCM sym)
{
  size_t hash = scm_i_symbol_hash (sym) % SCM_HASHTABLE_N_BUCKETS (obarray);
  SCM table_entry = SCM_HASHTABLE_BUCKET (obarray, hash);
  SCM handle = scm_sloppy_assq (sym, table_entry);

  if (scm_is_pair (handle))
    {
      SCM new_table_entry = scm_delq1_x (handle, table_entry);
      SCM_SET_HASHTABLE_BUCKET (obarray, hash, new_table_entry);
      SCM_HASHTABLE_DECREMENT (obarray);
    }

  return handle;
}

static void
obarray_remove_all (SCM obarray)
{
  size_t size = SCM_HASHTABLE_N_BUCKETS (obarray);
  size_t i;

  for (i = 0; i < size; i++)
    {
      SCM_SET_HASHTABLE_BUCKET (obarray, i, SCM_EOL);
    }
  SCM_SET_HASHTABLE_N_ITEMS (obarray, 0);
}

/* core environments base
 *
 * This struct and the corresponding functions form a base class for guile's
 * built-in environment types.
 */

struct core_environments_base {
  struct scm_environment_funcs *funcs;

  SCM observers;
  SCM weak_observers;
};

#define CORE_ENVIRONMENTS_BASE(env) \
  ((struct core_environments_base *) SCM_CELL_WORD_1 (env))
#define CORE_ENVIRONMENT_OBSERVERS(env) \
  (CORE_ENVIRONMENTS_BASE (env)->observers)
#define SCM_SET_CORE_ENVIRONMENT_OBSERVERS(env, v) \
  (CORE_ENVIRONMENT_OBSERVERS (env) = (v))
#define CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR(env) \
  (CORE_ENVIRONMENTS_BASE (env)->weak_observers)
#define CORE_ENVIRONMENT_WEAK_OBSERVERS(env) \
  (scm_c_vector_ref (CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR (env), 0))
#define SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS(env, v) \
  (scm_c_vector_set_x (CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR (env), 0, (v)))

static SCM
core_environments_observe (SCM env, scm_environment_observer proc, SCM data, int weak_p)
{
  SCM observer = scm_double_cell (scm_tc16_observer,
				  SCM_UNPACK (env),
				  SCM_UNPACK (data),
				  (scm_t_bits) proc);

  if (!weak_p)
    {
      SCM observers = CORE_ENVIRONMENT_OBSERVERS (env);
      SCM new_observers = scm_cons (observer, observers);
      SCM_SET_CORE_ENVIRONMENT_OBSERVERS (env, new_observers);
    }
  else
    {
      SCM observers = CORE_ENVIRONMENT_WEAK_OBSERVERS (env);
      SCM new_observers = scm_acons (SCM_BOOL_F, observer, observers);
      SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS (env, new_observers);
    }

  return observer;
}

static void
core_environments_unobserve (SCM env, SCM observer)
{
  unsigned int handling_weaks;
  for (handling_weaks = 0; handling_weaks <= 1; ++handling_weaks)
    {
      SCM l = handling_weaks
	? CORE_ENVIRONMENT_WEAK_OBSERVERS (env)
	: CORE_ENVIRONMENT_OBSERVERS (env);

      if (!scm_is_null (l))
	{
	  SCM rest = SCM_CDR (l);
	  SCM first = handling_weaks
	    ? SCM_CDAR (l)
	    : SCM_CAR (l);

	  if (scm_is_eq (first, observer))
	    {
	      /* Remove the first observer */
	      if (handling_weaks)
		SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS (env, rest);
              else
                SCM_SET_CORE_ENVIRONMENT_OBSERVERS (env, rest);
	      return;
	    }

	  do {
	    SCM rest = SCM_CDR (l);

	    if (!scm_is_null (rest))
	      {
		SCM next = handling_weaks
		  ? SCM_CDAR (l)
		  : SCM_CAR (l);

		if (scm_is_eq (next, observer))
		  {
		    SCM_SETCDR (l, SCM_CDR (rest));
		    return;
		  }
	      }

	    l = rest;
	  } while (!scm_is_null (l));
	}
    }

  /* Dirk:FIXME:: What to do now, since the observer is not found? */
}

static SCM
core_environments_mark (SCM env)
{
  scm_gc_mark (CORE_ENVIRONMENT_OBSERVERS (env));
  return CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR (env);
}

static void
core_environments_finalize (SCM env SCM_UNUSED)
{
}

static void
core_environments_preinit (struct core_environments_base *body)
{
  body->funcs = NULL;
  body->observers = SCM_BOOL_F;
  body->weak_observers = SCM_BOOL_F;
}

static void
core_environments_init (struct core_environments_base *body,
			       struct scm_environment_funcs *funcs)
{
  body->funcs = funcs;
  body->observers = SCM_EOL;
  body->weak_observers = scm_make_weak_value_alist_vector (scm_from_int (1));
}

/* Tell all observers to clear their caches.
 *
 * Environments have to be informed about changes in the following cases:
 * - The observed env has a new binding.  This must be always reported.
 * - The observed env has dropped a binding.  This must be always reported.
 * - A binding in the observed environment has changed.  This must only be
 *   reported, if there is a chance that the binding is being cached outside.
 *   However, this potential optimization is not performed currently.
 *
 * Errors that occur while the observers are called are accumulated and
 * signalled as one single error message to the caller.
 */

struct update_data
{
  SCM observer;
  SCM environment;
};

static SCM
update_catch_body (void *ptr)
{
  struct update_data *data = (struct update_data *) ptr;
  SCM observer = data->observer;

  (*SCM_OBSERVER_PROC (observer))
    (data->environment, SCM_OBSERVER_DATA (observer));

  return SCM_UNDEFINED;
}

static SCM
update_catch_handler (void *ptr, SCM tag, SCM args)
{
  struct update_data *data = (struct update_data *) ptr;
  SCM observer = data->observer;
  SCM message =
    scm_from_locale_string ("Observer `~A' signals `~A' error: ~S");

  return scm_cons (message, scm_list_3 (observer, tag, args));
}

static void
core_environments_broadcast (SCM env)
#define FUNC_NAME "core_environments_broadcast"
{
  unsigned int handling_weaks;
  SCM errors = SCM_EOL;

  for (handling_weaks = 0; handling_weaks <= 1; ++handling_weaks)
    {
      SCM observers = handling_weaks
	? CORE_ENVIRONMENT_WEAK_OBSERVERS (env)
	: CORE_ENVIRONMENT_OBSERVERS (env);

      for (; !scm_is_null (observers); observers = SCM_CDR (observers))
	{
          struct update_data data;
	  SCM observer = handling_weaks
	    ? SCM_CDAR (observers)
	    : SCM_CAR (observers);
          SCM error;

          data.observer = observer;
          data.environment = env;

          error = scm_internal_catch (SCM_BOOL_T,
                                      update_catch_body, &data,
                                      update_catch_handler, &data);

          if (!SCM_UNBNDP (error))
            errors = scm_cons (error, errors);
	}
    }

  if (!scm_is_null (errors))
    {
      /* Dirk:FIXME:: As soon as scm_misc_error is fixed to handle the name
       * parameter correctly it should not be necessary any more to also pass
       * namestr in order to get the desired information from the error
       * message.
       */
      SCM ordered_errors = scm_reverse (errors);
      scm_misc_error
        (FUNC_NAME,
         "Observers of `~A' have signalled the following errors: ~S",
         scm_cons2 (env, ordered_errors, SCM_EOL));
    }
}
#undef FUNC_NAME

/* leaf environments
 *
 * A leaf environment is simply a mutable set of definitions. A leaf
 * environment supports no operations beyond the common set.
 *
 * Implementation:  The obarray of the leaf environment holds (symbol . value)
 * pairs.  No further information is necessary, since all bindings and
 * locations in a leaf environment are mutable.
 */

struct leaf_environment {
  struct core_environments_base base;

  SCM obarray;
};

#define LEAF_ENVIRONMENT(env) \
  ((struct leaf_environment *) SCM_CELL_WORD_1 (env))

static SCM
leaf_environment_ref (SCM env, SCM sym)
{
  SCM obarray = LEAF_ENVIRONMENT (env)->obarray;
  SCM binding = obarray_retrieve (obarray, sym);
  return SCM_UNBNDP (binding) ? binding : SCM_CDR (binding);
}

static SCM
leaf_environment_fold (SCM env, scm_environment_folder proc, SCM data, SCM init)
{
  size_t i;
  SCM result = init;
  SCM obarray = LEAF_ENVIRONMENT (env)->obarray;

  for (i = 0; i < SCM_HASHTABLE_N_BUCKETS (obarray); i++)
    {
      SCM l;
      for (l = SCM_HASHTABLE_BUCKET (obarray, i);
	   !scm_is_null (l);
	   l = SCM_CDR (l))
	{
	  SCM binding = SCM_CAR (l);
	  SCM symbol = SCM_CAR (binding);
	  SCM value = SCM_CDR (binding);
	  result = (*proc) (data, symbol, value, result);
	}
    }
  return result;
}

static SCM
leaf_environment_define (SCM env, SCM sym, SCM val)
#define FUNC_NAME "leaf_environment_define"
{
  SCM obarray = LEAF_ENVIRONMENT (env)->obarray;

  obarray_replace (obarray, sym, val);
  core_environments_broadcast (env);

  return SCM_ENVIRONMENT_SUCCESS;
}
#undef FUNC_NAME

static SCM
leaf_environment_undefine (SCM env, SCM sym)
#define FUNC_NAME "leaf_environment_undefine"
{
  SCM obarray = LEAF_ENVIRONMENT (env)->obarray;
  SCM removed = obarray_remove (obarray, sym);

  if (scm_is_true (removed))
    core_environments_broadcast (env);

  return SCM_ENVIRONMENT_SUCCESS;
}
#undef FUNC_NAME

static SCM
leaf_environment_set_x (SCM env, SCM sym, SCM val)
#define FUNC_NAME "leaf_environment_set_x"
{
  SCM obarray = LEAF_ENVIRONMENT (env)->obarray;
  SCM binding = obarray_retrieve (obarray, sym);

  if (!SCM_UNBNDP (binding))
    {
      SCM_SETCDR (binding, val);
      return SCM_ENVIRONMENT_SUCCESS;
    }
  else
    {
      return SCM_UNDEFINED;
    }
}
#undef FUNC_NAME

static SCM
leaf_environment_cell (SCM env, SCM sym, int for_write SCM_UNUSED)
{
  SCM obarray = LEAF_ENVIRONMENT (env)->obarray;
  SCM binding = obarray_retrieve (obarray, sym);
  return binding;
}

static SCM
leaf_environment_mark (SCM env)
{
  scm_gc_mark (LEAF_ENVIRONMENT (env)->obarray);
  return core_environments_mark (env);
}

static void
leaf_environment_free (SCM env)
{
  core_environments_finalize (env);
  scm_gc_free (LEAF_ENVIRONMENT (env), sizeof (struct leaf_environment),
	       "leaf environment");
}

static int
leaf_environment_print (SCM type, SCM port, scm_print_state *pstate SCM_UNUSED)
{
  SCM address = scm_from_size_t (SCM_UNPACK (type));
  SCM base16 = scm_number_to_string (address, scm_from_int (16));

  scm_puts ("#<leaf environment ", port);
  scm_display (base16, port);
  scm_puts (">", port);

  return 1;
}

static struct scm_environment_funcs leaf_environment_funcs = {
  leaf_environment_ref,
  leaf_environment_fold,
  leaf_environment_define,
  leaf_environment_undefine,
  leaf_environment_set_x,
  leaf_environment_cell,
  core_environments_observe,
  core_environments_unobserve,
  leaf_environment_mark,
  leaf_environment_free,
  leaf_environment_print
};

void *scm_type_leaf_environment = &leaf_environment_funcs;

SCM_DEFINE (scm_make_leaf_environment, "make-leaf-environment", 0, 0, 0,
	    (),
	    "Create a new leaf environment, containing no bindings.\n"
	    "All bindings and locations created in the new environment\n"
	    "will be mutable.")
#define FUNC_NAME s_scm_make_leaf_environment
{
  size_t size = sizeof (struct leaf_environment);
  struct leaf_environment *body = scm_gc_malloc (size, "leaf environment");
  SCM env;

  core_environments_preinit (&body->base);
  body->obarray = SCM_BOOL_F;

  env = scm_make_environment (body);

  core_environments_init (&body->base, &leaf_environment_funcs);
  body->obarray = scm_c_make_hash_table (DEFAULT_OBARRAY_SIZE);

  return env;
}
#undef FUNC_NAME

SCM_DEFINE (scm_leaf_environment_p, "leaf-environment?", 1, 0, 0,
	    (SCM object),
	    "Return @code{#t} if object is a leaf environment, or @code{#f}\n"
	    "otherwise.")
#define FUNC_NAME s_scm_leaf_environment_p
{
  return scm_from_bool (SCM_LEAF_ENVIRONMENT_P (object));
}
#undef FUNC_NAME

/* eval environments
 *
 * A module's source code refers to definitions imported from other modules,
 * and definitions made within itself.  An eval environment combines two
 * environments -- a local environment and an imported environment -- to
 * produce a new environment in which both sorts of references can be
 * resolved.
 *
 * Implementation:  The obarray of the eval environment is used to cache
 * entries from the local and imported environments such that in most of the
 * cases only a single lookup is necessary.  Since for neither the local nor
 * the imported environment it is known, what kind of environment they form,
 * the most general case is assumed.  Therefore, entries in the obarray take
 * one of the following forms:
 *
 * 1) (<symbol> location mutability . source-env), where mutability indicates
 *    one of the following states:  IMMUTABLE if the location is known to be
 *    immutable, MUTABLE if the location is known to be mutable, UNKNOWN if
 *    the location has only been requested for non modifying accesses.
 *
 * 2) (symbol . source-env) if the symbol has a binding in the source-env, but
 *    if the source-env can't provide a cell for the binding.  Thus, for every
 *    access, the source-env has to be contacted directly.
 */

struct eval_environment {
  struct core_environments_base base;

  SCM obarray;

  SCM imported;
  SCM imported_observer;
  SCM local;
  SCM local_observer;
};

#define EVAL_ENVIRONMENT(env) \
  ((struct eval_environment *) SCM_CELL_WORD_1 (env))

#define IMMUTABLE SCM_I_MAKINUM (0)
#define MUTABLE   SCM_I_MAKINUM (1)
#define UNKNOWN   SCM_I_MAKINUM (2)

#define CACHED_LOCATION(x) SCM_CAR (x)
#define CACHED_MUTABILITY(x) SCM_CADR (x)
#define SET_CACHED_MUTABILITY(x, v) SCM_SETCAR (SCM_CDR (x), (v))
#define CACHED_SOURCE_ENVIRONMENT(x) SCM_CDDR (x)

/* eval_environment_lookup will report one of the following distinct results:
 * a) (<object> . value) if a cell could be obtained.
 * b) <environment> if the environment has to be contacted directly.
 * c) IMMUTABLE if an immutable cell was requested for write.
 * d) SCM_UNDEFINED if there is no binding for the symbol.
 */
static SCM
eval_environment_lookup (SCM env, SCM sym, int for_write)
{
  SCM obarray = EVAL_ENVIRONMENT (env)->obarray;
  SCM binding = obarray_retrieve (obarray, sym);

  if (!SCM_UNBNDP (binding))
    {
      /* The obarray holds an entry for the symbol. */

      SCM entry = SCM_CDR (binding);

      if (scm_is_pair (entry))
	{
	  /* The entry in the obarray is a cached location. */

	  SCM location = CACHED_LOCATION (entry);
	  SCM mutability;

	  if (!for_write)
	    return location;

	  mutability = CACHED_MUTABILITY (entry);
	  if (scm_is_eq (mutability, MUTABLE))
	    return location;

	  if (scm_is_eq (mutability, UNKNOWN))
	    {
	      SCM source_env = CACHED_SOURCE_ENVIRONMENT (entry);
	      SCM location = SCM_ENVIRONMENT_CELL (source_env, sym, 1);

	      if (scm_is_pair (location))
		{
		  SET_CACHED_MUTABILITY (entry, MUTABLE);
		  return location;
		}
	      else /* IMMUTABLE */
		{
		  SET_CACHED_MUTABILITY (entry, IMMUTABLE);
		  return IMMUTABLE;
		}
	    }

	  return IMMUTABLE;
	}
      else
	{
	  /* The obarray entry is an environment */

	  return entry;
	}
    }
  else
    {
      /* There is no entry for the symbol in the obarray.  This can either
       * mean that there has not been a request for the symbol yet, or that
       * the symbol is really undefined.  We are looking for the symbol in
       * both the local and the imported environment.  If we find a binding, a
       * cached entry is created.
       */

      struct eval_environment *body = EVAL_ENVIRONMENT (env);
      unsigned int handling_import;

      for (handling_import = 0; handling_import <= 1; ++handling_import)
	{
	  SCM source_env = handling_import ? body->imported : body->local;
	  SCM location = SCM_ENVIRONMENT_CELL (source_env, sym, for_write);

	  if (!SCM_UNBNDP (location))
	    {
	      if (scm_is_pair (location))
		{
		  SCM mutability = for_write ? MUTABLE : UNKNOWN;
		  SCM entry = scm_cons2 (location, mutability, source_env);
		  obarray_enter (obarray, sym, entry);
		  return location;
		}
	      else if (scm_is_eq (location, SCM_ENVIRONMENT_LOCATION_NO_CELL))
		{
		  obarray_enter (obarray, sym, source_env);
		  return source_env;
		}
	      else
		{
		  return IMMUTABLE;
		}
	    }
	}

      return SCM_UNDEFINED;
    }
}

static SCM
eval_environment_ref (SCM env, SCM sym)
#define FUNC_NAME "eval_environment_ref"
{
  SCM location = eval_environment_lookup (env, sym, 0);

  if (scm_is_pair (location))
    return SCM_CDR (location);
  else if (!SCM_UNBNDP (location))
    return SCM_ENVIRONMENT_REF (location, sym);
  else
    return SCM_UNDEFINED;
}
#undef FUNC_NAME

static SCM
eval_environment_folder (SCM extended_data, SCM symbol, SCM value, SCM tail)
{
  SCM local = SCM_CAR (extended_data);

  if (!SCM_ENVIRONMENT_BOUND_P (local, symbol))
    {
      SCM proc_as_nr = SCM_CADR (extended_data);
      unsigned long int proc_as_ul = scm_to_ulong (proc_as_nr);
      scm_environment_folder proc = (scm_environment_folder) proc_as_ul;
      SCM data = SCM_CDDR (extended_data);

      return (*proc) (data, symbol, value, tail);
    }
  else
    {
      return tail;
    }
}

static SCM
eval_environment_fold (SCM env, scm_environment_folder proc, SCM data, SCM init)
{
  SCM local = EVAL_ENVIRONMENT (env)->local;
  SCM imported = EVAL_ENVIRONMENT (env)->imported;
  SCM proc_as_nr = scm_from_ulong ((unsigned long) proc);
  SCM extended_data = scm_cons2 (local, proc_as_nr, data);
  SCM tmp_result = scm_c_environment_fold (imported, eval_environment_folder, extended_data, init);

  return scm_c_environment_fold (local, proc, data, tmp_result);
}

static SCM
eval_environment_define (SCM env, SCM sym, SCM val)
#define FUNC_NAME "eval_environment_define"
{
  SCM local = EVAL_ENVIRONMENT (env)->local;
  return SCM_ENVIRONMENT_DEFINE (local, sym, val);
}
#undef FUNC_NAME

static SCM
eval_environment_undefine (SCM env, SCM sym)
#define FUNC_NAME "eval_environment_undefine"
{
  SCM local = EVAL_ENVIRONMENT (env)->local;
  return SCM_ENVIRONMENT_UNDEFINE (local, sym);
}
#undef FUNC_NAME

static SCM
eval_environment_set_x (SCM env, SCM sym, SCM val)
#define FUNC_NAME "eval_environment_set_x"
{
  SCM location = eval_environment_lookup (env, sym, 1);

  if (scm_is_pair (location))
    {
      SCM_SETCDR (location, val);
      return SCM_ENVIRONMENT_SUCCESS;
    }
  else if (SCM_ENVIRONMENT_P (location))
    {
      return SCM_ENVIRONMENT_SET (location, sym, val);
    }
  else if (scm_is_eq (location, IMMUTABLE))
    {
      return SCM_ENVIRONMENT_LOCATION_IMMUTABLE;
    }
  else
    {
      return SCM_UNDEFINED;
    }
}
#undef FUNC_NAME

static SCM
eval_environment_cell (SCM env, SCM sym, int for_write)
#define FUNC_NAME "eval_environment_cell"
{
  SCM location = eval_environment_lookup (env, sym, for_write);

  if (scm_is_pair (location))
    return location;
  else if (SCM_ENVIRONMENT_P (location))
    return SCM_ENVIRONMENT_LOCATION_NO_CELL;
  else if (scm_is_eq (location, IMMUTABLE))
    return SCM_ENVIRONMENT_LOCATION_IMMUTABLE;
  else
    return SCM_UNDEFINED;
}
#undef FUNC_NAME

static SCM
eval_environment_mark (SCM env)
{
  struct eval_environment *body = EVAL_ENVIRONMENT (env);

  scm_gc_mark (body->obarray);
  scm_gc_mark (body->imported);
  scm_gc_mark (body->imported_observer);
  scm_gc_mark (body->local);
  scm_gc_mark (body->local_observer);

  return core_environments_mark (env);
}

static void
eval_environment_free (SCM env)
{
  core_environments_finalize (env);
  scm_gc_free (EVAL_ENVIRONMENT (env), sizeof (struct eval_environment),
	       "eval environment");
}

static int
eval_environment_print (SCM type, SCM port, scm_print_state *pstate SCM_UNUSED)
{
  SCM address = scm_from_size_t (SCM_UNPACK (type));
  SCM base16 = scm_number_to_string (address, scm_from_int (16));

  scm_puts ("#<eval environment ", port);
  scm_display (base16, port);
  scm_puts (">", port);

  return 1;
}

static struct scm_environment_funcs eval_environment_funcs = {
    eval_environment_ref,
    eval_environment_fold,
    eval_environment_define,
    eval_environment_undefine,
    eval_environment_set_x,
    eval_environment_cell,
    core_environments_observe,
    core_environments_unobserve,
    eval_environment_mark,
    eval_environment_free,
    eval_environment_print
};

void *scm_type_eval_environment = &eval_environment_funcs;

static void
eval_environment_observer (SCM caller SCM_UNUSED, SCM eval_env)
{
  SCM obarray = EVAL_ENVIRONMENT (eval_env)->obarray;

  obarray_remove_all (obarray);
  core_environments_broadcast (eval_env);
}

SCM_DEFINE (scm_make_eval_environment, "make-eval-environment", 2, 0, 0,
	    (SCM local, SCM imported),
	    "Return a new environment object eval whose bindings are the\n"
	    "union of the bindings in the environments @var{local} and\n"
	    "@var{imported}, with bindings from @var{local} taking\n"
	    "precedence. Definitions made in eval are placed in @var{local}.\n"
	    "Applying @code{environment-define} or\n"
	    "@code{environment-undefine} to eval has the same effect as\n"
	    "applying the procedure to @var{local}.\n"
	    "Note that eval incorporates @var{local} and @var{imported} by\n"
	    "reference:\n"
	    "If, after creating eval, the program changes the bindings of\n"
	    "@var{local} or @var{imported}, those changes will be visible\n"
	    "in eval.\n"
	    "Since most Scheme evaluation takes place in eval environments,\n"
	    "they transparently cache the bindings received from @var{local}\n"
	    "and @var{imported}. Thus, the first time the program looks up\n"
	    "a symbol in eval, eval may make calls to @var{local} or\n"
	    "@var{imported} to find their bindings, but subsequent\n"
	    "references to that symbol will be as fast as references to\n"
	    "bindings in finite environments.\n"
	    "In typical use, @var{local} will be a finite environment, and\n"
	    "@var{imported} will be an import environment")
#define FUNC_NAME s_scm_make_eval_environment
{
  SCM env;
  struct eval_environment *body;

  SCM_ASSERT (SCM_ENVIRONMENT_P (local), local, SCM_ARG1, FUNC_NAME);
  SCM_ASSERT (SCM_ENVIRONMENT_P (imported), imported, SCM_ARG2, FUNC_NAME);

  body = scm_gc_malloc (sizeof (struct eval_environment), "eval environment");

  core_environments_preinit (&body->base);
  body->obarray = SCM_BOOL_F;
  body->imported = SCM_BOOL_F;
  body->imported_observer = SCM_BOOL_F;
  body->local = SCM_BOOL_F;
  body->local_observer = SCM_BOOL_F;

  env = scm_make_environment (body);

  core_environments_init (&body->base, &eval_environment_funcs);
  body->obarray = scm_c_make_hash_table (DEFAULT_OBARRAY_SIZE);
  body->imported = imported;
  body->imported_observer
    = SCM_ENVIRONMENT_OBSERVE (imported, eval_environment_observer, env, 1);
  body->local = local;
  body->local_observer
    = SCM_ENVIRONMENT_OBSERVE (local, eval_environment_observer, env, 1);

  return env;
}
#undef FUNC_NAME

SCM_DEFINE (scm_eval_environment_p, "eval-environment?", 1, 0, 0,
	    (SCM object),
	    "Return @code{#t} if object is an eval environment, or @code{#f}\n"
	    "otherwise.")
#define FUNC_NAME s_scm_eval_environment_p
{
  return scm_from_bool (SCM_EVAL_ENVIRONMENT_P (object));
}
#undef FUNC_NAME

SCM_DEFINE (scm_eval_environment_local, "eval-environment-local", 1, 0, 0,
	    (SCM env),
	    "Return the local environment of eval environment @var{env}.")
#define FUNC_NAME s_scm_eval_environment_local
{
  SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);

  return EVAL_ENVIRONMENT (env)->local;
}
#undef FUNC_NAME

SCM_DEFINE (scm_eval_environment_set_local_x, "eval-environment-set-local!", 2, 0, 0,
	    (SCM env, SCM local),
	    "Change @var{env}'s local environment to @var{local}.")
#define FUNC_NAME s_scm_eval_environment_set_local_x
{
  struct eval_environment *body;

  SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
  SCM_ASSERT (SCM_ENVIRONMENT_P (local), local, SCM_ARG2, FUNC_NAME);

  body = EVAL_ENVIRONMENT (env);

  obarray_remove_all (body->obarray);
  SCM_ENVIRONMENT_UNOBSERVE (body->local, body->local_observer);

  body->local = local;
  body->local_observer
    = SCM_ENVIRONMENT_OBSERVE (local, eval_environment_observer, env, 1);

  core_environments_broadcast (env);

  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM_DEFINE (scm_eval_environment_imported, "eval-environment-imported", 1, 0, 0,
	    (SCM env),
	    "Return the imported environment of eval environment @var{env}.")
#define FUNC_NAME s_scm_eval_environment_imported
{
  SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);

  return EVAL_ENVIRONMENT (env)->imported;
}
#undef FUNC_NAME

SCM_DEFINE (scm_eval_environment_set_imported_x, "eval-environment-set-imported!", 2, 0, 0,
	    (SCM env, SCM imported),
	    "Change @var{env}'s imported environment to @var{imported}.")
#define FUNC_NAME s_scm_eval_environment_set_imported_x
{
  struct eval_environment *body;

  SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
  SCM_ASSERT (SCM_ENVIRONMENT_P (imported), imported, SCM_ARG2, FUNC_NAME);

  body = EVAL_ENVIRONMENT (env);

  obarray_remove_all (body->obarray);
  SCM_ENVIRONMENT_UNOBSERVE (body->imported, body->imported_observer);

  body->imported = imported;
  body->imported_observer
    = SCM_ENVIRONMENT_OBSERVE (imported, eval_environment_observer, env, 1);

  core_environments_broadcast (env);

  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

/* import environments
 *
 * An import environment combines the bindings of a set of argument
 * environments, and checks for naming clashes.
 *
 * Implementation:  The import environment does no caching at all.  For every
 * access, the list of imported environments is scanned.
 */

struct import_environment {
  struct core_environments_base base;

  SCM imports;
  SCM import_observers;

  SCM conflict_proc;
};

#define IMPORT_ENVIRONMENT(env) \
  ((struct import_environment *) SCM_CELL_WORD_1 (env))

/* Lookup will report one of the following distinct results:
 * a) <environment> if only environment binds the symbol.
 * b) (env-1 env-2 ...) for conflicting bindings in env-1, ...
 * c) SCM_UNDEFINED if there is no binding for the symbol.
 */
static SCM
import_environment_lookup (SCM env, SCM sym)
{
  SCM imports = IMPORT_ENVIRONMENT (env)->imports;
  SCM result = SCM_UNDEFINED;
  SCM l;

  for (l = imports; !scm_is_null (l); l = SCM_CDR (l))
    {
      SCM imported = SCM_CAR (l);

      if (SCM_ENVIRONMENT_BOUND_P (imported, sym))
	{
	  if (SCM_UNBNDP (result))
	    result = imported;
	  else if (scm_is_pair (result))
	    result = scm_cons (imported, result);
	  else
	    result = scm_cons2 (imported, result, SCM_EOL);
	}
    }

  if (scm_is_pair (result))
    return scm_reverse (result);
  else
    return result;
}

static SCM
import_environment_conflict (SCM env, SCM sym, SCM imports)
{
  SCM conflict_proc = IMPORT_ENVIRONMENT (env)->conflict_proc;
  SCM args = scm_cons2 (env, sym, scm_cons (imports, SCM_EOL));

  return scm_apply_0 (conflict_proc, args);
}

static SCM
import_environment_ref (SCM env, SCM sym)
#define FUNC_NAME "import_environment_ref"
{
  SCM owner = import_environment_lookup (env, sym);

  if (SCM_UNBNDP (owner))
    {
      return SCM_UNDEFINED;
    }
  else if (scm_is_pair (owner))
    {
      SCM resolve = import_environment_conflict (env, sym, owner);

      if (SCM_ENVIRONMENT_P (resolve))
	return SCM_ENVIRONMENT_REF (resolve, sym);
      else
	return SCM_UNSPECIFIED;
    }
  else
    {
      return SCM_ENVIRONMENT_REF (owner, sym);
    }
}
#undef FUNC_NAME

static SCM
import_environment_folder (SCM extended_data, SCM symbol, SCM value, SCM tail)
#define FUNC_NAME "import_environment_fold"
{
  SCM import_env = SCM_CAR (extended_data);
  SCM imported_env = SCM_CADR (extended_data);
  SCM owner = import_environment_lookup (import_env, symbol);
  SCM proc_as_nr = SCM_CADDR (extended_data);
  unsigned long int proc_as_ul = scm_to_ulong (proc_as_nr);
  scm_environment_folder proc = (scm_environment_folder) proc_as_ul;
  SCM data = SCM_CDDDR (extended_data);

  if (scm_is_pair (owner) && scm_is_eq (SCM_CAR (owner), imported_env))
    owner = import_environment_conflict (import_env, symbol, owner);

  if (SCM_ENVIRONMENT_P (owner))
    return (*proc) (data, symbol, value, tail);
  else /* unresolved conflict */
    return (*proc) (data, symbol, SCM_UNSPECIFIED, tail);
}
#undef FUNC_NAME

static SCM
import_environment_fold (SCM env, scm_environment_folder proc, SCM data, SCM init)
{
  SCM proc_as_nr = scm_from_ulong ((unsigned long) proc);
  SCM result = init;
  SCM l;

  for (l = IMPORT_ENVIRONMENT (env)->imports; !scm_is_null (l); l = SCM_CDR (l))
    {
      SCM imported_env = SCM_CAR (l);
      SCM extended_data = scm_cons (env, scm_cons2 (imported_env, proc_as_nr, data));

      result = scm_c_environment_fold (imported_env, import_environment_folder, extended_data, result);
    }

  return result;
}

static SCM
import_environment_define (SCM env SCM_UNUSED,
			   SCM sym SCM_UNUSED,
			   SCM val SCM_UNUSED)
#define FUNC_NAME "import_environment_define"
{
  return SCM_ENVIRONMENT_BINDING_IMMUTABLE;
}
#undef FUNC_NAME

static SCM
import_environment_undefine (SCM env SCM_UNUSED,
			     SCM sym SCM_UNUSED)
#define FUNC_NAME "import_environment_undefine"
{
  return SCM_ENVIRONMENT_BINDING_IMMUTABLE;
}
#undef FUNC_NAME

static SCM
import_environment_set_x (SCM env, SCM sym, SCM val)
#define FUNC_NAME "import_environment_set_x"
{
  SCM owner = import_environment_lookup (env, sym);

  if (SCM_UNBNDP (owner))
    {
      return SCM_UNDEFINED;
    }
  else if (scm_is_pair (owner))
    {
      SCM resolve = import_environment_conflict (env, sym, owner);

      if (SCM_ENVIRONMENT_P (resolve))
	return SCM_ENVIRONMENT_SET (resolve, sym, val);
      else
	return SCM_ENVIRONMENT_LOCATION_IMMUTABLE;
    }
  else
    {
      return SCM_ENVIRONMENT_SET (owner, sym, val);
    }
}
#undef FUNC_NAME

static SCM
import_environment_cell (SCM env, SCM sym, int for_write)
#define FUNC_NAME "import_environment_cell"
{
  SCM owner = import_environment_lookup (env, sym);

  if (SCM_UNBNDP (owner))
    {
      return SCM_UNDEFINED;
    }
  else if (scm_is_pair (owner))
    {
      SCM resolve = import_environment_conflict (env, sym, owner);

      if (SCM_ENVIRONMENT_P (resolve))
	return SCM_ENVIRONMENT_CELL (resolve, sym, for_write);
      else
	return SCM_ENVIRONMENT_LOCATION_NO_CELL;
    }
  else
    {
      return SCM_ENVIRONMENT_CELL (owner, sym, for_write);
    }
}
#undef FUNC_NAME

static SCM
import_environment_mark (SCM env)
{
  scm_gc_mark (IMPORT_ENVIRONMENT (env)->imports);
  scm_gc_mark (IMPORT_ENVIRONMENT (env)->import_observers);
  scm_gc_mark (IMPORT_ENVIRONMENT (env)->conflict_proc);
  return core_environments_mark (env);
}

static void
import_environment_free (SCM env)
{
  core_environments_finalize (env);
  scm_gc_free (IMPORT_ENVIRONMENT (env), sizeof (struct import_environment),
	       "import environment");
}

static int
import_environment_print (SCM type, SCM port,
			  scm_print_state *pstate SCM_UNUSED)
{
  SCM address = scm_from_size_t (SCM_UNPACK (type));
  SCM base16 = scm_number_to_string (address, scm_from_int (16));

  scm_puts ("#<import environment ", port);
  scm_display (base16, port);
  scm_puts (">", port);

  return 1;
}

static struct scm_environment_funcs import_environment_funcs = {
  import_environment_ref,
  import_environment_fold,
  import_environment_define,
  import_environment_undefine,
  import_environment_set_x,
  import_environment_cell,
  core_environments_observe,
  core_environments_unobserve,
  import_environment_mark,
  import_environment_free,
  import_environment_print
};

void *scm_type_import_environment = &import_environment_funcs;

static void
import_environment_observer (SCM caller SCM_UNUSED, SCM import_env)
{
  core_environments_broadcast (import_env);
}

SCM_DEFINE (scm_make_import_environment, "make-import-environment", 2, 0, 0,
	    (SCM imports, SCM conflict_proc),
	    "Return a new environment @var{imp} whose bindings are the union\n"
	    "of the bindings from the environments in @var{imports};\n"
	    "@var{imports} must be a list of environments. That is,\n"
	    "@var{imp} binds a symbol to a location when some element of\n"
	    "@var{imports} does.\n"
	    "If two different elements of @var{imports} have a binding for\n"
	    "the same symbol, the @var{conflict-proc} is called with the\n"
	    "following parameters:  the import environment, the symbol and\n"
	    "the list of the imported environments that bind the symbol.\n"
	    "If the @var{conflict-proc} returns an environment @var{env},\n"
	    "the conflict is considered as resolved and the binding from\n"
	    "@var{env} is used.  If the @var{conflict-proc} returns some\n"
	    "non-environment object, the conflict is considered unresolved\n"
	    "and the symbol is treated as unspecified in the import\n"
	    "environment.\n"
	    "The checking for conflicts may be performed lazily, i. e. at\n"
	    "the moment when a value or binding for a certain symbol is\n"
	    "requested instead of the moment when the environment is\n"
	    "created or the bindings of the imports change.\n"
	    "All bindings in @var{imp} are immutable. If you apply\n"
	    "@code{environment-define} or @code{environment-undefine} to\n"
	    "@var{imp}, Guile will signal an\n"
	    " @code{environment:immutable-binding} error. However,\n"
	    "notice that the set of bindings in @var{imp} may still change,\n"
	    "if one of its imported environments changes.")
#define FUNC_NAME s_scm_make_import_environment
{
  size_t size = sizeof (struct import_environment);
  struct import_environment *body = scm_gc_malloc (size, "import environment");
  SCM env;

  core_environments_preinit (&body->base);
  body->imports = SCM_BOOL_F;
  body->import_observers = SCM_BOOL_F;
  body->conflict_proc = SCM_BOOL_F;

  env = scm_make_environment (body);

  core_environments_init (&body->base, &import_environment_funcs);
  body->imports = SCM_EOL;
  body->import_observers = SCM_EOL;
  body->conflict_proc = conflict_proc;

  scm_import_environment_set_imports_x (env, imports);

  return env;
}
#undef FUNC_NAME

SCM_DEFINE (scm_import_environment_p, "import-environment?", 1, 0, 0,
	    (SCM object),
	    "Return @code{#t} if object is an import environment, or\n"
	    "@code{#f} otherwise.")
#define FUNC_NAME s_scm_import_environment_p
{
  return scm_from_bool (SCM_IMPORT_ENVIRONMENT_P (object));
}
#undef FUNC_NAME

SCM_DEFINE (scm_import_environment_imports, "import-environment-imports", 1, 0, 0,
	    (SCM env),
	    "Return the list of environments imported by the import\n"
	    "environment @var{env}.")
#define FUNC_NAME s_scm_import_environment_imports
{
  SCM_ASSERT (SCM_IMPORT_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);

  return IMPORT_ENVIRONMENT (env)->imports;
}
#undef FUNC_NAME

SCM_DEFINE (scm_import_environment_set_imports_x, "import-environment-set-imports!", 2, 0, 0,
	    (SCM env, SCM imports),
	    "Change @var{env}'s list of imported environments to\n"
	    "@var{imports}, and check for conflicts.")
#define FUNC_NAME s_scm_import_environment_set_imports_x
{
  struct import_environment *body = IMPORT_ENVIRONMENT (env);
  SCM import_observers = SCM_EOL;
  SCM l;

  SCM_ASSERT (SCM_IMPORT_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
  for (l = imports; scm_is_pair (l); l = SCM_CDR (l))
    {
      SCM obj = SCM_CAR (l);
      SCM_ASSERT (SCM_ENVIRONMENT_P (obj), imports, SCM_ARG2, FUNC_NAME);
    }
  SCM_ASSERT (scm_is_null (l), imports, SCM_ARG2, FUNC_NAME);

  for (l = body->import_observers; !scm_is_null (l); l = SCM_CDR (l))
    {
      SCM obs = SCM_CAR (l);
      SCM_ENVIRONMENT_UNOBSERVE (env, obs);
    }

  for (l = imports; !scm_is_null (l); l = SCM_CDR (l))
    {
      SCM imp = SCM_CAR (l);
      SCM obs = SCM_ENVIRONMENT_OBSERVE (imp, import_environment_observer, env, 1);
      import_observers = scm_cons (obs, import_observers);
    }

  body->imports = imports;
  body->import_observers = import_observers;

  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

/* export environments
 *
 * An export environment restricts an environment to a specified set of
 * bindings.
 *
 * Implementation:  The export environment does no caching at all.  For every
 * access, the signature is scanned.  The signature that is stored internally
 * is an alist of pairs (symbol . (mutability)).
 */

struct export_environment {
  struct core_environments_base base;

  SCM private;
  SCM private_observer;

  SCM signature;
};

#define EXPORT_ENVIRONMENT(env) \
  ((struct export_environment *) SCM_CELL_WORD_1 (env))

SCM_SYMBOL (symbol_immutable_location, "immutable-location");
SCM_SYMBOL (symbol_mutable_location, "mutable-location");

static SCM
export_environment_ref (SCM env, SCM sym)
#define FUNC_NAME "export_environment_ref"
{
  struct export_environment *body = EXPORT_ENVIRONMENT (env);
  SCM entry = scm_assq (sym, body->signature);

  if (scm_is_false (entry))
    return SCM_UNDEFINED;
  else
    return SCM_ENVIRONMENT_REF (body->private, sym);
}
#undef FUNC_NAME

static SCM
export_environment_fold (SCM env, scm_environment_folder proc, SCM data, SCM init)
{
  struct export_environment *body = EXPORT_ENVIRONMENT (env);
  SCM result = init;
  SCM l;

  for (l = body->signature; !scm_is_null (l); l = SCM_CDR (l))
    {
      SCM symbol = SCM_CAR (l);
      SCM value = SCM_ENVIRONMENT_REF (body->private, symbol);
      if (!SCM_UNBNDP (value))
	result = (*proc) (data, symbol, value, result);
    }
  return result;
}

static SCM
export_environment_define (SCM env SCM_UNUSED,
			   SCM sym SCM_UNUSED,
			   SCM val SCM_UNUSED)
#define FUNC_NAME "export_environment_define"
{
  return SCM_ENVIRONMENT_BINDING_IMMUTABLE;
}
#undef FUNC_NAME

static SCM
export_environment_undefine (SCM env SCM_UNUSED, SCM sym SCM_UNUSED)
#define FUNC_NAME "export_environment_undefine"
{
  return SCM_ENVIRONMENT_BINDING_IMMUTABLE;
}
#undef FUNC_NAME

static SCM
export_environment_set_x (SCM env, SCM sym, SCM val)
#define FUNC_NAME "export_environment_set_x"
{
  struct export_environment *body = EXPORT_ENVIRONMENT (env);
  SCM entry = scm_assq (sym, body->signature);

  if (scm_is_false (entry))
    {
      return SCM_UNDEFINED;
    }
  else
    {
      if (scm_is_eq (SCM_CADR (entry), symbol_mutable_location))
	return SCM_ENVIRONMENT_SET (body->private, sym, val);
      else
	return SCM_ENVIRONMENT_LOCATION_IMMUTABLE;
    }
}
#undef FUNC_NAME

static SCM
export_environment_cell (SCM env, SCM sym, int for_write)
#define FUNC_NAME "export_environment_cell"
{
  struct export_environment *body = EXPORT_ENVIRONMENT (env);
  SCM entry = scm_assq (sym, body->signature);

  if (scm_is_false (entry))
    {
      return SCM_UNDEFINED;
    }
  else
    {
      if (!for_write || scm_is_eq (SCM_CADR (entry), symbol_mutable_location))
	return SCM_ENVIRONMENT_CELL (body->private, sym, for_write);
      else
	return SCM_ENVIRONMENT_LOCATION_IMMUTABLE;
    }
}
#undef FUNC_NAME

static SCM
export_environment_mark (SCM env)
{
  struct export_environment *body = EXPORT_ENVIRONMENT (env);

  scm_gc_mark (body->private);
  scm_gc_mark (body->private_observer);
  scm_gc_mark (body->signature);

  return core_environments_mark (env);
}

static void
export_environment_free (SCM env)
{
  core_environments_finalize (env);
  scm_gc_free (EXPORT_ENVIRONMENT (env), sizeof (struct export_environment),
	       "export environment");
}

static int
export_environment_print (SCM type, SCM port,
			  scm_print_state *pstate SCM_UNUSED)
{
  SCM address = scm_from_size_t (SCM_UNPACK (type));
  SCM base16 = scm_number_to_string (address, scm_from_int (16));

  scm_puts ("#<export environment ", port);
  scm_display (base16, port);
  scm_puts (">", port);

  return 1;
}

static struct scm_environment_funcs export_environment_funcs = {
  export_environment_ref,
  export_environment_fold,
  export_environment_define,
  export_environment_undefine,
  export_environment_set_x,
  export_environment_cell,
  core_environments_observe,
  core_environments_unobserve,
  export_environment_mark,
  export_environment_free,
  export_environment_print
};

void *scm_type_export_environment = &export_environment_funcs;

static void
export_environment_observer (SCM caller SCM_UNUSED, SCM export_env)
{
  core_environments_broadcast (export_env);
}

SCM_DEFINE (scm_make_export_environment, "make-export-environment", 2, 0, 0,
	    (SCM private, SCM signature),
	    "Return a new environment @var{exp} containing only those\n"
	    "bindings in private whose symbols are present in\n"
	    "@var{signature}. The @var{private} argument must be an\n"
	    "environment.\n\n"
	    "The environment @var{exp} binds symbol to location when\n"
	    "@var{env} does, and symbol is exported by @var{signature}.\n\n"
	    "@var{signature} is a list specifying which of the bindings in\n"
	    "@var{private} should be visible in @var{exp}. Each element of\n"
	    "@var{signature} should be a list of the form:\n"
	    "  (symbol attribute ...)\n"
	    "where each attribute is one of the following:\n"
	    "@table @asis\n"
	    "@item the symbol @code{mutable-location}\n"
	    "  @var{exp} should treat the\n"
	    "  location bound to symbol as mutable. That is, @var{exp}\n"
	    "  will pass calls to @code{environment-set!} or\n"
	    "  @code{environment-cell} directly through to private.\n"
	    "@item the symbol @code{immutable-location}\n"
	    "  @var{exp} should treat\n"
	    "  the location bound to symbol as immutable. If the program\n"
	    "  applies @code{environment-set!} to @var{exp} and symbol, or\n"
	    "  calls @code{environment-cell} to obtain a writable value\n"
	    "  cell, @code{environment-set!} will signal an\n"
	    "  @code{environment:immutable-location} error. Note that, even\n"
	    "  if an export environment treats a location as immutable, the\n"
	    "  underlying environment may treat it as mutable, so its\n"
	    "  value may change.\n"
	    "@end table\n"
	    "It is an error for an element of signature to specify both\n"
	    "@code{mutable-location} and @code{immutable-location}. If\n"
	    "neither is specified, @code{immutable-location} is assumed.\n\n"
	    "As a special case, if an element of signature is a lone\n"
	    "symbol @var{sym}, it is equivalent to an element of the form\n"
	    "@code{(sym)}.\n\n"
	    "All bindings in @var{exp} are immutable. If you apply\n"
	    "@code{environment-define} or @code{environment-undefine} to\n"
	    "@var{exp}, Guile will signal an\n"
	    "@code{environment:immutable-binding} error. However,\n"
	    "notice that the set of bindings in @var{exp} may still change,\n"
	    "if the bindings in private change.")
#define FUNC_NAME s_scm_make_export_environment
{
  size_t size;
  struct export_environment *body;
  SCM env;

  SCM_ASSERT (SCM_ENVIRONMENT_P (private), private, SCM_ARG1, FUNC_NAME);

  size = sizeof (struct export_environment);
  body = scm_gc_malloc (size, "export environment");

  core_environments_preinit (&body->base);
  body->private = SCM_BOOL_F;
  body->private_observer = SCM_BOOL_F;
  body->signature = SCM_BOOL_F;

  env = scm_make_environment (body);

  core_environments_init (&body->base, &export_environment_funcs);
  body->private = private;
  body->private_observer
    = SCM_ENVIRONMENT_OBSERVE (private, export_environment_observer, env, 1);
  body->signature = SCM_EOL;

  scm_export_environment_set_signature_x (env, signature);

  return env;
}
#undef FUNC_NAME

SCM_DEFINE (scm_export_environment_p, "export-environment?", 1, 0, 0,
	    (SCM object),
	    "Return @code{#t} if object is an export environment, or\n"
	    "@code{#f} otherwise.")
#define FUNC_NAME s_scm_export_environment_p
{
  return scm_from_bool (SCM_EXPORT_ENVIRONMENT_P (object));
}
#undef FUNC_NAME

SCM_DEFINE (scm_export_environment_private, "export-environment-private", 1, 0, 0,
	    (SCM env),
	    "Return the private environment of export environment @var{env}.")
#define FUNC_NAME s_scm_export_environment_private
{
  SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);

  return EXPORT_ENVIRONMENT (env)->private;
}
#undef FUNC_NAME

SCM_DEFINE (scm_export_environment_set_private_x, "export-environment-set-private!", 2, 0, 0,
	    (SCM env, SCM private),
	    "Change the private environment of export environment @var{env}.")
#define FUNC_NAME s_scm_export_environment_set_private_x
{
  struct export_environment *body;

  SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
  SCM_ASSERT (SCM_ENVIRONMENT_P (private), private, SCM_ARG2, FUNC_NAME);

  body = EXPORT_ENVIRONMENT (env);
  SCM_ENVIRONMENT_UNOBSERVE (private, body->private_observer);

  body->private = private;
  body->private_observer
    = SCM_ENVIRONMENT_OBSERVE (private, export_environment_observer, env, 1);

  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM_DEFINE (scm_export_environment_signature, "export-environment-signature", 1, 0, 0,
	    (SCM env),
	    "Return the signature of export environment @var{env}.")
#define FUNC_NAME s_scm_export_environment_signature
{
  SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);

  return EXPORT_ENVIRONMENT (env)->signature;
}
#undef FUNC_NAME

static SCM
export_environment_parse_signature (SCM signature, const char* caller)
{
  SCM result = SCM_EOL;
  SCM l;

  for (l = signature; scm_is_pair (l); l = SCM_CDR (l))
    {
      SCM entry = SCM_CAR (l);

      if (scm_is_symbol (entry))
	{
	  SCM new_entry = scm_cons2 (entry, symbol_immutable_location, SCM_EOL);
	  result = scm_cons (new_entry, result);
	}
      else
	{
	  SCM sym;
	  SCM new_entry;
	  int immutable = 0;
	  int mutable = 0;
	  SCM mutability;
	  SCM l2;

	  SCM_ASSERT (scm_is_pair (entry), entry, SCM_ARGn, caller);
	  SCM_ASSERT (scm_is_symbol (SCM_CAR (entry)), entry, SCM_ARGn, caller);

	  sym = SCM_CAR (entry);

	  for (l2 = SCM_CDR (entry); scm_is_pair (l2); l2 = SCM_CDR (l2))
	    {
	      SCM attribute = SCM_CAR (l2);
	      if (scm_is_eq (attribute, symbol_immutable_location))
		immutable = 1;
	      else if (scm_is_eq (attribute, symbol_mutable_location))
		mutable = 1;
	      else
		SCM_ASSERT (0, entry, SCM_ARGn, caller);
	    }
	  SCM_ASSERT (scm_is_null (l2), entry, SCM_ARGn, caller);
	  SCM_ASSERT (!mutable || !immutable, entry, SCM_ARGn, caller);

	  if (!mutable && !immutable)
	    immutable = 1;

	  mutability = mutable ? symbol_mutable_location : symbol_immutable_location;
	  new_entry = scm_cons2 (sym, mutability, SCM_EOL);
	  result = scm_cons (new_entry, result);
	}
    }
  SCM_ASSERT (scm_is_null (l), signature, SCM_ARGn, caller);

  /* Dirk:FIXME:: Now we know that signature is syntactically correct.  There
   * are, however, no checks for symbols entered twice with contradicting
   * mutabilities.  It would be nice, to implement this test, to be able to
   * call the sort functions conveniently from C.
   */

  return scm_reverse (result);
}

SCM_DEFINE (scm_export_environment_set_signature_x, "export-environment-set-signature!", 2, 0, 0,
	    (SCM env, SCM signature),
	    "Change the signature of export environment @var{env}.")
#define FUNC_NAME s_scm_export_environment_set_signature_x
{
  SCM parsed_sig;

  SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
  parsed_sig = export_environment_parse_signature (signature, FUNC_NAME);

  EXPORT_ENVIRONMENT (env)->signature = parsed_sig;

  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

void
scm_environments_prehistory ()
{
  /* create environment smob */
  scm_tc16_environment = scm_make_smob_type ("environment", 0);
  scm_set_smob_mark (scm_tc16_environment, environment_mark);
  scm_set_smob_free (scm_tc16_environment, environment_free);
  scm_set_smob_print (scm_tc16_environment, environment_print);

  /* create observer smob */
  scm_tc16_observer = scm_make_smob_type ("observer", 0);
  scm_set_smob_mark (scm_tc16_observer, observer_mark);
  scm_set_smob_print (scm_tc16_observer, observer_print);

  /* create system environment */
  scm_system_environment = scm_make_leaf_environment ();
  scm_permanent_object (scm_system_environment);
}

void
scm_init_environments ()
{
#include "libguile/environments.x"
}

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/


code:
/* classes: h_files */

#ifndef SCM_ENVIRONMENTS_H
#define SCM_ENVIRONMENTS_H

/* Copyright (C) 1999,2000, 2006 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 2.1 of the License, or (at your option) any later version.
 *
 * This library 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
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 */

#include "libguile/__scm.h"

/* The type for folding functions written in C.  A function meant to be passed
 * to scm_c_environment_fold should have the type scm_environment_folder.
 */
typedef SCM (*scm_environment_folder) (SCM data, SCM sym, SCM val, SCM tail);

/* The type for observer functions written in C.  A function meant to be
 * passed to scm_c_environment_observe should have the type
 * scm_environment_observer.
 */
typedef void (*scm_environment_observer) (SCM env, SCM data);

struct scm_environment_funcs {
  SCM (*ref) (SCM self, SCM symbol);
  SCM (*fold) (SCM self, scm_environment_folder proc, SCM data, SCM init);

  SCM (*define) (SCM self, SCM symbol, SCM value);
  SCM (*undefine) (SCM self, SCM symbol);
  SCM (*set) (SCM self, SCM symbol, SCM value);

  SCM (*cell) (SCM self, SCM symbol, int for_write);
  SCM (*observe) (SCM self, scm_environment_observer proc, SCM data, int weak_p);
  void (*unobserve) (SCM self, SCM token);

  SCM (*mark) (SCM self);
  void (*free) (SCM self);
  int (*print) (SCM self, SCM port, scm_print_state *pstate);
};

#define SCM_ENVIRONMENT_SUCCESS SCM_BOOL_T
#define SCM_ENVIRONMENT_BINDING_IMMUTABLE scm_from_int (0)
#define SCM_ENVIRONMENT_LOCATION_IMMUTABLE scm_from_int (1)
#define SCM_ENVIRONMENT_LOCATION_NO_CELL SCM_BOOL_F

SCM_API scm_t_bits scm_tc16_environment;

#define SCM_ENVIRONMENT_P(x) \
  (!SCM_IMP (x) && SCM_CELL_TYPE (x) == scm_tc16_environment)
#define SCM_ENVIRONMENT_FUNCS(env) \
  (*((struct scm_environment_funcs **) SCM_CELL_WORD_1 (env)))
#define SCM_ENVIRONMENT_BOUND_P(env, symbol) \
  (!SCM_UNBNDP (SCM_ENVIRONMENT_REF (env, symbol)))
#define SCM_ENVIRONMENT_REF(env, symbol) \
  ((*(SCM_ENVIRONMENT_FUNCS (env)->ref)) (env, symbol))
#define SCM_ENVIRONMENT_FOLD(env, proc, data, init) \
  ((*(SCM_ENVIRONMENT_FUNCS (env)->fold)) (env, proc, data, init))
#define SCM_ENVIRONMENT_DEFINE(env, symbol, value) \
  ((*(SCM_ENVIRONMENT_FUNCS (env)->define)) (env, symbol, value))
#define SCM_ENVIRONMENT_UNDEFINE(env, symbol) \
  ((*(SCM_ENVIRONMENT_FUNCS (env)->undefine)) (env, symbol))
#define SCM_ENVIRONMENT_SET(env, symbol, value) \
  ((*(SCM_ENVIRONMENT_FUNCS (env)->set)) (env, symbol, value))
#define SCM_ENVIRONMENT_CELL(env, symbol, for_write) \
  ((*(SCM_ENVIRONMENT_FUNCS (env)->cell)) (env, symbol, for_write))
#define SCM_ENVIRONMENT_OBSERVE(env, proc, data, weak_p) \
  ((*(SCM_ENVIRONMENT_FUNCS (env)->observe)) (env, proc, data, weak_p))
#define SCM_ENVIRONMENT_UNOBSERVE(env, token) \
  ((*(SCM_ENVIRONMENT_FUNCS (env)->unobserve)) (env, token))

SCM_API scm_t_bits scm_tc16_observer;

#define SCM_OBSERVER_P(x) \
  (!SCM_IMP (x) && (SCM_CELL_TYPE (x) == scm_tc16_observer))
#define SCM_OBSERVER_ENVIRONMENT(x) \
  (SCM_CELL_OBJECT_1 (x))
#define SCM_OBSERVER_DATA(x) \
  (SCM_CELL_OBJECT_2 (x))
#define SCM_OBSERVER_PROC(x) \
  ((scm_environment_observer) SCM_CELL_WORD_3 (x))

SCM_API SCM scm_system_environment;

SCM_API void scm_error_environment_unbound (const char *, SCM, SCM) SCM_NORETURN;
SCM_API void scm_error_environment_immutable_binding (const char *, SCM, SCM) SCM_NORETURN;
SCM_API void scm_error_environment_immutable_location (const char *, SCM, SCM) SCM_NORETURN;

SCM_API SCM scm_make_environment (void *type);
SCM_API SCM scm_environment_p (SCM env);
SCM_API SCM scm_environment_bound_p (SCM env, SCM sym);
SCM_API SCM scm_environment_ref (SCM env, SCM sym);
SCM_API SCM scm_c_environment_ref (SCM env, SCM sym);
SCM_API SCM scm_environment_fold (SCM env, SCM proc, SCM init);
SCM_API SCM scm_c_environment_fold (SCM env, scm_environment_folder proc, SCM data, SCM init);
SCM_API SCM scm_environment_define (SCM env, SCM sym, SCM val);
SCM_API SCM scm_environment_undefine (SCM env, SCM sym);
SCM_API SCM scm_environment_set_x (SCM env, SCM sym, SCM val);
SCM_API SCM scm_environment_cell (SCM env, SCM sym, SCM for_write);
SCM_API SCM scm_c_environment_cell (SCM env, SCM sym, int for_write);
SCM_API SCM scm_environment_observe (SCM env, SCM proc);
SCM_API SCM scm_environment_observe_weak (SCM env, SCM proc);
SCM_API SCM scm_c_environment_observe (SCM env, scm_environment_observer proc, SCM data, int weak_p);
SCM_API SCM scm_environment_unobserve (SCM token);

SCM_API void scm_environments_prehistory (void);
SCM_API void scm_init_environments (void);

SCM_API void *scm_type_leaf_environment;

#define SCM_LEAF_ENVIRONMENT_P(env) \
  (SCM_ENVIRONMENT_P (env) \
   && SCM_ENVIRONMENT_FUNCS (env) == scm_type_leaf_environment)

SCM_API SCM scm_make_leaf_environment (void);
SCM_API SCM scm_leaf_environment_p (SCM env);

SCM_API void *scm_type_eval_environment;

#define SCM_EVAL_ENVIRONMENT_P(env) \
  (SCM_ENVIRONMENT_P (env) \
   && SCM_ENVIRONMENT_FUNCS (env) == scm_type_eval_environment)

SCM_API SCM scm_make_eval_environment (SCM local, SCM imported);
SCM_API SCM scm_eval_environment_p (SCM env);
SCM_API SCM scm_eval_environment_local (SCM env);
SCM_API SCM scm_eval_environment_set_local_x (SCM env, SCM local);
SCM_API SCM scm_eval_environment_imported (SCM env);
SCM_API SCM scm_eval_environment_set_imported_x (SCM env, SCM imported);

SCM_API void *scm_type_import_environment;

#define SCM_IMPORT_ENVIRONMENT_P(env) \
  (SCM_ENVIRONMENT_P (env) \
   && SCM_ENVIRONMENT_FUNCS (env) == scm_type_import_environment)

SCM_API SCM scm_make_import_environment (SCM imports, SCM conflict_proc);
SCM_API SCM scm_import_environment_p (SCM env);
SCM_API SCM scm_import_environment_imports (SCM env);
SCM_API SCM scm_import_environment_set_imports_x (SCM env, SCM imports);

SCM_API void *scm_type_export_environment;

#define SCM_EXPORT_ENVIRONMENT_P(env) \
  (SCM_ENVIRONMENT_P (env) \
   && SCM_ENVIRONMENT_FUNCS (env) == scm_type_export_environment)

SCM_API SCM scm_make_export_environment (SCM private, SCM signature);
SCM_API SCM scm_export_environment_p (SCM env);
SCM_API SCM scm_export_environment_private (SCM env);
SCM_API SCM scm_export_environment_set_private_x (SCM env, SCM private);
SCM_API SCM scm_export_environment_signature (SCM env);
SCM_API SCM scm_export_environment_set_signature_x (SCM env, SCM signature);

#endif  /* SCM_ENVIRONMENTS_H */

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/


code:
/* Copyright (C) 1995,1996,1997,1998,2000,2001,2003, 2004, 2006 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 2.1 of the License, or (at your option) any later version.
 *
 * This library 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
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 */

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

#include "libguile/_scm.h"
#include "libguile/ramap.h"
#include "libguile/stackchk.h"
#include "libguile/strorder.h"
#include "libguile/async.h"
#include "libguile/root.h"
#include "libguile/smob.h"
#include "libguile/unif.h"
#include "libguile/vectors.h"

#include "libguile/struct.h"
#include "libguile/goops.h"
#include "libguile/objects.h"

#include "libguile/validate.h"
#include "libguile/eq.h"

#ifdef HAVE_STRING_H
#include <string.h>
#endif

SCM_DEFINE1 (scm_eq_p, "eq?", scm_tc7_rpsubr,
             (SCM x, SCM y),
	    "Return @code{#t} if @var{x} and @var{y} are the same object,\n"
	    "except for numbers and characters.  For example,\n"
	    "\n"
	    "@example\n"
	    "(define x (vector 1 2 3))\n"
	    "(define y (vector 1 2 3))\n"
	    "\n"
	    "(eq? x x)  @result{} #t\n"
	    "(eq? x y)  @result{} #f\n"
	    "@end example\n"
	    "\n"
	    "Numbers and characters are not equal to any other object, but\n"
	    "the problem is they're not necessarily @code{eq?} to themselves\n"
	    "either.  This is even so when the number comes directly from a\n"
	    "variable,\n"
	    "\n"
	    "@example\n"
	    "(let ((n (+ 2 3)))\n"
	    "  (eq? n n))       @result{} *unspecified*\n"
	    "@end example\n"
	    "\n"
	    "Generally @code{eqv?} should be used when comparing numbers or\n"
	    "characters.  @code{=} or @code{char=?} can be used too.\n"
	    "\n"
	    "It's worth noting that end-of-list @code{()}, @code{#t},\n"
	    "@code{#f}, a symbol of a given name, and a keyword of a given\n"
	    "name, are unique objects.  There's just one of each, so for\n"
	    "instance no matter how @code{()} arises in a program, it's the\n"
	    "same object and can be compared with @code{eq?},\n"
	    "\n"
	    "@example\n"
	    "(define x (cdr '(123)))\n"
	    "(define y (cdr '(456)))\n"
	    "(eq? x y) @result{} #t\n"
	    "\n"
	    "(define x (string->symbol \"foo\"))\n"
	    "(eq? x 'foo) @result{} #t\n"
	    "@end example")
#define FUNC_NAME s_scm_eq_p
{
  return scm_from_bool (scm_is_eq (x, y));
}
#undef FUNC_NAME

/* We compare doubles in a special way for 'eqv?' to be able to
   distinguish plus and minus zero and to identify NaNs.
*/

static int
real_eqv (double x, double y)
{
  return !memcmp (&x, &y, sizeof(double)) || (x != x && y != y);
}

#include <stdio.h>
SCM_PRIMITIVE_GENERIC_1 (scm_eqv_p, "eqv?", scm_tc7_rpsubr,
             (SCM x, SCM y),
	    "Return @code{#t} if @var{x} and @var{y} are the same object, or\n"
	    "for characters and numbers the same value.\n"
	    "\n"
	    "On objects except characters and numbers, @code{eqv?} is the\n"
	    "same as @code{eq?}, it's true if @var{x} and @var{y} are the\n"
	    "same object.\n"
	    "\n"
	    "If @var{x} and @var{y} are numbers or characters, @code{eqv?}\n"
	    "compares their type and value.  An exact number is not\n"
	    "@code{eqv?} to an inexact number (even if their value is the\n"
	    "same).\n"
	    "\n"
	    "@example\n"
	    "(eqv? 3 (+ 1 2)) @result{} #t\n"
	    "(eqv? 1 1.0)     @result{} #f\n"
	    "@end example")
#define FUNC_NAME s_scm_eqv_p
{
  if (scm_is_eq (x, y))
    return SCM_BOOL_T;
  if (SCM_IMP (x))
    return SCM_BOOL_F;
  if (SCM_IMP (y))
    return SCM_BOOL_F;
  /* this ensures that types and scm_length are the same. */

  if (SCM_CELL_TYPE (x) != SCM_CELL_TYPE (y))
    {
      /* fractions use 0x10000 as a flag (at the suggestion of Marius Vollmer),
	 but this checks the entire type word, so fractions may be accidentally
	 flagged here as unequal.  Perhaps I should use the 4th double_cell word?
      */

      /* treat mixes of real and complex types specially */
      if (SCM_INEXACTP (x))
	{
	  if (SCM_REALP (x))
	    return scm_from_bool (SCM_COMPLEXP (y)
			     && real_eqv (SCM_REAL_VALUE (x),
					  SCM_COMPLEX_REAL (y))
			     && SCM_COMPLEX_IMAG (y) == 0.0);
	  else
	    return scm_from_bool (SCM_REALP (y)
			     && real_eqv (SCM_COMPLEX_REAL (x),
					  SCM_REAL_VALUE (y))
			     && SCM_COMPLEX_IMAG (x) == 0.0);
	}

      if (SCM_FRACTIONP (x) && SCM_FRACTIONP (y))
	return scm_i_fraction_equalp (x, y);
      return SCM_BOOL_F;
    }
  if (SCM_NUMP (x))
    {
      if (SCM_BIGP (x)) {
	return scm_from_bool (scm_i_bigcmp (x, y) == 0);
      } else if (SCM_REALP (x)) {
	return scm_from_bool (real_eqv (SCM_REAL_VALUE (x), SCM_REAL_VALUE (y)));
      } else if (SCM_FRACTIONP (x)) {
	return scm_i_fraction_equalp (x, y);
      } else { /* complex */
	return scm_from_bool (real_eqv (SCM_COMPLEX_REAL (x),
				   SCM_COMPLEX_REAL (y))
			 && real_eqv (SCM_COMPLEX_IMAG (x),
				      SCM_COMPLEX_IMAG (y)));
      }
    }
  if (SCM_UNPACK (g_scm_eqv_p))
    return scm_call_generic_2 (g_scm_eqv_p, x, y);
  else
    return SCM_BOOL_F;
}
#undef FUNC_NAME

SCM_PRIMITIVE_GENERIC_1 (scm_equal_p, "equal?", scm_tc7_rpsubr,
			 (SCM x, SCM y),
	    "Return @code{#t} if @var{x} and @var{y} are the same type, and\n"
	    "their contents or value are equal.\n"
	    "\n"
	    "For a pair, string, vector or array, @code{equal?} compares the\n"
	    "contents, and does so using using the same @code{equal?}\n"
	    "recursively, so a deep structure can be traversed.\n"
	    "\n"
	    "@example\n"
	    "(equal? (list 1 2 3) (list 1 2 3))   @result{} #t\n"
	    "(equal? (list 1 2 3) (vector 1 2 3)) @result{} #f\n"
	    "@end example\n"
	    "\n"
	    "For other objects, @code{equal?} compares as per @code{eqv?},\n"
	    "which means characters and numbers are compared by type and\n"
	    "value (and like @code{eqv?}, exact and inexact numbers are not\n"
	    "@code{equal?}, even if their value is the same).\n"
	    "\n"
	    "@example\n"
	    "(equal? 3 (+ 1 2)) @result{} #t\n"
	    "(equal? 1 1.0)     @result{} #f\n"
	    "@end example\n"
	    "\n"
	    "Hash tables are currently only compared as per @code{eq?}, so\n"
	    "two different tables are not @code{equal?}, even if their\n"
	    "contents are the same.\n"
	    "\n"
	    "@code{equal?} does not support circular data structures, it may\n"
	    "go into an infinite loop if asked to compare two circular lists\n"
	    "or similar.\n"
	    "\n"
	    "New application-defined object types (Smobs) have an\n"
	    "@code{equalp} handler which is called by @code{equal?}.  This\n"
	    "lets an application traverse the contents or control what is\n"
	    "considered @code{equal?} for two such objects.  If there's no\n"
	    "handler, the default is to just compare as per @code{eq?}.")
#define FUNC_NAME s_scm_equal_p
{
  SCM_CHECK_STACK;
 tailrecurse:
  SCM_TICK;
  if (scm_is_eq (x, y))
    return SCM_BOOL_T;
  if (SCM_IMP (x))
    return SCM_BOOL_F;
  if (SCM_IMP (y))
    return SCM_BOOL_F;
  if (scm_is_pair (x) && scm_is_pair (y))
    {
      if (scm_is_false (scm_equal_p (SCM_CAR (x), SCM_CAR (y))))
	return SCM_BOOL_F;
      x = SCM_CDR(x);
      y = SCM_CDR(y);
      goto tailrecurse;
    }
  if (SCM_TYP7 (x) == scm_tc7_string && SCM_TYP7 (y) == scm_tc7_string)
    return scm_string_equal_p (x, y);
  if (SCM_TYP7 (x) == scm_tc7_smob && SCM_TYP16 (x) == SCM_TYP16 (y))
    {
      int i = SCM_SMOBNUM (x);
      if (!(i < scm_numsmob))
	return SCM_BOOL_F;
      if (scm_smobs[i].equalp)
	return (scm_smobs[i].equalp) (x, y);
      else
	goto generic_equal;
    }
  /* This ensures that types and scm_length are the same.  */
  if (SCM_CELL_TYPE (x) != SCM_CELL_TYPE (y))
    {
      /* treat mixes of real and complex types specially */
      if (SCM_INEXACTP (x) && SCM_INEXACTP (y))
	{
	  if (SCM_REALP (x))
	    return scm_from_bool (SCM_COMPLEXP (y)
			     && SCM_REAL_VALUE (x) == SCM_COMPLEX_REAL (y)
			     && SCM_COMPLEX_IMAG (y) == 0.0);
	  else
	    return scm_from_bool (SCM_REALP (y)
			     && SCM_COMPLEX_REAL (x) == SCM_REAL_VALUE (y)
			     && SCM_COMPLEX_IMAG (x) == 0.0);
	}

      /* Vectors can be equal to one-dimensional arrays.
       */
      if (SCM_I_ARRAYP (x) || SCM_I_ARRAYP (y))
	return scm_array_equal_p (x, y);

      return SCM_BOOL_F;
    }
  switch (SCM_TYP7 (x))
    {
    default:
      break;
    case scm_tc7_number:
      switch SCM_TYP16 (x)
        {
        case scm_tc16_big:
          return scm_bigequal (x, y);
        case scm_tc16_real:
          return scm_real_equalp (x, y);
        case scm_tc16_complex:
          return scm_complex_equalp (x, y);
	case scm_tc16_fraction:
          return scm_i_fraction_equalp (x, y);
        }
    case scm_tc7_vector:
    case scm_tc7_wvect:
      return scm_i_vector_equal_p (x, y);
    }

  /* Check equality between structs of equal type (see cell-type test above)
     that are not GOOPS instances.  GOOPS instances are treated via the
     generic function.  */
  if ((SCM_STRUCTP (x)) && (!SCM_INSTANCEP (x)))
    return scm_i_struct_equalp (x, y);

 generic_equal:
  if (SCM_UNPACK (g_scm_equal_p))
    return scm_call_generic_2 (g_scm_equal_p, x, y);
  else
    return SCM_BOOL_F;
}
#undef FUNC_NAME

void
scm_init_eq ()
{
#include "libguile/eq.x"
}

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/


code:
/* classes: h_files */

#ifndef SCM_EQ_H
#define SCM_EQ_H

/* Copyright (C) 1995,1996,2000, 2006 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 2.1 of the License, or (at your option) any later version.
 *
 * This library 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
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 */

#include "libguile/__scm.h"

SCM_API SCM scm_eq_p (SCM x, SCM y);
SCM_API SCM scm_eqv_p (SCM x, SCM y);
SCM_API SCM scm_equal_p (SCM x, SCM y);
SCM_API void scm_init_eq (void);

#endif  /* SCM_EQ_H */

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/