code:
/* dynl.c - dynamic linking
 *
 * Copyright (C) 1990, 91, 92, 93, 94, 95, 96, 97, 98, 99, 2000, 2001, 2002,
 * 2003, 2008, 2009, 2010 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 3 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

/* "dynl.c" dynamically link&load object files.
   Author: Aubrey Jaffer
   Modified for libguile by Marius Vollmer */

#if 0 /* Disabled until we know for sure that it isn't needed */
/* XXX - This is only here to drag in a definition of __eprintf. This
   is needed for proper operation of dynamic linking. The real
   solution would probably be a shared libgcc. */

#undef NDEBUG
#include <assert.h>

static void
maybe_drag_in_eprintf ()
{
  assert (!maybe_drag_in_eprintf);
}
#endif

#include <stdio.h>
#include <string.h>

#include "libguile/_scm.h"
#include "libguile/libpath.h"
#include "libguile/dynl.h"
#include "libguile/smob.h"
#include "libguile/keywords.h"
#include "libguile/ports.h"
#include "libguile/strings.h"
#include "libguile/deprecation.h"
#include "libguile/validate.h"
#include "libguile/dynwind.h"
#include "libguile/foreign.h"

#include <ltdl.h>

/*
  From the libtool manual: "Note that libltdl is not threadsafe,
  i.e. a multithreaded application has to use a mutex for libltdl.".

  Guile does not currently support pre-emptive threads, so there is no
  mutex.  Previously SCM_CRITICAL_SECTION_START and
  SCM_CRITICAL_SECTION_END were used: they are mentioned here in case
  somebody is grepping for thread problems ;)
*/
/* njrev: not threadsafe, protection needed as described above */

static void *
sysdep_dynl_link (const char *fname, const char *subr)
{
  lt_dlhandle handle;

  if (fname != NULL)
    handle = lt_dlopenext (fname);
  else
    /* Return a handle for the program as a whole.  */
    handle = lt_dlopen (NULL);

  if (NULL == handle)
    {
      SCM fn;
      SCM msg;

      fn = fname != NULL ? scm_from_locale_string (fname) : SCM_BOOL_F;
      msg = scm_from_locale_string (lt_dlerror ());
      scm_misc_error (subr, "file: ~S, message: ~S", scm_list_2 (fn, msg));
    }

  return (void *) handle;
}

static void
sysdep_dynl_unlink (void *handle, const char *subr)
{
  if (lt_dlclose ((lt_dlhandle) handle))
    {
      scm_misc_error (subr, (char *) lt_dlerror (), SCM_EOL);
    }
}

static void *
sysdep_dynl_value (const char *symb, void *handle, const char *subr)
{
  void *fptr;

  fptr = lt_dlsym ((lt_dlhandle) handle, symb);
  if (!fptr)
    {
      scm_misc_error (subr, (char *) lt_dlerror (), SCM_EOL);
    }
  return fptr;
}

static void
sysdep_dynl_init ()
{
  char *env;

  lt_dlinit ();

  env = getenv ("GUILE_SYSTEM_EXTENSIONS_PATH");
  if (env && strcmp (env, "") == 0)
    /* special-case interpret system-ltdl-path=="" as meaning no system path,
       which is the case during the build */
    ;
  else if (env)
    /* FIXME: should this be a colon-separated path? Or is the only point to
       allow the build system to turn off the installed extensions path? */
    lt_dladdsearchdir (env);
  else
    {
      lt_dladdsearchdir (SCM_LIB_DIR);
      lt_dladdsearchdir (SCM_EXTENSIONS_DIR);
    }
}

scm_t_bits scm_tc16_dynamic_obj;

#define DYNL_FILENAME         SCM_SMOB_OBJECT
#define DYNL_HANDLE(x)        ((void *) SCM_SMOB_DATA_2 (x))
#define SET_DYNL_HANDLE(x, v) (SCM_SET_SMOB_DATA_2 ((x), (scm_t_bits) (v)))

static int
dynl_obj_print (SCM exp, SCM port, scm_print_state *pstate)
{
  scm_puts ("#<dynamic-object ", port);
  scm_iprin1 (DYNL_FILENAME (exp), port, pstate);
  if (DYNL_HANDLE (exp) == NULL)
    scm_puts (" (unlinked)", port);
  scm_putc ('>', port);
  return 1;
}

SCM_DEFINE (scm_dynamic_link, "dynamic-link", 0, 1, 0,
            (SCM filename),
	    "Find the shared object (shared library) denoted by\n"
	    "@var{filename} and link it into the running Guile\n"
	    "application.  The returned\n"
	    "scheme object is a ``handle'' for the library which can\n"
	    "be passed to @code{dynamic-func}, @code{dynamic-call} etc.\n\n"
	    "Searching for object files is system dependent.  Normally,\n"
	    "if @var{filename} does have an explicit directory it will\n"
	    "be searched for in locations\n"
	    "such as @file{/usr/lib} and @file{/usr/local/lib}.\n\n"
	    "When @var{filename} is omitted, a @dfn{global symbol handle} is\n"
	    "returned.  This handle provides access to the symbols\n"
	    "available to the program at run-time, including those exported\n"
	    "by the program itself and the shared libraries already loaded.\n")
#define FUNC_NAME s_scm_dynamic_link
{
  void *handle;
  char *file;

  scm_dynwind_begin (0);

  if (SCM_UNBNDP (filename))
    file = NULL;
  else
    {
      file = scm_to_locale_string (filename);
      scm_dynwind_free (file);
    }

  handle = sysdep_dynl_link (file, FUNC_NAME);
  scm_dynwind_end ();

  SCM_RETURN_NEWSMOB2 (scm_tc16_dynamic_obj,
		       SCM_UNBNDP (filename)
		       ? SCM_UNPACK (SCM_BOOL_F) : SCM_UNPACK (filename),
		       handle);
}
#undef FUNC_NAME

SCM_DEFINE (scm_dynamic_object_p, "dynamic-object?", 1, 0, 0,
            (SCM obj),
	    "Return @code{#t} if @var{obj} is a dynamic object handle,\n"
	    "or @code{#f} otherwise.")
#define FUNC_NAME s_scm_dynamic_object_p
{
  return scm_from_bool (SCM_TYP16_PREDICATE (scm_tc16_dynamic_obj, obj));
}
#undef FUNC_NAME

SCM_DEFINE (scm_dynamic_unlink, "dynamic-unlink", 1, 0, 0,
            (SCM dobj),
	    "Unlink a dynamic object from the application, if possible.  The\n"
	    "object must have been linked by @code{dynamic-link}, with \n"
	    "@var{dobj} the corresponding handle.  After this procedure\n"
	    "is called, the handle can no longer be used to access the\n"
	    "object.")
#define FUNC_NAME s_scm_dynamic_unlink
{
  /*fixme* GC-problem */
  SCM_VALIDATE_SMOB (SCM_ARG1, dobj, dynamic_obj);
  if (DYNL_HANDLE (dobj) == NULL) {
    SCM_MISC_ERROR ("Already unlinked: ~S", scm_list_1 (dobj));
  } else {
    sysdep_dynl_unlink (DYNL_HANDLE (dobj), FUNC_NAME);
    SET_DYNL_HANDLE (dobj, NULL);
    return SCM_UNSPECIFIED;
  }
}
#undef FUNC_NAME

SCM_DEFINE (scm_dynamic_pointer, "dynamic-pointer", 2, 0, 0,
            (SCM name, SCM dobj),
	    "Return a ``wrapped pointer'' to the symbol @var{name}\n"
	    "in the shared object referred to by @var{dobj}.  The returned\n"
	    "pointer points to a C object.\n\n"
	    "Regardless whether your C compiler prepends an underscore\n"
	    "@samp{_} to the global names in a program, you should\n"
	    "@strong{not} include this underscore in @var{name}\n"
	    "since it will be added automatically when necessary.")
#define FUNC_NAME s_scm_dynamic_pointer
{
  void *val;

  SCM_VALIDATE_STRING (1, name);
  SCM_VALIDATE_SMOB (SCM_ARG2, dobj, dynamic_obj);

  if (DYNL_HANDLE (dobj) == NULL)
    SCM_MISC_ERROR ("Already unlinked: ~S", dobj);
  else
    {
      char *chars;

      scm_dynwind_begin (0);
      chars = scm_to_locale_string (name);
      scm_dynwind_free (chars);
      val = sysdep_dynl_value (chars, DYNL_HANDLE (dobj), FUNC_NAME);
      scm_dynwind_end ();

      return scm_from_pointer (val, NULL);
    }
}
#undef FUNC_NAME

SCM_DEFINE (scm_dynamic_func, "dynamic-func", 2, 0, 0,
            (SCM name, SCM dobj),
	    "Return a ``handle'' for the function @var{name} in the\n"
	    "shared object referred to by @var{dobj}.  The handle\n"
	    "can be passed to @code{dynamic-call} to actually\n"
	    "call the function.\n\n"
	    "Regardless whether your C compiler prepends an underscore\n"
	    "@samp{_} to the global names in a program, you should\n"
	    "@strong{not} include this underscore in @var{name}\n"
	    "since it will be added automatically when necessary.")
#define FUNC_NAME s_scm_dynamic_func
{
  return scm_dynamic_pointer (name, dobj);
}
#undef FUNC_NAME

