-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005
+/* 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
#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>
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
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)))))
-scm_i_pthread_mutex_t source_mutex = SCM_I_PTHREAD_RECURSIVE_MUTEX_INITIALIZER;
+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_i_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);
- scm_i_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,
{
SCM ans;
- scm_frame_begin (0);
- scm_frame_critical_section (SCM_BOOL_F);
+ 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_frame_end ();
+ scm_dynwind_end ();
return ans;
}
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 */
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_i_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);
- scm_i_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));
-
- /* In order to make case 1.1 of the R5RS pitfall testsuite
- succeed, we would need to copy init_values here like
- so:
-
- init_values = scm_list_copy (init_values);
- */
- 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
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_i_set_last_debug_frame (debug.prev);
return proc;
#endif
#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_i_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);
- scm_i_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_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;
{
SCM res;
- scm_frame_begin (SCM_F_FRAME_REWINDABLE);
+ scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
if (scm_is_dynamic_state (module_or_state))
- scm_frame_current_dynamic_state (module_or_state);
+ scm_dynwind_current_dynamic_state (module_or_state);
else
- scm_frame_current_module (module_or_state);
+ scm_dynwind_current_module (module_or_state);
res = scm_primitive_eval_x (exp);
- scm_frame_end ();
+ scm_dynwind_end ();
return res;
}
{
SCM res;
- scm_frame_begin (SCM_F_FRAME_REWINDABLE);
+ scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
if (scm_is_dynamic_state (module_or_state))
- scm_frame_current_dynamic_state (module_or_state);
+ scm_dynwind_current_dynamic_state (module_or_state);
else
- scm_frame_current_module (module_or_state);
+ scm_dynwind_current_module (module_or_state);
res = scm_primitive_eval (exp);
- scm_frame_end ();
+ 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