152 |
|
|
153 |
#define EXTEND_ENV SCM_EXTEND_ENV |
#define EXTEND_ENV SCM_EXTEND_ENV |
154 |
|
|
155 |
SCM_REC_CRITICAL_SECTION (source); |
SCM_REC_MUTEX (source_mutex); |
|
#define SOURCE_SECTION_START SCM_REC_CRITICAL_SECTION_START (source); |
|
|
#define SOURCE_SECTION_END SCM_REC_CRITICAL_SECTION_END (source); |
|
156 |
|
|
157 |
SCM * |
SCM * |
158 |
scm_ilookup (SCM iloc, SCM env) |
scm_ilookup (SCM iloc, SCM env) |
818 |
} |
} |
819 |
|
|
820 |
|
|
821 |
|
SCM_SYNTAX (s_future, "future", scm_makmmacro, scm_m_future); |
822 |
|
SCM_GLOBAL_SYMBOL (scm_sym_future, s_future); |
823 |
|
|
824 |
|
/* Like promises, futures are implemented as closures with an empty |
825 |
|
* parameter list. Thus, (future <expression>) is transformed into |
826 |
|
* (#@future '() <expression>), where the empty list represents the |
827 |
|
* empty parameter list. This representation allows for easy creation |
828 |
|
* of the closure during evaluation. */ |
829 |
|
SCM |
830 |
|
scm_m_future (SCM xorig, SCM env SCM_UNUSED) |
831 |
|
{ |
832 |
|
SCM_ASSYNT (scm_ilength (xorig) == 2, scm_s_expression, s_future); |
833 |
|
return scm_cons2 (SCM_IM_FUTURE, SCM_EOL, SCM_CDR (xorig)); |
834 |
|
} |
835 |
|
|
836 |
|
|
837 |
SCM_SYNTAX(s_define, "define", scm_makmmacro, scm_m_define); |
SCM_SYNTAX(s_define, "define", scm_makmmacro, scm_m_define); |
838 |
SCM_GLOBAL_SYMBOL(scm_sym_define, s_define); |
SCM_GLOBAL_SYMBOL(scm_sym_define, s_define); |
839 |
|
|
1490 |
ls = z = scm_cons (scm_sym_delay, SCM_UNSPECIFIED); |
ls = z = scm_cons (scm_sym_delay, SCM_UNSPECIFIED); |
1491 |
x = SCM_CDR (x); |
x = SCM_CDR (x); |
1492 |
goto loop; |
goto loop; |
1493 |
|
case (SCM_ISYMNUM (SCM_IM_FUTURE)): |
1494 |
|
ls = z = scm_cons (scm_sym_delay, SCM_UNSPECIFIED); |
1495 |
|
x = SCM_CDR (x); |
1496 |
|
goto loop; |
1497 |
case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES)): |
case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES)): |
1498 |
ls = z = scm_cons (scm_sym_at_call_with_values, SCM_UNSPECIFIED); |
ls = z = scm_cons (scm_sym_at_call_with_values, SCM_UNSPECIFIED); |
1499 |
goto loop; |
goto loop; |
1602 |
{ |
{ |
1603 |
if (SCM_ISYMP (SCM_CAR (code))) |
if (SCM_ISYMP (SCM_CAR (code))) |
1604 |
{ |
{ |
1605 |
SOURCE_SECTION_START; |
scm_rec_mutex_lock (&source_mutex); |
1606 |
/* check for race condition */ |
/* check for race condition */ |
1607 |
if (SCM_ISYMP (SCM_CAR (code))) |
if (SCM_ISYMP (SCM_CAR (code))) |
1608 |
code = scm_m_expand_body (code, env); |
code = scm_m_expand_body (code, env); |
1609 |
SOURCE_SECTION_END; |
scm_rec_mutex_unlock (&source_mutex); |
1610 |
goto again; |
goto again; |
1611 |
} |
} |
1612 |
} |
} |
2005 |
{ |
{ |
2006 |
if (SCM_ISYMP (form)) |
if (SCM_ISYMP (form)) |
2007 |
{ |
{ |
2008 |
SOURCE_SECTION_START; |
scm_rec_mutex_lock (&source_mutex); |
2009 |
/* check for race condition */ |
/* check for race condition */ |
2010 |
if (SCM_ISYMP (SCM_CAR (x))) |
if (SCM_ISYMP (SCM_CAR (x))) |
2011 |
x = scm_m_expand_body (x, env); |
x = scm_m_expand_body (x, env); |
2012 |
SOURCE_SECTION_END; |
scm_rec_mutex_unlock (&source_mutex); |
2013 |
goto nontoplevel_begin; |
goto nontoplevel_begin; |
2014 |
} |
} |
2015 |
else |
else |
2391 |
RETURN (scm_makprom (scm_closure (SCM_CDR (x), env))); |
RETURN (scm_makprom (scm_closure (SCM_CDR (x), env))); |
2392 |
|
|
2393 |
|
|
2394 |
|
case (SCM_ISYMNUM (SCM_IM_FUTURE)): |
2395 |
|
RETURN (scm_i_make_future (scm_closure (SCM_CDR (x), env))); |
2396 |
|
|
2397 |
|
|
2398 |
case (SCM_ISYMNUM (SCM_IM_DISPATCH)): |
case (SCM_ISYMNUM (SCM_IM_DISPATCH)): |
2399 |
{ |
{ |
2400 |
/* If not done yet, evaluate the operand forms. The result is a |
/* If not done yet, evaluate the operand forms. The result is a |
3668 |
{ |
{ |
3669 |
if (SCM_ISYMP (SCM_CAR (proc))) |
if (SCM_ISYMP (SCM_CAR (proc))) |
3670 |
{ |
{ |
3671 |
SOURCE_SECTION_START; |
scm_rec_mutex_lock (&source_mutex); |
3672 |
/* check for race condition */ |
/* check for race condition */ |
3673 |
if (SCM_ISYMP (SCM_CAR (proc))) |
if (SCM_ISYMP (SCM_CAR (proc))) |
3674 |
proc = scm_m_expand_body (proc, args); |
proc = scm_m_expand_body (proc, args); |
3675 |
SOURCE_SECTION_END; |
scm_rec_mutex_unlock (&source_mutex); |
3676 |
goto again; |
goto again; |
3677 |
} |
} |
3678 |
else |
else |
4161 |
SCM |
SCM |
4162 |
scm_makprom (SCM code) |
scm_makprom (SCM code) |
4163 |
{ |
{ |
4164 |
SCM_RETURN_NEWSMOB (scm_tc16_promise, SCM_UNPACK (code)); |
SCM_RETURN_NEWSMOB2 (scm_tc16_promise, |
4165 |
|
SCM_UNPACK (code), |
4166 |
|
scm_make_rec_mutex ()); |
4167 |
} |
} |
4168 |
|
|
4169 |
|
static size_t |
4170 |
|
promise_free (SCM promise) |
4171 |
|
{ |
4172 |
|
scm_rec_mutex_free (SCM_PROMISE_MUTEX (promise)); |
4173 |
|
return 0; |
4174 |
|
} |
4175 |
|
|
4176 |
static int |
static int |
4177 |
promise_print (SCM exp, SCM port, scm_print_state *pstate) |
promise_print (SCM exp, SCM port, scm_print_state *pstate) |
4179 |
int writingp = SCM_WRITINGP (pstate); |
int writingp = SCM_WRITINGP (pstate); |
4180 |
scm_puts ("#<promise ", port); |
scm_puts ("#<promise ", port); |
4181 |
SCM_SET_WRITINGP (pstate, 1); |
SCM_SET_WRITINGP (pstate, 1); |
4182 |
scm_iprin1 (SCM_CELL_OBJECT_1 (exp), port, pstate); |
scm_iprin1 (SCM_PROMISE_DATA (exp), port, pstate); |
4183 |
SCM_SET_WRITINGP (pstate, writingp); |
SCM_SET_WRITINGP (pstate, writingp); |
4184 |
scm_putc ('>', port); |
scm_putc ('>', port); |
4185 |
return !0; |
return !0; |
4186 |
} |
} |
4187 |
|
|
|
|
|
4188 |
SCM_DEFINE (scm_force, "force", 1, 0, 0, |
SCM_DEFINE (scm_force, "force", 1, 0, 0, |
4189 |
(SCM x), |
(SCM promise), |
4190 |
"If the promise @var{x} has not been computed yet, compute and\n" |
"If the promise @var{x} has not been computed yet, compute and\n" |
4191 |
"return @var{x}, otherwise just return the previously computed\n" |
"return @var{x}, otherwise just return the previously computed\n" |
4192 |
"value.") |
"value.") |
4193 |
#define FUNC_NAME s_scm_force |
#define FUNC_NAME s_scm_force |
4194 |
{ |
{ |
4195 |
SCM_VALIDATE_SMOB (1, x, promise); |
SCM_VALIDATE_SMOB (1, promise, promise); |
4196 |
if (!((1L << 16) & SCM_CELL_WORD_0 (x))) |
scm_rec_mutex_lock (SCM_PROMISE_MUTEX (promise)); |
4197 |
|
if (!SCM_PROMISE_COMPUTED_P (promise)) |
4198 |
{ |
{ |
4199 |
SCM ans = scm_call_0 (SCM_CELL_OBJECT_1 (x)); |
SCM ans = scm_call_0 (SCM_PROMISE_DATA (promise)); |
4200 |
if (!((1L << 16) & SCM_CELL_WORD_0 (x))) |
if (!SCM_PROMISE_COMPUTED_P (promise)) |
4201 |
{ |
{ |
4202 |
SCM_DEFER_INTS; |
SCM_SET_PROMISE_DATA (promise, ans); |
4203 |
SCM_SET_CELL_OBJECT_1 (x, ans); |
SCM_SET_PROMISE_COMPUTED (promise); |
|
SCM_SET_CELL_WORD_0 (x, SCM_CELL_WORD_0 (x) | (1L << 16)); |
|
|
SCM_ALLOW_INTS; |
|
4204 |
} |
} |
4205 |
} |
} |
4206 |
return SCM_CELL_OBJECT_1 (x); |
scm_rec_mutex_unlock (SCM_PROMISE_MUTEX (promise)); |
4207 |
|
return SCM_PROMISE_DATA (promise); |
4208 |
} |
} |
4209 |
#undef FUNC_NAME |
#undef FUNC_NAME |
4210 |
|
|
4441 |
|
|
4442 |
scm_tc16_promise = scm_make_smob_type ("promise", 0); |
scm_tc16_promise = scm_make_smob_type ("promise", 0); |
4443 |
scm_set_smob_mark (scm_tc16_promise, scm_markcdr); |
scm_set_smob_mark (scm_tc16_promise, scm_markcdr); |
4444 |
|
scm_set_smob_free (scm_tc16_promise, promise_free); |
4445 |
scm_set_smob_print (scm_tc16_promise, promise_print); |
scm_set_smob_print (scm_tc16_promise, promise_print); |
4446 |
|
|
4447 |
/* Dirk:Fixme:: make scm_undefineds local to eval.c: it's only used here. */ |
/* Dirk:Fixme:: make scm_undefineds local to eval.c: it's only used here. */ |