SCM_DEFINE (scm_dynamic_call, "dynamic-call", 2, 0, 0,
            (SCM func, SCM dobj),
	    "Call a C function in a dynamic object.  Two styles of\n"
	    "invocation are supported:\n\n"
	    "@itemize @bullet\n"
	    "@item @var{func} can be a function handle returned by\n"
	    "@code{dynamic-func}.  In this case @var{dobj} is\n"
	    "ignored\n"
	    "@item @var{func} can be a string with the name of the\n"
	    "function to call, with @var{dobj} the handle of the\n"
	    "dynamic object in which to find the function.\n"
	    "This is equivalent to\n"
	    "@smallexample\n\n"
	    "(dynamic-call (dynamic-func @var{func} @var{dobj}) #f)\n"
	    "@end smallexample\n"
	    "@end itemize\n\n"
	    "In either case, the function is passed no arguments\n"
	    "and its return value is ignored.")
#define FUNC_NAME s_scm_dynamic_call
{
  void (*fptr) (void);

  if (scm_is_string (func))
    func = scm_dynamic_func (func, dobj);
  SCM_VALIDATE_POINTER (SCM_ARG1, func);

  fptr = SCM_POINTER_VALUE (func);
  fptr ();
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

void
scm_init_dynamic_linking ()
{
  scm_tc16_dynamic_obj = scm_make_smob_type ("dynamic-object", 0);
  scm_set_smob_print (scm_tc16_dynamic_obj, dynl_obj_print);
  sysdep_dynl_init ();
#include "libguile/dynl.x"
}

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


code:
/* classes: h_files */

#ifndef SCM_DYNL_H
#define SCM_DYNL_H

/* Copyright (C) 1996,1998,2000,2001, 2006, 2008, 2010 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 3 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_dynamic_link (SCM fname);
SCM_API SCM scm_dynamic_unlink (SCM dobj);
SCM_API SCM scm_dynamic_object_p (SCM obj);
SCM_API SCM scm_dynamic_pointer (SCM name, SCM dobj);
SCM_API SCM scm_dynamic_func (SCM symb, SCM dobj);
SCM_API SCM scm_dynamic_call (SCM symb, SCM dobj);

SCM_INTERNAL void scm_init_dynamic_linking (void);

#endif  /* SCM_DYNL_H */

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

license: mit


code:
/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 2008, 2010 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 3 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/control.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>
   #<with-fluids>
   #<prompt>
   (enter-proc . leave-proc)     dynamic-wind

*/

SCM
scm_dynamic_wind (SCM in_guard, SCM thunk, SCM out_guard)
#define FUNC_NAME "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);
}

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_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 if (SCM_WITH_FLUIDS_P (wind_elt))
	{
          scm_i_swap_with_fluids (wind_elt,
                                  SCM_I_CURRENT_THREAD->dynamic_state);
	}
      else if (SCM_PROMPT_P (wind_elt))
        ; /* pass -- see vm_reinstate_partial_continuation */
      else if (scm_is_pair (wind_elt))
        scm_call_0 (SCM_CAR (wind_elt));
      else
        /* trash on the wind list */
        abort ();

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

      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 if (SCM_WITH_FLUIDS_P (wind_elt))
	{
          scm_i_swap_with_fluids (wind_elt,
                                  SCM_I_CURRENT_THREAD->dynamic_state);
	}
      else if (SCM_PROMPT_P (wind_elt))
        ; /* pass -- though we could invalidate the prompt */
      else if (scm_is_pair (wind_elt))
        scm_call_0 (SCM_CDR (wind_elt));
      else
        /* trash on the wind list */
        abort ();

      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);

#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, 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 3 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_INTERNAL void scm_i_dowinds (SCM to, long delta,
				 void (*turn_func) (void *), void *data);
SCM_INTERNAL 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:
*/


