-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
*
* 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
*/
\f
+#define _GNU_SOURCE
+
/* This file is read twice in order to produce debugging versions of ceval and
* scm_apply. These functions, deval and scm_dapply, are produced when we
* define the preprocessor macro DEVAL. The file is divided into sections
* which are treated differently with respect to DEVAL. The heads of these
* sections are marked with the string "SECTION:". */
-#define _GNU_SOURCE
-
/* SECTION: This code is compiled once.
*/
#ifndef DEVAL
-/* AIX requires this to be the first thing in the file. The #pragma
- directive is indented so pre-ANSI compilers will ignore it, rather
- than choke on it. */
-#ifndef __GNUC__
-# if HAVE_ALLOCA_H
-# include <alloca.h>
-# else
-# ifdef _AIX
-# pragma alloca
-# else
-# ifndef alloca /* predefined by HP cc +Olibcalls */
-char *alloca ();
-# endif
-# endif
+/* This blob per the Autoconf manual (under "Particular Functions"). */
+#if HAVE_ALLOCA_H
+# include <alloca.h>
+#elif defined __GNUC__
+# define alloca __builtin_alloca
+#elif defined _AIX
+# define alloca __alloca
+#elif defined _MSC_VER
+# include <malloc.h>
+# define alloca _alloca
+#else
+# include <stddef.h>
+# ifdef __cplusplus
+extern "C"
# endif
+void *alloca (size_t);
#endif
#include <assert.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/eval.h"
-#include <pthread.h>
-
\f
static SCM unmemoize_exprs (SCM expr, SCM env);
static SCM canonicalize_define (SCM expr);
static SCM *scm_lookupcar1 (SCM vloc, SCM genv, int check);
static SCM unmemoize_builtin_macro (SCM expr, SCM env);
+static void eval_letrec_inits (SCM env, SCM init_forms, SCM **init_values_eol);
\f
"offset @var{binding} and the cdr flag @var{cdrp}.")
#define FUNC_NAME s_scm_dbg_make_iloc
{
- return SCM_MAKE_ILOC (scm_to_unsigned_integer (frame, 0, SCM_IFRAME_MAX),
- scm_to_unsigned_integer (binding, 0, SCM_IDIST_MAX),
+ return SCM_MAKE_ILOC ((scm_t_bits) scm_to_unsigned_integer (frame, 0, SCM_IFRAMEMAX),
+ (scm_t_bits) scm_to_unsigned_integer (binding, 0, SCM_IDISTMAX),
scm_is_true (cdrp));
}
#undef FUNC_NAME
if (scm_ilength (res) <= 0)
res = scm_list_2 (SCM_IM_BEGIN, res);
-
- SCM_DEFER_INTS;
+
+ /* njrev: Several queries here: (1) I don't see how it can be
+ correct that the SCM_SETCAR 2 lines below this comment needs
+ protection, but the SCM_SETCAR 6 lines above does not, so
+ something here is probably wrong. (2) macroexp() is now only
+ used in one place - scm_m_generalized_set_x - whereas all other
+ macro expansion happens through expand_user_macros. Therefore
+ (2.1) perhaps macroexp() could be eliminated completely now?
+ (2.2) Does expand_user_macros need any critical section
+ protection? */
+
+ SCM_CRITICAL_SECTION_START;
SCM_SETCAR (x, SCM_CAR (res));
SCM_SETCDR (x, SCM_CDR (res));
- SCM_ALLOW_INTS;
+ SCM_CRITICAL_SECTION_END;
goto macro_tail;
}
ASSERT_SYNTAX_2 (length == 3, s_extra_expression, clause, expr);
SCM_SETCAR (SCM_CDR (clause), SCM_IM_ARROW);
}
+ /* SRFI 61 extended cond */
+ else if (length >= 3
+ && scm_is_eq (SCM_CADDR (clause), scm_sym_arrow)
+ && arrow_literal_p)
+ {
+ ASSERT_SYNTAX_2 (length > 3, s_missing_recipient, clause, expr);
+ ASSERT_SYNTAX_2 (length == 4, s_extra_expression, clause, expr);
+ SCM_SETCAR (SCM_CDDR (clause), SCM_IM_ARROW);
+ }
}
SCM_SETCAR (expr, SCM_IM_COND);
unmemoize_exprs (SCM_CDR (expr), env));
}
+#if 0
+
+/* See futures.h for a comment why futures are not enabled.
+ */
SCM_SYNTAX (s_future, "future", scm_i_makbimacro, scm_m_future);
SCM_GLOBAL_SYMBOL (scm_sym_future, s_future);
return scm_list_2 (scm_sym_future, unmemoize_expression (thunk_expr, env));
}
+#endif
SCM_SYNTAX (s_gset_x, "set!", scm_i_makbimacro, scm_m_generalized_set_x);
SCM_SYMBOL (scm_sym_setter, "setter");
case (ISYMNUM (SCM_IM_CALL_WITH_VALUES)):
return unmemoize_at_call_with_values (expr, env);
+#if 0
+ /* See futures.h for a comment why futures are not enabled.
+ */
case (ISYMNUM (SCM_IM_FUTURE)):
return unmemoize_future (expr, env);
+#endif
case (ISYMNUM (SCM_IM_SLOT_REF)):
return unmemoize_atslot_ref (expr, env);
SCM_GLOBAL_SYMBOL (scm_sym_apply_frame, "apply-frame");
SCM_GLOBAL_SYMBOL (scm_sym_exit_frame, "exit-frame");
SCM_GLOBAL_SYMBOL (scm_sym_trace, "trace");
+SCM_SYMBOL (sym_instead, "instead");
/* A function object to implement "apply" for non-closure functions. */
static SCM f_apply;
? SCM_CAR (x) \
: *scm_lookupcar ((x), (env), 1)))))
-pthread_mutex_t source_mutex = PTHREAD_RECURSIVE_MUTEX_INITIALIZER_NP;
+scm_i_pthread_mutex_t source_mutex;
/* Lookup a given local variable in an environment. The local variable is
{
if (SCM_ISYMP (SCM_CAR (code)))
{
- scm_pthread_mutex_lock (&source_mutex);
+ scm_dynwind_begin (0);
+ scm_i_dynwind_pthread_mutex_lock (&source_mutex);
/* check for race condition */
if (SCM_ISYMP (SCM_CAR (code)))
m_expand_body (code, env);
- pthread_mutex_unlock (&source_mutex);
+ scm_dynwind_end ();
goto again;
}
}
SCM tmp, tail = scm_from_bool(SCM_TRACED_FRAME_P (debug)); \
SCM_SET_TRACED_FRAME (debug); \
SCM_TRAPS_P = 0;\
- if (SCM_CHEAPTRAPS_P)\
- {\
- tmp = scm_make_debugobj (&debug);\
- scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
- }\
- else\
- {\
- int first;\
- tmp = scm_make_continuation (&first);\
- if (first)\
- scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
- }\
+ tmp = scm_make_debugobj (&debug);\
+ scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
SCM_TRAPS_P = 1;\
}\
} while (0)
scm_t_option scm_debug_opts[] = {
{ SCM_OPTION_BOOLEAN, "cheap", 1,
- "*Flyweight representation of the stack at traps." },
+ "*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,
#define FUNC_NAME s_scm_eval_options_interface
{
SCM ans;
- SCM_DEFER_INTS;
+
+ scm_dynwind_begin (0);
+ scm_dynwind_critical_section (SCM_BOOL_F);
ans = scm_options (setting,
scm_eval_opts,
SCM_N_EVAL_OPTIONS,
FUNC_NAME);
scm_eval_stack = SCM_EVAL_STACK * sizeof (void *);
- SCM_ALLOW_INTS;
+ scm_dynwind_end ();
+
return ans;
}
#undef FUNC_NAME
#define FUNC_NAME s_scm_evaluator_traps
{
SCM ans;
- SCM_DEFER_INTS;
+ SCM_CRITICAL_SECTION_START;
ans = scm_options (setting,
scm_evaluator_trap_table,
SCM_N_EVALUATOR_TRAPS,
FUNC_NAME);
+ /* njrev: same again. */
SCM_RESET_DEBUG_MODE;
- SCM_ALLOW_INTS;
+ SCM_CRITICAL_SECTION_END;
return ans;
}
#undef FUNC_NAME
return *results;
}
+static void
+eval_letrec_inits (SCM env, SCM init_forms, SCM **init_values_eol)
+{
+ SCM argv[10];
+ int i = 0, imax = sizeof (argv) / sizeof (SCM);
+
+ while (!scm_is_null (init_forms))
+ {
+ if (imax == i)
+ {
+ eval_letrec_inits (env, init_forms, init_values_eol);
+ break;
+ }
+ argv[i++] = EVALCAR (init_forms, env);
+ init_forms = SCM_CDR (init_forms);
+ }
+
+ for (i--; i >= 0; i--)
+ {
+ **init_values_eol = scm_list_1 (argv[i]);
+ *init_values_eol = SCM_CDRLOC (**init_values_eol);
+ }
+}
+
#endif /* !DEVAL */
#ifdef DEVAL
scm_t_debug_frame debug;
scm_t_debug_info *debug_info_end;
- debug.prev = scm_last_debug_frame;
+ debug.prev = scm_i_last_debug_frame ();
debug.status = 0;
/*
* The debug.vect contains twice as much scm_t_debug_info frames as the
* sizeof (scm_t_debug_info));
debug.info = debug.vect;
debug_info_end = debug.vect + scm_debug_eframe_size;
- scm_last_debug_frame = &debug;
+ scm_i_set_last_debug_frame (&debug);
#endif
#ifdef EVAL_STACK_CHECKING
if (scm_stack_checking_enabled_p && SCM_STACK_OVERFLOW_P (&proc))
SCM stackrep;
SCM tail = scm_from_bool (SCM_TAILRECP (debug));
SCM_SET_TAILREC (debug);
- if (SCM_CHEAPTRAPS_P)
- stackrep = scm_make_debugobj (&debug);
- else
- {
- int first;
- SCM val = scm_make_continuation (&first);
-
- if (first)
- stackrep = val;
- else
- {
- x = val;
- if (SCM_IMP (x))
- RETURN (x);
- else
- /* This gives the possibility for the debugger to
- modify the source expression before evaluation. */
- goto dispatch;
- }
- }
+ stackrep = scm_make_debugobj (&debug);
SCM_TRAPS_P = 0;
- scm_call_4 (SCM_ENTER_FRAME_HDLR,
- scm_sym_enter_frame,
- stackrep,
- tail,
- unmemoize_expression (x, env));
+ stackrep = scm_call_4 (SCM_ENTER_FRAME_HDLR,
+ scm_sym_enter_frame,
+ stackrep,
+ tail,
+ unmemoize_expression (x, env));
SCM_TRAPS_P = 1;
+ if (scm_is_pair (stackrep) &&
+ scm_is_eq (SCM_CAR (stackrep), sym_instead))
+ {
+ /* This gives the possibility for the debugger to modify
+ the source expression before evaluation. */
+ x = SCM_CDR (stackrep);
+ if (SCM_IMP (x))
+ RETURN (x);
+ }
}
}
#endif
{
if (SCM_ISYMP (form))
{
- scm_pthread_mutex_lock (&source_mutex);
+ scm_dynwind_begin (0);
+ scm_i_dynwind_pthread_mutex_lock (&source_mutex);
/* check for race condition */
if (SCM_ISYMP (SCM_CAR (x)))
m_expand_body (x, env);
- pthread_mutex_unlock (&source_mutex);
+ scm_dynwind_end ();
goto nontoplevel_begin;
}
else
else
{
arg1 = EVALCAR (clause, env);
- if (scm_is_true (arg1) && !SCM_NILP (arg1))
+ /* SRFI 61 extended cond */
+ if (!scm_is_null (SCM_CDR (clause))
+ && !scm_is_null (SCM_CDDR (clause))
+ && scm_is_eq (SCM_CADDR (clause), SCM_IM_ARROW))
+ {
+ SCM xx, guard_result;
+ if (SCM_VALUESP (arg1))
+ arg1 = scm_struct_ref (arg1, SCM_INUM0);
+ else
+ arg1 = scm_list_1 (arg1);
+ xx = SCM_CDR (clause);
+ proc = EVALCAR (xx, env);
+ guard_result = SCM_APPLY (proc, arg1, SCM_EOL);
+ if (scm_is_true (guard_result)
+ && !SCM_NILP (guard_result))
+ {
+ proc = SCM_CDDR (xx);
+ proc = EVALCAR (proc, env);
+ PREP_APPLY (proc, arg1);
+ goto apply_proc;
+ }
+ }
+ else if (scm_is_true (arg1) && !SCM_NILP (arg1))
{
x = SCM_CDR (clause);
if (scm_is_null (x))
x = SCM_CDR (x);
{
SCM init_forms = SCM_CAR (x);
- SCM init_values = SCM_EOL;
- do
- {
- init_values = scm_cons (EVALCAR (init_forms, env), init_values);
- init_forms = SCM_CDR (init_forms);
- }
- while (!scm_is_null (init_forms));
- SCM_SETCDR (SCM_CAR (env), init_values);
+ SCM init_values = scm_list_1 (SCM_BOOL_T);
+ SCM *init_values_eol = SCM_CDRLOC (init_values);
+ eval_letrec_inits (env, init_forms, &init_values_eol);
+ SCM_SETCDR (SCM_CAR (env), SCM_CDR (init_values));
}
x = SCM_CDR (x);
PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
case (ISYMNUM (SCM_IM_DELAY)):
RETURN (scm_makprom (scm_closure (SCM_CDR (x), env)));
-
+#if 0
+ /* See futures.h for a comment why futures are not enabled.
+ */
case (ISYMNUM (SCM_IM_FUTURE)):
RETURN (scm_i_make_future (scm_closure (SCM_CDR (x), env)));
-
+#endif
/* PLACEHOLDER for case (ISYMNUM (SCM_IM_DISPATCH)): The following
code (type_dispatch) is intended to be the tail of the case
}
scm_swap_bindings (vars, vals);
- scm_dynwinds = scm_acons (vars, vals, scm_dynwinds);
+ scm_i_set_dynwinds (scm_acons (vars, vals, scm_i_dynwinds ()));
/* Ignore all but the last evaluation result. */
for (x = SCM_CDR (x); !scm_is_null (SCM_CDR (x)); x = SCM_CDR (x))
}
proc = EVALCAR (x, env);
- scm_dynwinds = SCM_CDR (scm_dynwinds);
+ scm_i_set_dynwinds (SCM_CDR (scm_i_dynwinds ()));
scm_swap_bindings (vars, vals);
RETURN (proc);
#ifdef DEVAL
if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc)))
{
- SCM_DEFER_INTS;
+ SCM_CRITICAL_SECTION_START;
SCM_SETCAR (x, SCM_CAR (arg1));
SCM_SETCDR (x, SCM_CDR (arg1));
- SCM_ALLOW_INTS;
+ SCM_CRITICAL_SECTION_END;
goto dispatch;
}
/* Prevent memoizing of debug info expression. */
SCM_CAR (x),
SCM_CDR (x));
#endif
- SCM_DEFER_INTS;
+ SCM_CRITICAL_SECTION_START;
SCM_SETCAR (x, SCM_CAR (arg1));
SCM_SETCDR (x, SCM_CDR (arg1));
- SCM_ALLOW_INTS;
+ SCM_CRITICAL_SECTION_END;
PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
goto loop;
#if SCM_ENABLE_DEPRECATED == 1
if (SCM_EXIT_FRAME_P || (SCM_TRACE_P && SCM_TRACED_FRAME_P (debug)))
{
SCM_CLEAR_TRACED_FRAME (debug);
- if (SCM_CHEAPTRAPS_P)
- arg1 = scm_make_debugobj (&debug);
- else
- {
- int first;
- SCM val = scm_make_continuation (&first);
-
- if (first)
- arg1 = val;
- else
- {
- proc = val;
- goto ret;
- }
- }
+ arg1 = scm_make_debugobj (&debug);
SCM_TRAPS_P = 0;
- scm_call_3 (SCM_EXIT_FRAME_HDLR, scm_sym_exit_frame, arg1, proc);
+ arg1 = scm_call_3 (SCM_EXIT_FRAME_HDLR, scm_sym_exit_frame, arg1, proc);
SCM_TRAPS_P = 1;
+ if (scm_is_pair (arg1) && scm_is_eq (SCM_CAR (arg1), sym_instead))
+ proc = SCM_CDR (arg1);
}
-ret:
- scm_last_debug_frame = debug.prev;
+ scm_i_set_last_debug_frame (debug.prev);
return proc;
#endif
}
#ifdef DEVAL
scm_t_debug_frame debug;
scm_t_debug_info debug_vect_body;
- debug.prev = scm_last_debug_frame;
+ debug.prev = scm_i_last_debug_frame ();
debug.status = SCM_APPLYFRAME;
debug.vect = &debug_vect_body;
debug.vect[0].a.proc = proc;
debug.vect[0].a.args = SCM_EOL;
- scm_last_debug_frame = &debug;
+ scm_i_set_last_debug_frame (&debug);
#else
if (scm_debug_mode_p)
return scm_dapply (proc, arg1, args);
#ifdef DEVAL
if (SCM_ENTER_FRAME_P && SCM_TRAPS_P)
{
- SCM tmp;
- if (SCM_CHEAPTRAPS_P)
- tmp = scm_make_debugobj (&debug);
- else
- {
- int first;
-
- tmp = scm_make_continuation (&first);
- if (!first)
- goto entap;
- }
+ SCM tmp = scm_make_debugobj (&debug);
SCM_TRAPS_P = 0;
scm_call_2 (SCM_ENTER_FRAME_HDLR, scm_sym_enter_frame, tmp);
SCM_TRAPS_P = 1;
}
-entap:
ENTER_APPLY;
#endif
tail:
switch (SCM_TYP7 (proc))
{
case scm_tc7_subr_2o:
- args = scm_is_null (args) ? SCM_UNDEFINED : SCM_CAR (args);
+ if (SCM_UNBNDP (arg1))
+ scm_wrong_num_args (proc);
+ if (scm_is_null (args))
+ args = SCM_UNDEFINED;
+ else
+ {
+ if (! scm_is_null (SCM_CDR (args)))
+ scm_wrong_num_args (proc);
+ args = SCM_CAR (args);
+ }
RETURN (SCM_SUBRF (proc) (arg1, args));
case scm_tc7_subr_2:
if (scm_is_null (args) || !scm_is_null (SCM_CDR (args)))
{
if (SCM_ISYMP (SCM_CAR (proc)))
{
- scm_pthread_mutex_lock (&source_mutex);
+ scm_dynwind_begin (0);
+ scm_i_dynwind_pthread_mutex_lock (&source_mutex);
/* check for race condition */
if (SCM_ISYMP (SCM_CAR (proc)))
m_expand_body (proc, args);
- pthread_mutex_unlock (&source_mutex);
+ scm_dynwind_end ();
goto again;
}
else
if (SCM_EXIT_FRAME_P || (SCM_TRACE_P && SCM_TRACED_FRAME_P (debug)))
{
SCM_CLEAR_TRACED_FRAME (debug);
- if (SCM_CHEAPTRAPS_P)
- arg1 = scm_make_debugobj (&debug);
- else
- {
- int first;
- SCM val = scm_make_continuation (&first);
-
- if (first)
- arg1 = val;
- else
- {
- proc = val;
- goto ret;
- }
- }
+ arg1 = scm_make_debugobj (&debug);
SCM_TRAPS_P = 0;
- scm_call_3 (SCM_EXIT_FRAME_HDLR, scm_sym_exit_frame, arg1, proc);
+ arg1 = scm_call_3 (SCM_EXIT_FRAME_HDLR, scm_sym_exit_frame, arg1, proc);
SCM_TRAPS_P = 1;
+ if (scm_is_pair (arg1) && scm_is_eq (SCM_CAR (arg1), sym_instead))
+ proc = SCM_CDR (arg1);
}
-ret:
- scm_last_debug_frame = debug.prev;
+ scm_i_set_last_debug_frame (debug.prev);
return proc;
#endif
}
* hare-and-tortoise implementation, found several times in guile. */
struct t_trace {
- struct t_trace *trace; // These pointers form a trace along the stack.
- SCM obj; // The object handled at the respective stack frame.
+ struct t_trace *trace; /* These pointers form a trace along the stack. */
+ SCM obj; /* The object handled at the respective stack frame.*/
};
static SCM
return new_vector;
}
- else // scm_is_pair (hare->obj)
+ else /* scm_is_pair (hare->obj) */
{
SCM result;
SCM tail;
environment and calling scm_i_eval. Thus, changes to the
top-level module are tracked normally.
- - scm_eval (exp, mod)
+ - scm_eval (exp, mod_or_state)
- evaluates EXP while MOD is the current module. This is done by
- setting the current module to MOD, 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 are tracked, but these changes do not persist when
+ evaluates EXP while MOD_OR_STATE is the current module or current
+ dynamic state (as appropriate). This is done by setting the
+ current module (or dynamic state) to MOD_OR_STATE, invoking
+ scm_primitive_eval on EXP, and then restoring the current module
+ (or dynamic state) 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.
For each level of evals, there are two variants, distinguished by a
* system, where we would like to make the choice of evaluation
* environment explicit. */
-static void
-change_environment (void *data)
-{
- SCM pair = SCM_PACK (data);
- SCM new_module = SCM_CAR (pair);
- SCM old_module = scm_current_module ();
- SCM_SETCDR (pair, old_module);
- scm_set_current_module (new_module);
-}
-
-static void
-restore_environment (void *data)
-{
- SCM pair = SCM_PACK (data);
- SCM old_module = SCM_CDR (pair);
- SCM new_module = scm_current_module ();
- SCM_SETCAR (pair, new_module);
- scm_set_current_module (old_module);
-}
-
-static SCM
-inner_eval_x (void *data)
-{
- return scm_primitive_eval_x (SCM_PACK(data));
-}
-
SCM
-scm_eval_x (SCM exp, SCM module)
-#define FUNC_NAME "eval!"
+scm_eval_x (SCM exp, SCM module_or_state)
{
- SCM_VALIDATE_MODULE (2, module);
+ SCM res;
- return scm_internal_dynamic_wind
- (change_environment, inner_eval_x, restore_environment,
- (void *) SCM_UNPACK (exp),
- (void *) SCM_UNPACK (scm_cons (module, SCM_BOOL_F)));
-}
-#undef FUNC_NAME
+ scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
+ if (scm_is_dynamic_state (module_or_state))
+ scm_dynwind_current_dynamic_state (module_or_state);
+ else
+ scm_dynwind_current_module (module_or_state);
-static SCM
-inner_eval (void *data)
-{
- return scm_primitive_eval (SCM_PACK(data));
+ res = scm_primitive_eval_x (exp);
+
+ scm_dynwind_end ();
+ return res;
}
SCM_DEFINE (scm_eval, "eval", 2, 0, 0,
- (SCM exp, SCM module),
+ (SCM exp, SCM module_or_state),
"Evaluate @var{exp}, a list representing a Scheme expression,\n"
- "in the top-level environment specified by @var{module}.\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} is made the current module. The current module\n"
- "is reset to its previous value when @var{eval} returns.\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_VALIDATE_MODULE (2, module);
+ 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
+ scm_dynwind_current_module (module_or_state);
+
+ res = scm_primitive_eval (exp);
- return scm_internal_dynamic_wind
- (change_environment, inner_eval, restore_environment,
- (void *) SCM_UNPACK (exp),
- (void *) SCM_UNPACK (scm_cons (module, SCM_BOOL_F)));
+ scm_dynwind_end ();
+ return res;
}
#undef FUNC_NAME
void
scm_init_eval ()
{
+ scm_i_pthread_mutex_init (&source_mutex,
+ scm_i_pthread_mutexattr_recursive);
+
scm_init_opts (scm_evaluator_traps,
scm_evaluator_trap_table,
SCM_N_EVALUATOR_TRAPS);
HCoop / bpt / guile.git / blobdiff