summaryrefslogtreecommitdiff
path: root/libguile/eval.c
diff options
context:
space:
mode:
Diffstat (limited to 'libguile/eval.c')
-rw-r--r--libguile/eval.c75
1 files changed, 52 insertions, 23 deletions
diff --git a/libguile/eval.c b/libguile/eval.c
index 8ba26f293..ac3877e3a 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -152,9 +152,7 @@ char *alloca ();
#define EXTEND_ENV SCM_EXTEND_ENV
-SCM_REC_CRITICAL_SECTION (source);
-#define SOURCE_SECTION_START SCM_REC_CRITICAL_SECTION_START (source);
-#define SOURCE_SECTION_END SCM_REC_CRITICAL_SECTION_END (source);
+SCM_REC_MUTEX (source_mutex);
SCM *
scm_ilookup (SCM iloc, SCM env)
@@ -820,6 +818,22 @@ scm_m_delay (SCM xorig, SCM env SCM_UNUSED)
}
+SCM_SYNTAX (s_future, "future", scm_makmmacro, scm_m_future);
+SCM_GLOBAL_SYMBOL (scm_sym_future, s_future);
+
+/* Like promises, futures are implemented as closures with an empty
+ * parameter list. Thus, (future <expression>) is transformed into
+ * (#@future '() <expression>), where the empty list represents the
+ * empty parameter list. This representation allows for easy creation
+ * of the closure during evaluation. */
+SCM
+scm_m_future (SCM xorig, SCM env SCM_UNUSED)
+{
+ SCM_ASSYNT (scm_ilength (xorig) == 2, scm_s_expression, s_future);
+ return scm_cons2 (SCM_IM_FUTURE, SCM_EOL, SCM_CDR (xorig));
+}
+
+
SCM_SYNTAX(s_define, "define", scm_makmmacro, scm_m_define);
SCM_GLOBAL_SYMBOL(scm_sym_define, s_define);
@@ -1476,6 +1490,10 @@ unmemocopy (SCM x, SCM env)
ls = z = scm_cons (scm_sym_delay, SCM_UNSPECIFIED);
x = SCM_CDR (x);
goto loop;
+ case (SCM_ISYMNUM (SCM_IM_FUTURE)):
+ ls = z = scm_cons (scm_sym_delay, SCM_UNSPECIFIED);
+ x = SCM_CDR (x);
+ goto loop;
case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES)):
ls = z = scm_cons (scm_sym_at_call_with_values, SCM_UNSPECIFIED);
goto loop;
@@ -1584,11 +1602,11 @@ scm_eval_body (SCM code, SCM env)
{
if (SCM_ISYMP (SCM_CAR (code)))
{
- SOURCE_SECTION_START;
+ scm_rec_mutex_lock (&source_mutex);
/* check for race condition */
if (SCM_ISYMP (SCM_CAR (code)))
code = scm_m_expand_body (code, env);
- SOURCE_SECTION_END;
+ scm_rec_mutex_unlock (&source_mutex);
goto again;
}
}
@@ -1987,11 +2005,11 @@ dispatch:
{
if (SCM_ISYMP (form))
{
- SOURCE_SECTION_START;
+ scm_rec_mutex_lock (&source_mutex);
/* check for race condition */
if (SCM_ISYMP (SCM_CAR (x)))
x = scm_m_expand_body (x, env);
- SOURCE_SECTION_END;
+ scm_rec_mutex_unlock (&source_mutex);
goto nontoplevel_begin;
}
else
@@ -2373,6 +2391,10 @@ dispatch:
RETURN (scm_makprom (scm_closure (SCM_CDR (x), env)));
+ case (SCM_ISYMNUM (SCM_IM_FUTURE)):
+ RETURN (scm_i_make_future (scm_closure (SCM_CDR (x), env)));
+
+
case (SCM_ISYMNUM (SCM_IM_DISPATCH)):
{
/* If not done yet, evaluate the operand forms. The result is a
@@ -3646,11 +3668,11 @@ tail:
{
if (SCM_ISYMP (SCM_CAR (proc)))
{
- SOURCE_SECTION_START;
+ scm_rec_mutex_lock (&source_mutex);
/* check for race condition */
if (SCM_ISYMP (SCM_CAR (proc)))
proc = scm_m_expand_body (proc, args);
- SOURCE_SECTION_END;
+ scm_rec_mutex_unlock (&source_mutex);
goto again;
}
else
@@ -4139,10 +4161,17 @@ scm_t_bits scm_tc16_promise;
SCM
scm_makprom (SCM code)
{
- SCM_RETURN_NEWSMOB (scm_tc16_promise, SCM_UNPACK (code));
+ SCM_RETURN_NEWSMOB2 (scm_tc16_promise,
+ SCM_UNPACK (code),
+ scm_make_rec_mutex ());
}
-
+static size_t
+promise_free (SCM promise)
+{
+ scm_rec_mutex_free (SCM_PROMISE_MUTEX (promise));
+ return 0;
+}
static int
promise_print (SCM exp, SCM port, scm_print_state *pstate)
@@ -4150,33 +4179,32 @@ promise_print (SCM exp, SCM port, scm_print_state *pstate)
int writingp = SCM_WRITINGP (pstate);
scm_puts ("#<promise ", port);
SCM_SET_WRITINGP (pstate, 1);
- scm_iprin1 (SCM_CELL_OBJECT_1 (exp), port, pstate);
+ scm_iprin1 (SCM_PROMISE_DATA (exp), port, pstate);
SCM_SET_WRITINGP (pstate, writingp);
scm_putc ('>', port);
return !0;
}
-
SCM_DEFINE (scm_force, "force", 1, 0, 0,
- (SCM x),
+ (SCM promise),
"If the promise @var{x} has not been computed yet, compute and\n"
"return @var{x}, otherwise just return the previously computed\n"
"value.")
#define FUNC_NAME s_scm_force
{
- SCM_VALIDATE_SMOB (1, x, promise);
- if (!((1L << 16) & SCM_CELL_WORD_0 (x)))
+ SCM_VALIDATE_SMOB (1, promise, promise);
+ scm_rec_mutex_lock (SCM_PROMISE_MUTEX (promise));
+ if (!SCM_PROMISE_COMPUTED_P (promise))
{
- SCM ans = scm_call_0 (SCM_CELL_OBJECT_1 (x));
- if (!((1L << 16) & SCM_CELL_WORD_0 (x)))
+ SCM ans = scm_call_0 (SCM_PROMISE_DATA (promise));
+ if (!SCM_PROMISE_COMPUTED_P (promise))
{
- SCM_DEFER_INTS;
- SCM_SET_CELL_OBJECT_1 (x, ans);
- SCM_SET_CELL_WORD_0 (x, SCM_CELL_WORD_0 (x) | (1L << 16));
- SCM_ALLOW_INTS;
+ SCM_SET_PROMISE_DATA (promise, ans);
+ SCM_SET_PROMISE_COMPUTED (promise);
}
}
- return SCM_CELL_OBJECT_1 (x);
+ scm_rec_mutex_unlock (SCM_PROMISE_MUTEX (promise));
+ return SCM_PROMISE_DATA (promise);
}
#undef FUNC_NAME
@@ -4413,6 +4441,7 @@ scm_init_eval ()
scm_tc16_promise = scm_make_smob_type ("promise", 0);
scm_set_smob_mark (scm_tc16_promise, scm_markcdr);
+ scm_set_smob_free (scm_tc16_promise, promise_free);
scm_set_smob_print (scm_tc16_promise, promise_print);
/* Dirk:Fixme:: make scm_undefineds local to eval.c: it's only used here. */