code:
/* Copyright (C) 1995,1996,1997,1998,2000,2001,2003, 2004, 2006, 2009, 2010 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 3 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/array-map.h"
#include "libguile/stackchk.h"
#include "libguile/strorder.h"
#include "libguile/async.h"
#include "libguile/root.h"
#include "libguile/smob.h"
#include "libguile/arrays.h"
#include "libguile/vectors.h"
#include "libguile/hashtab.h"
#include "libguile/bytevectors.h"

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

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

#include "libguile/private-options.h"

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

static SCM scm_i_eq_p (SCM x, SCM y, SCM rest);
SCM_DEFINE (scm_i_eq_p, "eq?", 0, 2, 1,
            (SCM x, SCM y, SCM rest),
	    "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_i_eq_p
{
  if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
    return SCM_BOOL_T;
  while (scm_is_pair (rest))
    {
      if (!scm_is_eq (x, y))
        return SCM_BOOL_F;
      x = y;
      y = scm_car (rest);
      rest = scm_cdr (rest);
    }
  return scm_from_bool (scm_is_eq (x, y));
}
#undef FUNC_NAME

SCM
scm_eq_p (SCM x, SCM y)
{
  return scm_from_bool (scm_is_eq (x, y));
}

/* 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);
}

static SCM scm_i_eqv_p (SCM x, SCM y, SCM rest);
#include <stdio.h>
SCM_DEFINE (scm_i_eqv_p, "eqv?", 0, 2, 1,
            (SCM x, SCM y, SCM rest),
	    "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_i_eqv_p
{
  if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
    return SCM_BOOL_T;
  while (!scm_is_null (rest))
    {
      if (!scm_is_true (scm_eqv_p (x, y)))
        return SCM_BOOL_F;
      x = y;
      y = scm_car (rest);
      rest = scm_cdr (rest);
    }
  return scm_eqv_p (x, y);
}
#undef FUNC_NAME

SCM scm_eqv_p (SCM x, SCM y)
#define FUNC_NAME s_scm_i_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)));
      }
    }
  return SCM_BOOL_F;
}
#undef FUNC_NAME

static SCM scm_i_equal_p (SCM, SCM, SCM);
SCM_PRIMITIVE_GENERIC (scm_i_equal_p, "equal?", 0, 2, 1,
                       (SCM x, SCM y, SCM rest),
                       "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_i_equal_p
{
  if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
    return SCM_BOOL_T;
  while (!scm_is_null (rest))
    {
      if (!scm_is_true (scm_equal_p (x, y)))
        return SCM_BOOL_F;
      x = y;
      y = scm_car (rest);
      rest = SCM_CDR (rest);
    }
  return scm_equal_p (x, y);
}
#undef FUNC_NAME

SCM
scm_equal_p (SCM x, SCM y)
#define FUNC_NAME s_scm_i_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_bytevector && SCM_TYP7 (y) == scm_tc7_bytevector)
    return scm_bytevector_eq_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_is_array (x) && scm_is_array (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). */
  if (SCM_STRUCTP (x))
    {
      if (SCM_INSTANCEP (x))
        goto generic_equal;
      else
        return scm_i_struct_equalp (x, y);
    }

  /* Otherwise just return false. Dispatching to the generic is the wrong thing
     here, as we can hit this case for any two objects of the same type that we
     think are distinct, like different symbols. */
  return SCM_BOOL_F;

 generic_equal:
  if (SCM_UNPACK (g_scm_i_equal_p))
    return scm_call_generic_2 (g_scm_i_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, 2008, 2010 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 3 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_is_eq is defined in tags.h for some reason. */

/* An older spelling for scm_is_eq. */
#define SCM_EQ_P(x,y) (scm_is_eq (x, y))

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_INTERNAL void scm_init_eq (void);

#endif  /* SCM_EQ_H */

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


code:
/* Copyright (C) 1995,1996,1997,1998,2000,2001, 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 3 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 <stdio.h>
#include <errno.h>

#include "libguile/_scm.h"
#include "libguile/dynwind.h"
#include "libguile/pairs.h"
#include "libguile/strings.h"
#include "libguile/throw.h"

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

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

/* For Windows... */
#ifdef HAVE_IO_H
#include <io.h>
#endif

/* {Errors and Exceptional Conditions}
 */

/* Scheme interface to scm_error_scm.  */
void
scm_error (SCM key, const char *subr, const char *message, SCM args, SCM rest)
{
  scm_error_scm
    (key,
     (subr == NULL) ? SCM_BOOL_F : scm_from_locale_string (subr),
     (message == NULL) ? SCM_BOOL_F : scm_from_locale_string (message),
     args, rest);
}

/* All errors should pass through here.  */
SCM_DEFINE (scm_error_scm, "scm-error", 5, 0, 0,
           (SCM key, SCM subr, SCM message, SCM args, SCM data),
	    "Raise an error with key @var{key}.  @var{subr} can be a string\n"
	    "naming the procedure associated with the error, or @code{#f}.\n"
	    "@var{message} is the error message string, possibly containing\n"
	    "@code{~S} and @code{~A} escapes.  When an error is reported,\n"
	    "these are replaced by formatting the corresponding members of\n"
	    "@var{args}: @code{~A} (was @code{%s} in older versions of\n"
	    "Guile) formats using @code{display} and @code{~S} (was\n"
	    "@code{%S}) formats using @code{write}.  @var{data} is a list or\n"
	    "@code{#f} depending on @var{key}: if @var{key} is\n"
	    "@code{system-error} then it should be a list containing the\n"
	    "Unix @code{errno} value; If @var{key} is @code{signal} then it\n"
	    "should be a list containing the Unix signal number; If\n"
	    "@var{key} is @code{out-of-range} or @code{wrong-type-arg},\n"
            "it is a list containing the bad value; otherwise\n"
	    "it will usually be @code{#f}.")
#define FUNC_NAME s_scm_error_scm
{
  if (scm_gc_running_p)
    {
      /* The error occured during GC --- abort */
      fprintf (stderr, "Guile: error during GC.\n"),
      abort ();
    }

  scm_ithrow (key, scm_list_4 (subr, message, args, data), 1);

  /* No return, but just in case: */
  fprintf (stderr, "Guile scm_ithrow returned!\n");
  exit (1);
}
#undef FUNC_NAME

#ifdef __MINGW32__
# include "win32-socket.h"
# define SCM_I_STRERROR(err) \
    ((err >= WSABASEERR) ? scm_i_socket_strerror (err) : strerror (err))
# define SCM_I_ERRNO() \
    (errno ? errno : scm_i_socket_errno ())
#else
# define SCM_I_STRERROR(err) strerror (err)
# define SCM_I_ERRNO() errno
#endif /* __MINGW32__ */

/* strerror may not be thread safe, for instance in glibc (version 2.3.2) an
   error number not among the known values results in a string like "Unknown
   error 9999" formed in a static buffer, which will be overwritten by a
   similar call in another thread.  A test program running two threads with
   different unknown error numbers can trip this fairly quickly.

   Some systems don't do what glibc does, instead just giving a single
   "Unknown error" for unrecognised numbers.  It doesn't seem worth trying
   to tell if that's the case, a mutex is reasonably fast, and strerror
   isn't needed very often.

   strerror_r (when available) could be used, it might be a touch faster
   than a frame and a mutex, though there's probably not much
   difference.  */

SCM_DEFINE (scm_strerror, "strerror", 1, 0, 0,
            (SCM err),
	    "Return the Unix error message corresponding to @var{err}, which\n"
	    "must be an integer value.")
#define FUNC_NAME s_scm_strerror
{
  SCM ret;
  scm_dynwind_begin (0);
  scm_i_dynwind_pthread_mutex_lock (&scm_i_misc_mutex);

  ret = scm_from_locale_string (SCM_I_STRERROR (scm_to_int (err)));

  scm_dynwind_end ();
  return ret;
}
#undef FUNC_NAME

SCM_GLOBAL_SYMBOL (scm_system_error_key, "system-error");
void
scm_syserror (const char *subr)
{
  SCM err = scm_from_int (SCM_I_ERRNO ());
  scm_error (scm_system_error_key,
	     subr,
	     "~A",
	     scm_cons (scm_strerror (err), SCM_EOL),
	     scm_cons (err, SCM_EOL));
}

void
scm_syserror_msg (const char *subr, const char *message, SCM args, int eno)
{
  scm_error (scm_system_error_key,
	     subr,
	     message,
	     args,
	     scm_cons (scm_from_int (eno), SCM_EOL));
}

SCM_GLOBAL_SYMBOL (scm_num_overflow_key, "numerical-overflow");
void
scm_num_overflow (const char *subr)
{
  scm_error (scm_num_overflow_key,
	     subr,
	     "Numerical overflow",
	     SCM_BOOL_F,
	     SCM_BOOL_F);
}

SCM_GLOBAL_SYMBOL (scm_out_of_range_key, "out-of-range");
void
scm_out_of_range (const char *subr, SCM bad_value)
{
  scm_error (scm_out_of_range_key,
	     subr,
	     "Value out of range: ~S",
             scm_list_1 (bad_value),
             scm_list_1 (bad_value));
}

void
scm_out_of_range_pos (const char *subr, SCM bad_value, SCM pos)
{
  scm_error (scm_out_of_range_key,
	     subr,
	     "Argument ~A out of range: ~S",
             scm_list_2 (pos, bad_value),
	     scm_list_1 (bad_value));
}

SCM_GLOBAL_SYMBOL (scm_args_number_key, "wrong-number-of-args");
void
scm_wrong_num_args (SCM proc)
{
  scm_error (scm_args_number_key,
	     NULL,
	     "Wrong number of arguments to ~A",
	     scm_list_1 (proc),
	     SCM_BOOL_F);
}

void
scm_error_num_args_subr (const char *subr)
{
  scm_error (scm_args_number_key,
	     NULL,
	     "Wrong number of arguments to ~A",
	     scm_list_1 (scm_from_locale_string (subr)),
	     SCM_BOOL_F);
}

SCM_GLOBAL_SYMBOL (scm_arg_type_key, "wrong-type-arg");
void
scm_wrong_type_arg (const char *subr, int pos, SCM bad_value)
{
  scm_error (scm_arg_type_key,
	     subr,
	     (pos == 0) ? "Wrong type: ~S"
	     : "Wrong type argument in position ~A: ~S",
	     (pos == 0) ? scm_list_1 (bad_value)
	     : scm_list_2 (scm_from_int (pos), bad_value),
	     scm_list_1 (bad_value));
}

void
scm_i_wrong_type_arg_symbol (SCM symbol, int pos, SCM bad_value)
{
  scm_error_scm (scm_arg_type_key,
		 scm_symbol_to_string (symbol),
		 (pos == 0) ? scm_from_locale_string ("Wrong type: ~S")
		 : scm_from_locale_string ("Wrong type argument in position ~A: ~S"),
		 (pos == 0) ? scm_list_1 (bad_value)
		 : scm_list_2 (scm_from_int (pos), bad_value),
		 scm_list_1 (bad_value));
  scm_remember_upto_here_2 (symbol, bad_value);
}

void
scm_wrong_type_arg_msg (const char *subr, int pos, SCM bad_value, const char *szMessage)
{
  SCM msg = scm_from_locale_string (szMessage);
  if (pos == 0)
    {
      scm_error (scm_arg_type_key,
		 subr, "Wrong type (expecting ~A): ~S",
		 scm_list_2 (msg, bad_value),
		 scm_list_1 (bad_value));
    }
  else
    {
      scm_error (scm_arg_type_key,
		 subr,
		 "Wrong type argument in position ~A (expecting ~A): ~S",
		 scm_list_3 (scm_from_int (pos), msg, bad_value),
		 scm_list_1 (bad_value));
    }
}

SCM_GLOBAL_SYMBOL (scm_memory_alloc_key, "memory-allocation-error");
void
scm_memory_error (const char *subr)
{
  fprintf (stderr, "FATAL: memory error in %s\n", subr);
  abort ();
}

SCM_GLOBAL_SYMBOL (scm_misc_error_key, "misc-error");
void
scm_misc_error (const char *subr, const char *message, SCM args)
{
  scm_error (scm_misc_error_key, subr, message, args, SCM_BOOL_F);
}

void
scm_init_error ()
{
#include "libguile/cpp-E.c"
#include "libguile/error.x"
}

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


code:
/* classes: h_files */

#ifndef SCM_ERROR_H
#define SCM_ERROR_H

/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 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 3 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_system_error_key;
SCM_API SCM scm_num_overflow_key;
SCM_API SCM scm_out_of_range_key;
SCM_API SCM scm_args_number_key;
SCM_API SCM scm_arg_type_key;
SCM_API SCM scm_memory_alloc_key;
SCM_API SCM scm_misc_error_key;

SCM_API void scm_error (SCM key, const char *subr, const char *message,
			SCM args, SCM rest) SCM_NORETURN;
SCM_API SCM scm_error_scm (SCM key, SCM subr, SCM message,
			   SCM args, SCM rest) SCM_NORETURN;
SCM_API SCM scm_strerror (SCM err);
SCM_API void scm_syserror (const char *subr) SCM_NORETURN;
SCM_API void scm_syserror_msg (const char *subr, const char *message,
			       SCM args, int eno) SCM_NORETURN;
SCM_API void scm_num_overflow (const char *subr) SCM_NORETURN;
SCM_API void scm_out_of_range (const char *subr, SCM bad_value)
     SCM_NORETURN;
SCM_API void scm_out_of_range_pos (const char *subr, SCM bad_value, SCM pos)
     SCM_NORETURN;
SCM_API void scm_wrong_num_args (SCM proc) SCM_NORETURN;
SCM_API void scm_error_num_args_subr (const char* subr) SCM_NORETURN;
SCM_API void scm_wrong_type_arg (const char *subr, int pos,
				 SCM bad_value) SCM_NORETURN;
SCM_INTERNAL void scm_i_wrong_type_arg_symbol (SCM symbol, int pos,
					       SCM bad_value) SCM_NORETURN;
SCM_API void scm_wrong_type_arg_msg (const char *subr, int pos,
				     SCM bad_value, const char *sz) SCM_NORETURN;
SCM_API void scm_memory_error (const char *subr) SCM_NORETURN;
SCM_API void scm_misc_error (const char *subr, const char *message,
			     SCM args) SCM_NORETURN;
SCM_INTERNAL void scm_init_error (void);

#endif  /* SCM_ERROR_H */

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


code:
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010
 * 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 3 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 <alloca.h>
#include <assert.h>

#include "libguile/__scm.h"

#include "libguile/_scm.h"
#include "libguile/alist.h"
#include "libguile/async.h"
#include "libguile/continuations.h"
#include "libguile/control.h"
#include "libguile/debug.h"
#include "libguile/deprecation.h"
#include "libguile/dynwind.h"
#include "libguile/eq.h"
#include "libguile/expand.h"
#include "libguile/feature.h"
#include "libguile/fluids.h"
#include "libguile/goops.h"
#include "libguile/hash.h"
#include "libguile/hashtab.h"
#include "libguile/list.h"
#include "libguile/macros.h"
#include "libguile/memoize.h"
#include "libguile/modules.h"
#include "libguile/ports.h"
#include "libguile/print.h"
#include "libguile/procprop.h"
#include "libguile/programs.h"
#include "libguile/root.h"
#include "libguile/smob.h"
#include "libguile/srcprop.h"
#include "libguile/stackchk.h"
#include "libguile/strings.h"
#include "libguile/threads.h"
#include "libguile/throw.h"
#include "libguile/validate.h"
#include "libguile/values.h"
#include "libguile/vectors.h"
#include "libguile/vm.h"

#include "libguile/eval.h"
#include "libguile/private-options.h"

/* We have three levels of EVAL here:

   - eval (exp, env)

     evaluates EXP in environment ENV.  ENV is a lexical environment
     structure as used by the actual tree code evaluator.  When ENV is
     a top-level environment, then changes to the current module are
     tracked by updating ENV so that it continues to be in sync with
     the current module.

   - scm_primitive_eval (exp)

     evaluates EXP in the top-level environment as determined by the
     current module.  This is done by constructing a suitable
     environment and calling eval.  Thus, changes to the
     top-level module are tracked normally.

   - scm_eval (exp, mod)

     evaluates EXP while MOD is the current module. This is done
     by setting the current module to MOD_OR_STATE, invoking
     scm_primitive_eval on EXP, and then restoring the current module
     to the value it had previously.  That is, while EXP is evaluated,
     changes to the current module (or dynamic state) are tracked,
     but these changes do not persist when scm_eval returns.

*/

/* Boot closures. We only see these when compiling eval.scm, because once
   eval.scm is in the house, closures are standard VM closures.
 */

static scm_t_bits scm_tc16_boot_closure;
#define RETURN_BOOT_CLOSURE(code, env) SCM_RETURN_NEWSMOB2 (scm_tc16_boot_closure, (code), (env))
#define BOOT_CLOSURE_P(obj) SCM_TYP16_PREDICATE (scm_tc16_boot_closure, (obj))
#define BOOT_CLOSURE_CODE(x) SCM_SMOB_OBJECT (x)
#define BOOT_CLOSURE_ENV(x) SCM_SMOB_OBJECT_2 (x)
#define BOOT_CLOSURE_BODY(x) CAR (BOOT_CLOSURE_CODE (x))
#define BOOT_CLOSURE_NUM_REQUIRED_ARGS(x) SCM_I_INUM (CADR (BOOT_CLOSURE_CODE (x)))
#define BOOT_CLOSURE_IS_FIXED(x) scm_is_null (CDDR (BOOT_CLOSURE_CODE (x)))
/* NB: One may only call the following accessors if the closure is not FIXED. */
#define BOOT_CLOSURE_HAS_REST_ARGS(x) scm_is_true (CADDR (BOOT_CLOSURE_CODE (x)))
#define BOOT_CLOSURE_IS_REST(x) scm_is_null (CDDDR (BOOT_CLOSURE_CODE (x)))
/* NB: One may only call the following accessors if the closure is not REST. */
#define BOOT_CLOSURE_IS_FULL(x) (1)
#define BOOT_CLOSURE_PARSE_FULL(fu_,body,nargs,rest,nopt,kw,inits,alt)    \
  do { SCM fu = fu_;                                            \
    body = CAR (fu); fu = CDR (fu);                             \
                                                                \
    rest = kw = alt = SCM_BOOL_F;                               \
    inits = SCM_EOL;                                            \
    nopt = 0;                                                   \
                                                                \
    nreq = SCM_I_INUM (CAR (fu)); fu = CDR (fu);                \
    if (scm_is_pair (fu))                                       \
      {                                                         \
        rest = CAR (fu); fu = CDR (fu);                         \
        if (scm_is_pair (fu))                                   \
          {                                                     \
            nopt = SCM_I_INUM (CAR (fu)); fu = CDR (fu);        \
            kw = CAR (fu); fu = CDR (fu);                       \
            inits = CAR (fu); fu = CDR (fu);                    \
            alt = CAR (fu);                                     \
          }                                                     \
      }                                                         \
  } while (0)
static void prepare_boot_closure_env_for_apply (SCM proc, SCM args,
                                                SCM *out_body, SCM *out_env);
static void prepare_boot_closure_env_for_eval (SCM proc, unsigned int argc,
                                               SCM exps, SCM *out_body,
                                               SCM *inout_env);

#define CAR(x)   SCM_CAR(x)
#define CDR(x)   SCM_CDR(x)
#define CAAR(x)  SCM_CAAR(x)
#define CADR(x)  SCM_CADR(x)
#define CDAR(x)  SCM_CDAR(x)
#define CDDR(x)  SCM_CDDR(x)
#define CADDR(x) SCM_CADDR(x)
#define CDDDR(x) SCM_CDDDR(x)

SCM_SYMBOL (scm_unbound_variable_key, "unbound-variable");

static void error_used_before_defined (void)
{
  scm_error (scm_unbound_variable_key, NULL,
             "Variable used before given a value", SCM_EOL, SCM_BOOL_F);
}

static void error_invalid_keyword (SCM proc)
{
  scm_error_scm (scm_from_locale_symbol ("keyword-argument-error"), proc,
                 scm_from_locale_string ("Invalid keyword"), SCM_EOL,
                 SCM_BOOL_F);
}

static void error_unrecognized_keyword (SCM proc)
{
  scm_error_scm (scm_from_locale_symbol ("keyword-argument-error"), proc,
                 scm_from_locale_string ("Unrecognized keyword"), SCM_EOL,
                 SCM_BOOL_F);
}

/* the environment:
   (VAL ... . MOD)
   If MOD is #f, it means the environment was captured before modules were
   booted.
   If MOD is the literal value '(), we are evaluating at the top level, and so
   should track changes to the current module. You have to be careful in this
   case, because further lexical contours should capture the current module.
*/
#define CAPTURE_ENV(env)                                        \
  ((env == SCM_EOL) ? scm_current_module () :                   \
   ((env == SCM_BOOL_F) ? scm_the_root_module () : env))

static SCM
eval (SCM x, SCM env)
{
  SCM mx;
  SCM proc = SCM_UNDEFINED, args = SCM_EOL;
  unsigned int argc;

 loop:
  SCM_TICK;
  if (!SCM_MEMOIZED_P (x))
    abort ();

  mx = SCM_MEMOIZED_ARGS (x);
  switch (SCM_MEMOIZED_TAG (x))
    {
    case SCM_M_BEGIN:
      for (; !scm_is_null (CDR (mx)); mx = CDR (mx))
        eval (CAR (mx), env);
      x = CAR (mx);
      goto loop;

    case SCM_M_IF:
      if (scm_is_true (eval (CAR (mx), env)))
        x = CADR (mx);
      else
        x = CDDR (mx);
      goto loop;

    case SCM_M_LET:
      {
        SCM inits = CAR (mx);
        SCM new_env = CAPTURE_ENV (env);
        for (; scm_is_pair (inits); inits = CDR (inits))
          new_env = scm_cons (eval (CAR (inits), env), new_env);
        env = new_env;
        x = CDR (mx);
        goto loop;
      }

    case SCM_M_LAMBDA:
      RETURN_BOOT_CLOSURE (mx, CAPTURE_ENV (env));

    case SCM_M_QUOTE:
      return mx;

    case SCM_M_DEFINE:
      scm_define (CAR (mx), eval (CDR (mx), env));
      return SCM_UNSPECIFIED;

    case SCM_M_DYNWIND:
      {
        SCM in, out, res, old_winds;
        in = eval (CAR (mx), env);
        out = eval (CDDR (mx), env);
        scm_call_0 (in);
        old_winds = scm_i_dynwinds ();
        scm_i_set_dynwinds (scm_acons (in, out, old_winds));
        res = eval (CADR (mx), env);
        scm_i_set_dynwinds (old_winds);
        scm_call_0 (out);
        return res;
      }

    case SCM_M_WITH_FLUIDS:
      {
        long i, len;
        SCM *fluidv, *valuesv, walk, wf, res;
        len = scm_ilength (CAR (mx));
        fluidv = alloca (sizeof (SCM)*len);
        for (i = 0, walk = CAR (mx); i < len; i++, walk = CDR (walk))
          fluidv[i] = eval (CAR (walk), env);
        valuesv = alloca (sizeof (SCM)*len);
        for (i = 0, walk = CADR (mx); i < len; i++, walk = CDR (walk))
          valuesv[i] = eval (CAR (walk), env);

        wf = scm_i_make_with_fluids (len, fluidv, valuesv);
        scm_i_swap_with_fluids (wf, SCM_I_CURRENT_THREAD->dynamic_state);
        scm_i_set_dynwinds (scm_cons (wf, scm_i_dynwinds ()));
        res = eval (CDDR (mx), env);
        scm_i_swap_with_fluids (wf, SCM_I_CURRENT_THREAD->dynamic_state);
        scm_i_set_dynwinds (CDR (scm_i_dynwinds ()));

        return res;
      }

    case SCM_M_APPLY:
      /* Evaluate the procedure to be applied.  */
      proc = eval (CAR (mx), env);
      /* Evaluate the argument holding the list of arguments */
      args = eval (CADR (mx), env);

    apply_proc:
      /* Go here to tail-apply a procedure.  PROC is the procedure and
       * ARGS is the list of arguments. */
      if (BOOT_CLOSURE_P (proc))
        {
          prepare_boot_closure_env_for_apply (proc, args, &x, &env);
          goto loop;
        }
      else
        return scm_vm_apply (scm_the_vm (), proc, args);

    case SCM_M_CALL:
      /* Evaluate the procedure to be applied.  */
      proc = eval (CAR (mx), env);
      argc = SCM_I_INUM (CADR (mx));
      mx = CDDR (mx);

      if (BOOT_CLOSURE_P (proc))
        {
          prepare_boot_closure_env_for_eval (proc, argc, mx, &x, &env);
          goto loop;
        }
      else
        {
	  SCM *argv;
	  unsigned int i;

	  argv = alloca (argc * sizeof (SCM));
	  for (i = 0; i < argc; i++, mx = CDR (mx))
	    argv[i] = eval (CAR (mx), env);

	  return scm_c_vm_run (scm_the_vm (), proc, argv, argc);
        }

    case SCM_M_CONT:
      return scm_i_call_with_current_continuation (eval (mx, env));

    case SCM_M_CALL_WITH_VALUES:
      {
        SCM producer;
        SCM v;

        producer = eval (CAR (mx), env);
        proc = eval (CDR (mx), env);  /* proc is the consumer. */
        v = scm_vm_apply (scm_the_vm (), producer, SCM_EOL);
        if (SCM_VALUESP (v))
          args = scm_struct_ref (v, SCM_INUM0);
        else
          args = scm_list_1 (v);
        goto apply_proc;
      }

    case SCM_M_LEXICAL_REF:
      {
        int n;
        SCM ret;
        for (n = SCM_I_INUM (mx); n; n--)
          env = CDR (env);
        ret = CAR (env);
        if (SCM_UNLIKELY (SCM_UNBNDP (ret)))
          /* we don't know what variable, though, because we don't have its
             name */
          error_used_before_defined ();
        return ret;
      }

    case SCM_M_LEXICAL_SET:
      {
        int n;
        SCM val = eval (CDR (mx), env);
        for (n = SCM_I_INUM (CAR (mx)); n; n--)
          env = CDR (env);
        SCM_SETCAR (env, val);
        return SCM_UNSPECIFIED;
      }

    case SCM_M_TOPLEVEL_REF:
      if (SCM_VARIABLEP (mx))
        return SCM_VARIABLE_REF (mx);
      else
        {
          while (scm_is_pair (env))
            env = CDR (env);
          return SCM_VARIABLE_REF
            (scm_memoize_variable_access_x (x, CAPTURE_ENV (env)));
        }

    case SCM_M_TOPLEVEL_SET:
      {
        SCM var = CAR (mx);
        SCM val = eval (CDR (mx), env);
        if (SCM_VARIABLEP (var))
          {
            SCM_VARIABLE_SET (var, val);
            return SCM_UNSPECIFIED;
          }
        else
          {
            while (scm_is_pair (env))
              env = CDR (env);
            SCM_VARIABLE_SET
              (scm_memoize_variable_access_x (x, CAPTURE_ENV (env)),
               val);
            return SCM_UNSPECIFIED;
          }
      }

    case SCM_M_MODULE_REF:
      if (SCM_VARIABLEP (mx))
        return SCM_VARIABLE_REF (mx);
      else
        return SCM_VARIABLE_REF
          (scm_memoize_variable_access_x (x, SCM_BOOL_F));

    case SCM_M_MODULE_SET:
      if (SCM_VARIABLEP (CDR (mx)))
        {
          SCM_VARIABLE_SET (CDR (mx), eval (CAR (mx), env));
          return SCM_UNSPECIFIED;
        }
      else
        {
          SCM_VARIABLE_SET
            (scm_memoize_variable_access_x (x, SCM_BOOL_F),
             eval (CAR (mx), env));
          return SCM_UNSPECIFIED;
        }

    case SCM_M_PROMPT:
      {
        SCM vm, prompt, handler, res;

        vm = scm_the_vm ();
        prompt = scm_c_make_prompt (eval (CAR (mx), env), SCM_VM_DATA (vm)->fp,
                                    SCM_VM_DATA (vm)->sp, SCM_VM_DATA (vm)->ip,
                                    0, -1, scm_i_dynwinds ());
        handler = eval (CDDR (mx), env);
        scm_i_set_dynwinds (scm_cons (prompt, scm_i_dynwinds ()));

        if (SCM_PROMPT_SETJMP (prompt))
          {
            /* The prompt exited nonlocally. */
            proc = handler;
            args = scm_i_prompt_pop_abort_args_x (prompt);
            goto apply_proc;
          }

        res = eval (CADR (mx), env);
        scm_i_set_dynwinds (CDR (scm_i_dynwinds ()));
        return res;
      }

    default:
      abort ();
    }
}

scm_t_option scm_eval_opts[] = {
  { SCM_OPTION_INTEGER, "stack", 22000, "Size of thread stacks (in machine words)." },
  { 0 }
};

scm_t_option scm_debug_opts[] = {
  { SCM_OPTION_BOOLEAN, "cheap", 1,
    "*This option is now obsolete.  Setting it has no effect." },
  { SCM_OPTION_BOOLEAN, "breakpoints", 0, "*Check for breakpoints." },
  { SCM_OPTION_BOOLEAN, "trace", 0, "*Trace mode." },
  { SCM_OPTION_BOOLEAN, "procnames", 1,
    "Record procedure names at definition." },
  { SCM_OPTION_BOOLEAN, "backwards", 0,
    "Display backtrace in anti-chronological order." },
  { SCM_OPTION_INTEGER, "width", 79, "Maximal width of backtrace." },
  { SCM_OPTION_INTEGER, "indent", 10, "Maximal indentation in backtrace." },
  { SCM_OPTION_INTEGER, "frames", 3,
    "Maximum number of tail-recursive frames in backtrace." },
  { SCM_OPTION_INTEGER, "maxdepth", 1000,
    "Maximal number of stored backtrace frames." },
  { SCM_OPTION_INTEGER, "depth", 20, "Maximal length of printed backtrace." },
  { SCM_OPTION_BOOLEAN, "backtrace", 0, "Show backtrace on error." },
  { SCM_OPTION_BOOLEAN, "debug", 0, "Use the debugging evaluator." },
  /* This default stack limit will be overridden by debug.c:init_stack_limit(),
     if we have getrlimit() and the stack limit is not INFINITY. But it is still
     important, as some systems have both the soft and the hard limits set to
     INFINITY; in that case we fall back to this value.

     The situation is aggravated by certain compilers, which can consume
     "beaucoup de stack", as they say in France.

     See http://thread.gmane.org/gmane.lisp.guile.devel/8599/focus=8662 for
     more discussion. This setting is 640 KB on 32-bit arches (should be enough
     for anyone!) or a whoppin' 1280 KB on 64-bit arches.
  */
  { SCM_OPTION_INTEGER, "stack", 160000, "Stack size limit (measured in words; 0 = no check)." },
  { SCM_OPTION_SCM, "show-file-name", (unsigned long)SCM_BOOL_T,
    "Show file names and line numbers "
    "in backtraces when not `#f'.  A value of `base' "
    "displays only base names, while `#t' displays full names."},
  { SCM_OPTION_BOOLEAN, "warn-deprecated", 0,
    "Warn when deprecated features are used." },
  { 0 },
};

/*
 * this ordering is awkward and illogical, but we maintain it for
 * compatibility. --hwn
 */
scm_t_option scm_evaluator_trap_table[] = {
  { SCM_OPTION_BOOLEAN, "traps", 0, "Enable evaluator traps." },
  { SCM_OPTION_BOOLEAN, "enter-frame", 0, "Trap when eval enters new frame." },
  { SCM_OPTION_BOOLEAN, "apply-frame", 0, "Trap when entering apply." },
  { SCM_OPTION_BOOLEAN, "exit-frame", 0, "Trap when exiting eval or apply." },
  { SCM_OPTION_SCM, "enter-frame-handler", (unsigned long)SCM_BOOL_F, "Handler for enter-frame traps." },
  { SCM_OPTION_SCM, "apply-frame-handler", (unsigned long)SCM_BOOL_F, "Handler for apply-frame traps." },
  { SCM_OPTION_SCM, "exit-frame-handler", (unsigned long)SCM_BOOL_F, "Handler for exit-frame traps." },
  { SCM_OPTION_BOOLEAN, "memoize-symbol", 0, "Trap when memoizing a symbol." },
  { SCM_OPTION_SCM, "memoize-symbol-handler", (unsigned long)SCM_BOOL_F, "The handler for memoization." },
  { 0 }
};

SCM_DEFINE (scm_eval_options_interface, "eval-options-interface", 0, 1, 0,
            (SCM setting),
	    "Option interface for the evaluation options. Instead of using\n"
	    "this procedure directly, use the procedures @code{eval-enable},\n"
	    "@code{eval-disable}, @code{eval-set!} and @code{eval-options}.")
#define FUNC_NAME s_scm_eval_options_interface
{
  SCM ans;

  scm_dynwind_begin (0);
  scm_dynwind_critical_section (SCM_BOOL_F);
  ans = scm_options (setting,
		     scm_eval_opts,
		     FUNC_NAME);
  scm_dynwind_end ();

  return ans;
}
#undef FUNC_NAME

SCM_DEFINE (scm_evaluator_traps, "evaluator-traps-interface", 0, 1, 0,
            (SCM setting),
	    "Option interface for the evaluator trap options.")
#define FUNC_NAME s_scm_evaluator_traps
{
  SCM ans;

  scm_options_try (setting,
		   scm_evaluator_trap_table,
		   FUNC_NAME, 1);
  SCM_CRITICAL_SECTION_START;
  ans = scm_options (setting,
		     scm_evaluator_trap_table,
		     FUNC_NAME);

  /* njrev: same again. */
  SCM_CRITICAL_SECTION_END;
  return ans;
}
#undef FUNC_NAME

/* Simple procedure calls
 */

SCM
scm_call_0 (SCM proc)
{
  return scm_c_vm_run (scm_the_vm (), proc, NULL, 0);
}

SCM
scm_call_1 (SCM proc, SCM arg1)
{
  return scm_c_vm_run (scm_the_vm (), proc, &arg1, 1);
}

SCM
scm_call_2 (SCM proc, SCM arg1, SCM arg2)
{
  SCM args[] = { arg1, arg2 };
  return scm_c_vm_run (scm_the_vm (), proc, args, 2);
}

SCM
scm_call_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3)
{
  SCM args[] = { arg1, arg2, arg3 };
  return scm_c_vm_run (scm_the_vm (), proc, args, 3);
}

