mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

add with-fluids objects and primitive syntax

Browse source 
* libguile/tags.h (scm_tc7_with_fluids): Allocate a tc7 for
  "with-fluids" objects, which will only live on the dynamic stack (wind
  list), not in normal scheme-land.

* libguile/fluids.h (SCM_WITH_FLUIDS_P, SCM_WITH_FLUIDS_LEN)
  (SCM_WITH_FLUIDS_NTH_FLUID, SCM_WITH_FLUIDS_NTH_VAL)
  (SCM_WITH_FLUIDS_SET_NTH_VAL): Add some accessors.
* libguile/fluids.c (scm_i_make_with_fluids, scm_i_swap_with_fluids):
  New internal functions.
  (scm_c_with_fluids, scm_c_with_fluid): Push with-fluids objects on the
  dynwind list, not winders.

* libguile/dynwind.c (scm_i_dowinds): Add cases for winding and
  unwinding with-fluids objects.

* libguile/memoize.h (scm_sym_with_fluids, SCM_M_BEGIN): New public
  data.
* libguile/memoize.c (scm_m_with_fluids): Define with-fluids as a
  primitive syntax.
  (unmemoize): Add with-fluids case.

* libguile/eval.c (eval):
* module/ice-9/eval.scm (primitive-eval): Add with-fluids cases.

* test-suite/tests/fluids.test
  ("fluids not modified if nonfluid passed to with-fluids"): Enable a
  now-passing test.
This commit is contained in:
Andy Wingo 2010-02-18 17:10:29 +01:00
parent 27bd1deced
commit bb0229b51d
9 changed files with 206 additions and 61 deletions
Download patch file Download diff file Expand all files Collapse all files

41
libguile/memoize.c
View file

@ -201,6 +201,8 @@ scm_t_bits scm_tc16_memoized;
MAKMEMO (SCM_M_DEFINE, scm_cons (var, val))
#define MAKMEMO_DYNWIND(in, expr, out) \
MAKMEMO (SCM_M_DYNWIND, scm_cons (in, scm_cons (expr, out)))
#define MAKMEMO_WITH_FLUIDS(fluids, vals, expr) \
MAKMEMO (SCM_M_WITH_FLUIDS, scm_cons (fluids, scm_cons (vals, expr)))
#define MAKMEMO_APPLY(exp) \
MAKMEMO (SCM_M_APPLY, exp)
#define MAKMEMO_CONT(proc) \
@ -234,6 +236,7 @@ static const char *const memoized_tags[] =
"quote",
"define",
"dynwind",
"with-fluids",
"apply",
"call/cc",
"call-with-values",
@ -265,6 +268,7 @@ static SCM scm_m_at_call_with_values (SCM xorig, SCM env);
static SCM scm_m_cond (SCM xorig, SCM env);
static SCM scm_m_define (SCM x, SCM env);
static SCM scm_m_at_dynamic_wind (SCM xorig, SCM env);
static SCM scm_m_with_fluids (SCM xorig, SCM env);
static SCM scm_m_eval_when (SCM xorig, SCM env);
static SCM scm_m_if (SCM xorig, SCM env);
static SCM scm_m_lambda (SCM xorig, SCM env);
@ -401,6 +405,7 @@ SCM_SYNTAX (s_at_call_with_values, "@call-with-values", scm_m_at_call_with_value
SCM_SYNTAX (s_cond, "cond", scm_m_cond);
SCM_SYNTAX (s_define, "define", scm_m_define);
SCM_SYNTAX (s_at_dynamic_wind, "@dynamic-wind", scm_m_at_dynamic_wind);
SCM_SYNTAX (s_with_fluids, "with-fluids", scm_m_with_fluids);
SCM_SYNTAX (s_eval_when, "eval-when", scm_m_eval_when);
SCM_SYNTAX (s_if, "if", scm_m_if);
SCM_SYNTAX (s_lambda, "lambda", scm_m_lambda);
@ -425,6 +430,7 @@ SCM_GLOBAL_SYMBOL (scm_sym_case, "case");
SCM_GLOBAL_SYMBOL (scm_sym_cond, "cond");
SCM_GLOBAL_SYMBOL (scm_sym_define, "define");
SCM_GLOBAL_SYMBOL (scm_sym_at_dynamic_wind, "@dynamic-wind");
SCM_GLOBAL_SYMBOL (scm_sym_with_fluids, "with-fluids");
SCM_GLOBAL_SYMBOL (scm_sym_else, "else");
SCM_GLOBAL_SYMBOL (scm_sym_eval_when, "eval-when");
SCM_GLOBAL_SYMBOL (scm_sym_if, "if");
@ -635,6 +641,29 @@ scm_m_at_dynamic_wind (SCM expr, SCM env)
memoize (CADDDR (expr), env));
}
static SCM
scm_m_with_fluids (SCM expr, SCM env)
{
SCM binds, fluids, vals;
ASSERT_SYNTAX (scm_ilength (expr) >= 3, s_bad_expression, expr);
binds = CADR (expr);
ASSERT_SYNTAX_2 (scm_ilength (binds) >= 0, s_bad_bindings, binds, expr);
for (fluids = SCM_EOL, vals = SCM_EOL;
scm_is_pair (binds);
binds = CDR (binds))
{
SCM binding = CAR (binds);
ASSERT_SYNTAX_2 (scm_ilength (CAR (binds)) == 2, s_bad_binding,
binding, expr);
fluids = scm_cons (memoize (CAR (binding), env), fluids);
vals = scm_cons (memoize (CADR (binding), env), vals);
}
return MAKMEMO_WITH_FLUIDS (scm_reverse_x (fluids, SCM_UNDEFINED),
scm_reverse_x (vals, SCM_UNDEFINED),
memoize_sequence (CDDR (expr), env));
}
static SCM
scm_m_eval_when (SCM expr, SCM env)
{
@ -1083,6 +1112,18 @@ unmemoize (const SCM expr)
unmemoize (CAR (args)),
unmemoize (CADR (args)),
unmemoize (CDDR (args)));
case SCM_M_WITH_FLUIDS:
{
SCM binds = SCM_EOL, fluids, vals;
for (fluids = CAR (args), vals = CADR (args); scm_is_pair (fluids);
fluids = CDR (fluids), vals = CDR (vals))
binds = scm_cons (scm_list_2 (unmemoize (CAR (fluids)),
unmemoize (CAR (vals))),
binds);
return scm_list_3 (scm_sym_with_fluids,
scm_reverse_x (binds, SCM_UNDEFINED),
unmemoize (CDDR (args)));
}
case SCM_M_IF:
return scm_list_4 (scm_sym_if, unmemoize (scm_car (args)),
unmemoize (scm_cadr (args)), unmemoize (scm_cddr (args)));