SCM
scm_call_4 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4)
{
  SCM args[] = { arg1, arg2, arg3, arg4 };
  return scm_c_vm_run (scm_the_vm (), proc, args, 4);
}

SCM
scm_call_n (SCM proc, SCM *argv, size_t nargs)
{
  return scm_c_vm_run (scm_the_vm (), proc, argv, nargs);
}

/* Simple procedure applies
 */

SCM
scm_apply_0 (SCM proc, SCM args)
{
  return scm_apply (proc, args, SCM_EOL);
}

SCM
scm_apply_1 (SCM proc, SCM arg1, SCM args)
{
  return scm_apply (proc, scm_cons (arg1, args), SCM_EOL);
}

SCM
scm_apply_2 (SCM proc, SCM arg1, SCM arg2, SCM args)
{
  return scm_apply (proc, scm_cons2 (arg1, arg2, args), SCM_EOL);
}

SCM
scm_apply_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM args)
{
  return scm_apply (proc, scm_cons (arg1, scm_cons2 (arg2, arg3, args)),
		    SCM_EOL);
}

/* This code processes the arguments to apply:

   (apply PROC ARG1 ... ARGS)

   Given a list (ARG1 ... ARGS), this function conses the ARG1
   ... arguments onto the front of ARGS, and returns the resulting
   list.  Note that ARGS is a list; thus, the argument to this
   function is a list whose last element is a list.

   Apply calls this function, and applies PROC to the elements of the
   result.  apply:nconc2last takes care of building the list of
   arguments, given (ARG1 ... ARGS).

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

SCM_DEFINE (scm_nconc2last, "apply:nconc2last", 1, 0, 0,
	    (SCM lst),
	    "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
	    "conses the @var{arg1} @dots{} arguments onto the front of\n"
	    "@var{args}, and returns the resulting list. Note that\n"
	    "@var{args} is a list; thus, the argument to this function is\n"
	    "a list whose last element is a list.\n"
	    "Note: Rather than do new consing, @code{apply:nconc2last}\n"
	    "destroys its argument, so use with care.")
#define FUNC_NAME s_scm_nconc2last
{
  SCM *lloc;
  SCM_VALIDATE_NONEMPTYLIST (1, lst);
  lloc = &lst;
  while (!scm_is_null (SCM_CDR (*lloc))) /* Perhaps should be
                                          SCM_NULL_OR_NIL_P, but not
                                          needed in 99.99% of cases,
                                          and it could seriously hurt
                                          performance. - Neil */
    lloc = SCM_CDRLOC (*lloc);
  SCM_ASSERT (scm_ilength (SCM_CAR (*lloc)) >= 0, lst, SCM_ARG1, FUNC_NAME);
  *lloc = SCM_CAR (*lloc);
  return lst;
}
#undef FUNC_NAME

/* Typechecking for multi-argument MAP and FOR-EACH.

   Verify that each element of the vector ARGV, except for the first,
   is a proper list whose length is LEN.  Attribute errors to WHO,
   and claim that the i'th element of ARGV is WHO's i+2'th argument.  */
static inline void
check_map_args (SCM argv,
		long len,
		SCM gf,
		SCM proc,
		SCM args,
		const char *who)
{
  long i;

  for (i = SCM_SIMPLE_VECTOR_LENGTH (argv) - 1; i >= 1; i--)
    {
      SCM elt = SCM_SIMPLE_VECTOR_REF (argv, i);
      long elt_len = scm_ilength (elt);

      if (elt_len < 0)
	{
	  if (gf)
	    scm_apply_generic (gf, scm_cons (proc, args));
	  else
	    scm_wrong_type_arg (who, i + 2, elt);
	}

      if (elt_len != len)
	scm_out_of_range_pos (who, elt, scm_from_long (i + 2));
    }
}

SCM_GPROC (s_map, "map", 2, 0, 1, scm_map, g_map);

/* Note: Currently, scm_map applies PROC to the argument list(s)
   sequentially, starting with the first element(s).  This is used in
   evalext.c where the Scheme procedure `map-in-order', which guarantees
   sequential behaviour, is implemented using scm_map.  If the
   behaviour changes, we need to update `map-in-order'.
*/

SCM
scm_map (SCM proc, SCM arg1, SCM args)
#define FUNC_NAME s_map
{
  long i, len;
  SCM res = SCM_EOL;
  SCM *pres = &res;

  len = scm_ilength (arg1);
  SCM_GASSERTn (len >= 0,
		g_map, scm_cons2 (proc, arg1, args), SCM_ARG2, s_map);
  SCM_VALIDATE_REST_ARGUMENT (args);
  if (scm_is_null (args))
    {
      SCM_GASSERT2 (scm_is_true (scm_procedure_p (proc)), g_map, proc, arg1, SCM_ARG1, s_map);
      while (SCM_NIMP (arg1))
	{
	  *pres = scm_list_1 (scm_call_1 (proc, SCM_CAR (arg1)));
	  pres = SCM_CDRLOC (*pres);
	  arg1 = SCM_CDR (arg1);
	}
      return res;
    }
  if (scm_is_null (SCM_CDR (args)))
    {
      SCM arg2 = SCM_CAR (args);
      int len2 = scm_ilength (arg2);
      SCM_GASSERTn (scm_is_true (scm_procedure_p (proc)), g_map,
                    scm_cons2 (proc, arg1, args), SCM_ARG1, s_map);
      SCM_GASSERTn (len2 >= 0,
		    g_map, scm_cons2 (proc, arg1, args), SCM_ARG3, s_map);
      if (len2 != len)
	SCM_OUT_OF_RANGE (3, arg2);
      while (SCM_NIMP (arg1))
	{
	  *pres = scm_list_1 (scm_call_2 (proc, SCM_CAR (arg1), SCM_CAR (arg2)));
	  pres = SCM_CDRLOC (*pres);
	  arg1 = SCM_CDR (arg1);
	  arg2 = SCM_CDR (arg2);
	}
      return res;
    }
  arg1 = scm_cons (arg1, args);
  args = scm_vector (arg1);
  check_map_args (args, len, g_map, proc, arg1, s_map);
  while (1)
    {
      arg1 = SCM_EOL;
      for (i = SCM_SIMPLE_VECTOR_LENGTH (args) - 1; i >= 0; i--)
	{
	  SCM elt = SCM_SIMPLE_VECTOR_REF (args, i);
	  if (SCM_IMP (elt))
	    return res;
	  arg1 = scm_cons (SCM_CAR (elt), arg1);
	  SCM_SIMPLE_VECTOR_SET (args, i, SCM_CDR (elt));
	}
      *pres = scm_list_1 (scm_apply (proc, arg1, SCM_EOL));
      pres = SCM_CDRLOC (*pres);
    }
}
#undef FUNC_NAME

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

SCM
scm_for_each (SCM proc, SCM arg1, SCM args)
#define FUNC_NAME s_for_each
{
  long i, len;
  len = scm_ilength (arg1);
  SCM_GASSERTn (len >= 0, g_for_each, scm_cons2 (proc, arg1, args),
		SCM_ARG2, s_for_each);
  SCM_VALIDATE_REST_ARGUMENT (args);
  if (scm_is_null (args))
    {
      SCM_GASSERT2 (scm_is_true (scm_procedure_p (proc)), g_for_each,
                    proc, arg1, SCM_ARG1, s_for_each);
      while (SCM_NIMP (arg1))
	{
	  scm_call_1 (proc, SCM_CAR (arg1));
	  arg1 = SCM_CDR (arg1);
	}
      return SCM_UNSPECIFIED;
    }
  if (scm_is_null (SCM_CDR (args)))
    {
      SCM arg2 = SCM_CAR (args);
      int len2 = scm_ilength (arg2);
      SCM_GASSERTn (scm_is_true (scm_procedure_p (proc)), g_for_each,
		    scm_cons2 (proc, arg1, args), SCM_ARG1, s_for_each);
      SCM_GASSERTn (len2 >= 0, g_for_each,
		    scm_cons2 (proc, arg1, args), SCM_ARG3, s_for_each);
      if (len2 != len)
	SCM_OUT_OF_RANGE (3, arg2);
      while (SCM_NIMP (arg1))
	{
	  scm_call_2 (proc, SCM_CAR (arg1), SCM_CAR (arg2));
	  arg1 = SCM_CDR (arg1);
	  arg2 = SCM_CDR (arg2);
	}
      return SCM_UNSPECIFIED;
    }
  arg1 = scm_cons (arg1, args);
  args = scm_vector (arg1);
  check_map_args (args, len, g_for_each, proc, arg1, s_for_each);
  while (1)
    {
      arg1 = SCM_EOL;
      for (i = SCM_SIMPLE_VECTOR_LENGTH (args) - 1; i >= 0; i--)
	{
	  SCM elt = SCM_SIMPLE_VECTOR_REF (args, i);
	  if (SCM_IMP (elt))
	    return SCM_UNSPECIFIED;
	  arg1 = scm_cons (SCM_CAR (elt), arg1);
	  SCM_SIMPLE_VECTOR_SET (args, i, SCM_CDR (elt));
	}
      scm_apply (proc, arg1, SCM_EOL);
    }
}
#undef FUNC_NAME

static SCM
scm_c_primitive_eval (SCM exp)
{
  if (!SCM_EXPANDED_P (exp))
    exp = scm_call_1 (scm_current_module_transformer (), exp);
  return eval (scm_memoize_expression (exp), SCM_EOL);
}

static SCM var_primitive_eval;
SCM
scm_primitive_eval (SCM exp)
{
  return scm_c_vm_run (scm_the_vm (), scm_variable_ref (var_primitive_eval),
                       &exp, 1);
}

/* Eval does not take the second arg optionally.  This is intentional
 * in order to be R5RS compatible, and to prepare for the new module
 * system, where we would like to make the choice of evaluation
 * environment explicit.  */

SCM_DEFINE (scm_eval, "eval", 2, 0, 0,
	    (SCM exp, SCM module_or_state),
	    "Evaluate @var{exp}, a list representing a Scheme expression,\n"
            "in the top-level environment specified by\n"
	    "@var{module_or_state}.\n"
            "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
            "@var{module_or_state} is made the current module when\n"
	    "it is a module, or the current dynamic state when it is\n"
	    "a dynamic state."
	    "Example: (eval '(+ 1 2) (interaction-environment))")
#define FUNC_NAME s_scm_eval
{
  SCM res;

  scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
  if (scm_is_dynamic_state (module_or_state))
    scm_dynwind_current_dynamic_state (module_or_state);
  else if (scm_module_system_booted_p)
    {
      SCM_VALIDATE_MODULE (2, module_or_state);
      scm_dynwind_current_module (module_or_state);
    }
  /* otherwise if the module system isn't booted, ignore the module arg */

  res = scm_primitive_eval (exp);

  scm_dynwind_end ();
  return res;
}
#undef FUNC_NAME

static SCM f_apply;

/* Apply a function to a list of arguments.

   This function is exported to the Scheme level as taking two
   required arguments and a tail argument, as if it were:
	(lambda (proc arg1 . args) ...)
   Thus, if you just have a list of arguments to pass to a procedure,
   pass the list as ARG1, and '() for ARGS.  If you have some fixed
   args, pass the first as ARG1, then cons any remaining fixed args
   onto the front of your argument list, and pass that as ARGS.  */

SCM
scm_apply (SCM proc, SCM arg1, SCM args)
{
  /* Fix things up so that args contains all args. */
  if (scm_is_null (args))
    args = arg1;
  else
    args = scm_cons_star (arg1, args);

  return scm_vm_apply (scm_the_vm (), proc, args);
}

static void
prepare_boot_closure_env_for_apply (SCM proc, SCM args,
                                    SCM *out_body, SCM *out_env)
{
  int nreq = BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc);
  SCM env = BOOT_CLOSURE_ENV (proc);

  if (BOOT_CLOSURE_IS_FIXED (proc)
      || (BOOT_CLOSURE_IS_REST (proc)
          && !BOOT_CLOSURE_HAS_REST_ARGS (proc)))
    {
      if (SCM_UNLIKELY (scm_ilength (args) != nreq))
        scm_wrong_num_args (proc);
      for (; scm_is_pair (args); args = CDR (args))
        env = scm_cons (CAR (args), env);
      *out_body = BOOT_CLOSURE_BODY (proc);
      *out_env = env;
    }
  else if (BOOT_CLOSURE_IS_REST (proc))
    {
      if (SCM_UNLIKELY (scm_ilength (args) < nreq))
        scm_wrong_num_args (proc);
      for (; nreq; nreq--, args = CDR (args))
        env = scm_cons (CAR (args), env);
      env = scm_cons (args, env);
      *out_body = BOOT_CLOSURE_BODY (proc);
      *out_env = env;
    }
  else
    {
      int i, argc, nreq, nopt;
      SCM body, rest, kw, inits, alt;
      SCM mx = BOOT_CLOSURE_CODE (proc);

    loop:
      BOOT_CLOSURE_PARSE_FULL (mx, body, nargs, rest, nopt, kw, inits, alt);

      argc = scm_ilength (args);
      if (argc < nreq)
        {
          if (scm_is_true (alt))
            {
              mx = alt;
              goto loop;
            }
          else
            scm_wrong_num_args (proc);
        }
      if (scm_is_false (kw) && argc > nreq + nopt && scm_is_false (rest))
        {
          if (scm_is_true (alt))
            {
              mx = alt;
              goto loop;
            }
          else
            scm_wrong_num_args (proc);
        }

      for (i = 0; i < nreq; i++, args = CDR (args))
        env = scm_cons (CAR (args), env);

      if (scm_is_false (kw))
        {
          /* Optional args (possibly), but no keyword args. */
          for (; i < argc && i < nreq + nopt;
               i++, args = CDR (args))
            {
              env = scm_cons (CAR (args), env);
              inits = CDR (inits);
            }

          for (; i < nreq + nopt; i++, inits = CDR (inits))
            env = scm_cons (eval (CAR (inits), env), env);

          if (scm_is_true (rest))
            env = scm_cons (args, env);
        }
      else
        {
          SCM aok;

          aok = CAR (kw);
          kw = CDR (kw);

          /* Keyword args. As before, but stop at the first keyword. */
          for (; i < argc && i < nreq + nopt && !scm_is_keyword (CAR (args));
               i++, args = CDR (args), inits = CDR (inits))
            env = scm_cons (CAR (args), env);

          for (; i < nreq + nopt; i++, inits = CDR (inits))
            env = scm_cons (eval (CAR (inits), env), env);

          if (scm_is_true (rest))
            {
              env = scm_cons (args, env);
              i++;
            }

          /* Now fill in env with unbound values, limn the rest of the args for
             keywords, and fill in unbound values with their inits. */
          {
            int imax = i - 1;
            int kw_start_idx = i;
            SCM walk, k, v;
            for (walk = kw; scm_is_pair (walk); walk = CDR (walk))
              if (SCM_I_INUM (CDAR (walk)) > imax)
                imax = SCM_I_INUM (CDAR (walk));
            for (; i <= imax; i++)
              env = scm_cons (SCM_UNDEFINED, env);

            if (scm_is_pair (args) && scm_is_pair (CDR (args)))
              for (; scm_is_pair (args) && scm_is_pair (CDR (args));
                   args = CDR (args))
                {
                  k = CAR (args); v = CADR (args);
                  if (!scm_is_keyword (k))
                    {
                      if (scm_is_true (rest))
                        continue;
                      else
                        break;
                    }
                  for (walk = kw; scm_is_pair (walk); walk = CDR (walk))
                    if (scm_is_eq (k, CAAR (walk)))
                      {
                        /* Well... ok, list-set! isn't the nicest interface, but
                           hey. */
                        int iset = imax - SCM_I_INUM (CDAR (walk));
                        scm_list_set_x (env, SCM_I_MAKINUM (iset), v);
                        args = CDR (args);
                        break;
                      }
                  if (scm_is_null (walk) && scm_is_false (aok))
                    error_unrecognized_keyword (proc);
                }
            if (scm_is_pair (args) && scm_is_false (rest))
              error_invalid_keyword (proc);

            /* Now fill in unbound values, evaluating init expressions in their
               appropriate environment. */
            for (i = imax - kw_start_idx; scm_is_pair (inits); i--, inits = CDR (inits))
              {
                SCM tail = scm_list_tail (env, SCM_I_MAKINUM (i));
                if (SCM_UNBNDP (CAR (tail)))
                  SCM_SETCAR (tail, eval (CAR (inits), CDR (tail)));
              }
          }
        }

      *out_body = body;
      *out_env = env;
    }
}

static void
prepare_boot_closure_env_for_eval (SCM proc, unsigned int argc,
                                   SCM exps, SCM *out_body, SCM *inout_env)
{
  int nreq = BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc);
  SCM new_env = BOOT_CLOSURE_ENV (proc);
  if (BOOT_CLOSURE_IS_FIXED (proc)
      || (BOOT_CLOSURE_IS_REST (proc)
          && !BOOT_CLOSURE_HAS_REST_ARGS (proc)))
    {
      for (; scm_is_pair (exps); exps = CDR (exps), nreq--)
        new_env = scm_cons (eval (CAR (exps), *inout_env), new_env);
      if (SCM_UNLIKELY (nreq != 0))
        scm_wrong_num_args (proc);
      *out_body = BOOT_CLOSURE_BODY (proc);
      *inout_env = new_env;
    }
  else if (BOOT_CLOSURE_IS_REST (proc))
    {
      if (SCM_UNLIKELY (argc < nreq))
        scm_wrong_num_args (proc);
      for (; nreq; nreq--, exps = CDR (exps))
        new_env = scm_cons (eval (CAR (exps), *inout_env), new_env);
      {
        SCM rest = SCM_EOL;
        for (; scm_is_pair (exps); exps = CDR (exps))
          rest = scm_cons (eval (CAR (exps), *inout_env), rest);
        new_env = scm_cons (scm_reverse (rest),
                            new_env);
      }
      *out_body = BOOT_CLOSURE_BODY (proc);
      *inout_env = new_env;
    }
  else
    {
      SCM args = SCM_EOL;
      for (; scm_is_pair (exps); exps = CDR (exps))
        args = scm_cons (eval (CAR (exps), *inout_env), args);
      args = scm_reverse_x (args, SCM_UNDEFINED);
      prepare_boot_closure_env_for_apply (proc, args, out_body, inout_env);
    }
}

static SCM
boot_closure_apply (SCM closure, SCM args)
{
  SCM body, env;
  prepare_boot_closure_env_for_apply (closure, args, &body, &env);
  return eval (body, env);
}

static int
boot_closure_print (SCM closure, SCM port, scm_print_state *pstate)
{
  SCM args;
  scm_puts ("#<boot-closure ", port);
  scm_uintprint ((unsigned long)SCM2PTR (closure), 16, port);
  scm_putc (' ', port);
  args = scm_make_list (scm_from_int (BOOT_CLOSURE_NUM_REQUIRED_ARGS (closure)),
                        scm_from_locale_symbol ("_"));
  if (!BOOT_CLOSURE_IS_FIXED (closure) && BOOT_CLOSURE_HAS_REST_ARGS (closure))
    args = scm_cons_star (scm_from_locale_symbol ("_"), args);
  /* FIXME: optionals and rests */
  scm_display (args, port);
  scm_putc ('>', port);
  return 1;
}

void
scm_init_eval ()
{
  SCM primitive_eval;

  scm_init_opts (scm_evaluator_traps,
		 scm_evaluator_trap_table);
  scm_init_opts (scm_eval_options_interface,
		 scm_eval_opts);

  f_apply = scm_c_define_gsubr ("apply", 2, 0, 1, scm_apply);

  scm_tc16_boot_closure = scm_make_smob_type ("boot-closure", 0);
  scm_set_smob_apply (scm_tc16_boot_closure, boot_closure_apply, 0, 0, 1);
  scm_set_smob_print (scm_tc16_boot_closure, boot_closure_print);

  primitive_eval = scm_c_make_gsubr ("primitive-eval", 1, 0, 0,
                                     scm_c_primitive_eval);
  var_primitive_eval = scm_define (SCM_SUBR_NAME (primitive_eval),
                                   primitive_eval);

#include "libguile/eval.x"
}

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


code:
/* classes: h_files */

#ifndef SCM_EVAL_H
#define SCM_EVAL_H

/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2003,2004,2008,2009,2010
 * 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 3 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"

#include "libguile/struct.h"
#include "libguile/memoize.h"

/* {Options}
 */

/* {Ilocs}
 *
 * Ilocs are relative pointers into local environment structures.
 *
 */
#define SCM_ILOCP(n)		(SCM_ITAG8(n)==scm_tc8_iloc)

/* {Evaluator}
 */

typedef SCM (*scm_t_trampoline_0) (SCM proc);
typedef SCM (*scm_t_trampoline_1) (SCM proc, SCM arg1);
typedef SCM (*scm_t_trampoline_2) (SCM proc, SCM arg1, SCM arg2);

#define SCM_EXTEND_ENV scm_acons

/*fixme* This should probably be removed throught the code. */

#define SCM_TOP_LEVEL_LOOKUP_CLOSURE (scm_current_module_lookup_closure())

SCM_API SCM scm_call_0 (SCM proc);
SCM_API SCM scm_call_1 (SCM proc, SCM arg1);
SCM_API SCM scm_call_2 (SCM proc, SCM arg1, SCM arg2);
SCM_API SCM scm_call_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3);
SCM_API SCM scm_call_4 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4);
SCM_API SCM scm_call_n (SCM proc, SCM *argv, size_t nargs);
SCM_API SCM scm_apply_0 (SCM proc, SCM args);
SCM_API SCM scm_apply_1 (SCM proc, SCM arg1, SCM args);
SCM_API SCM scm_apply_2 (SCM proc, SCM arg1, SCM arg2, SCM args);
SCM_API SCM scm_apply_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM args);
SCM_API SCM scm_nconc2last (SCM lst);
SCM_API SCM scm_apply (SCM proc, SCM arg1, SCM args);
#define scm_dapply(proc,arg1,args) scm_apply (proc, arg1, args)
SCM_API SCM scm_map (SCM proc, SCM arg1, SCM args);
SCM_API SCM scm_for_each (SCM proc, SCM arg1, SCM args);
SCM_API SCM scm_primitive_eval (SCM exp);
#define scm_primitive_eval_x(exp) scm_primitive_eval (exp)
SCM_API SCM scm_eval (SCM exp, SCM module);
#define scm_eval_x(exp, module) scm_eval (exp, module)

SCM_INTERNAL void scm_init_eval (void);

#endif  /* SCM_EVAL_H */

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


code:
/* Copyright (C) 1998,1999,2000,2001,2002,2003, 2006, 2008, 2009, 2010 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 3 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/eval.h"
#include "libguile/fluids.h"
#include "libguile/modules.h"

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

SCM_DEFINE (scm_defined_p, "defined?", 1, 1, 0,
            (SCM sym, SCM module),
	    "Return @code{#t} if @var{sym} is defined in the module "
	    "@var{module} or the current module when @var{module} is not"
	    "specified.")
#define FUNC_NAME s_scm_defined_p
{
  SCM var;

  SCM_VALIDATE_SYMBOL (1, sym);

  if (SCM_UNBNDP (module))
    module = scm_current_module ();
  else
    SCM_VALIDATE_MODULE (2, module);

  var = scm_module_variable (module, sym);

  return (scm_is_false (var) || SCM_UNBNDP (SCM_VARIABLE_REF (var))
	  ? SCM_BOOL_F
	  : SCM_BOOL_T);
}
#undef FUNC_NAME

SCM_REGISTER_PROC (s_map_in_order, "map-in-order", 2, 0, 1, scm_map);

SCM_DEFINE (scm_self_evaluating_p, "self-evaluating?", 1, 0, 0,
	    (SCM obj),
	    "Return #t for objects which Guile considers self-evaluating")
#define FUNC_NAME s_scm_self_evaluating_p
{
  switch (SCM_ITAG3 (obj))
    {
    case scm_tc3_int_1:
    case scm_tc3_int_2:
      /* inum */
      return SCM_BOOL_T;
    case scm_tc3_imm24:
	/* characters, booleans, other immediates */
      return scm_from_bool (!scm_is_null_and_not_nil (obj));
    case scm_tc3_cons:
      switch (SCM_TYP7 (obj))
	{
	case scm_tc7_vector:
	case scm_tc7_wvect:
	case scm_tc7_pointer:
	case scm_tc7_hashtable:
	case scm_tc7_fluid:
	case scm_tc7_dynamic_state:
        case scm_tc7_frame:
        case scm_tc7_objcode:
        case scm_tc7_vm:
        case scm_tc7_vm_cont:
	case scm_tc7_number:
	case scm_tc7_string:
	case scm_tc7_smob:
	case scm_tc7_program:
	case scm_tc7_bytevector:
	case scm_tcs_struct:
	  return SCM_BOOL_T;
	default:
	  return SCM_BOOL_F;
	}
    }
  SCM_MISC_ERROR ("Internal error: Object ~S has unknown type",
		  scm_list_1 (obj));
  return SCM_UNSPECIFIED; /* never reached */
}
#undef FUNC_NAME

void
scm_init_evalext ()
{
#include "libguile/evalext.x"
}

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


code:
/* classes: h_files */

#ifndef SCM_EVALEXT_H
#define SCM_EVALEXT_H

/* Copyright (C) 1998,1999,2000, 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 3 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_defined_p (SCM sym, SCM env);
SCM_API SCM scm_self_evaluating_p (SCM obj);
SCM_INTERNAL void scm_init_evalext (void);

#if (SCM_ENABLE_DEPRECATED == 1)

#define scm_definedp scm_defined_p

#endif

#endif  /* SCM_EVALEXT_H */

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