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

10
libguile/dynwind.c
View file

@ -257,6 +257,11 @@ scm_i_dowinds (SCM to, long delta, void (*turn_func) (void *), void *data)
if (WINDER_REWIND_P (wind_elt))
WINDER_PROC (wind_elt) (WINDER_DATA (wind_elt));
}
else if (SCM_WITH_FLUIDS_P (wind_elt))
{
scm_i_swap_with_fluids (wind_elt,
SCM_I_CURRENT_THREAD->dynamic_state);
}
else
{
wind_key = SCM_CAR (wind_elt);
@ -294,6 +299,11 @@ scm_i_dowinds (SCM to, long delta, void (*turn_func) (void *), void *data)
if (!WINDER_REWIND_P (wind_elt))
WINDER_PROC (wind_elt) (WINDER_DATA (wind_elt));
}
else if (SCM_WITH_FLUIDS_P (wind_elt))
{
scm_i_swap_with_fluids (wind_elt,
SCM_I_CURRENT_THREAD->dynamic_state);
}
else
{
wind_key = SCM_CAR (wind_elt);

22
libguile/eval.c
View file

@ -229,6 +229,28 @@ eval (SCM x, SCM env)
return res;
}
case SCM_M_WITH_FLUIDS:
{
long i, len;
SCM *fluidv, *valuesv, walk, wf, res;
len = scm_ilength (CAR (mx));
fluidv = alloca (sizeof (SCM)*len);
for (i = 0, walk = CAR (mx); i < len; i++, walk = CDR (walk))
fluidv[i] = eval (CAR (walk), env);
valuesv = alloca (sizeof (SCM)*len);
for (i = 0, walk = CADR (mx); i < len; i++, walk = CDR (walk))
valuesv[i] = eval (CAR (walk), env);
wf = scm_i_make_with_fluids (len, fluidv, valuesv);
scm_i_swap_with_fluids (wf, SCM_I_CURRENT_THREAD->dynamic_state);
scm_i_set_dynwinds (scm_cons (wf, scm_i_dynwinds ()));
res = eval (CDDR (mx), env);
scm_i_swap_with_fluids (wf, SCM_I_CURRENT_THREAD->dynamic_state);
scm_i_set_dynwinds (CDR (scm_i_dynwinds ()));
return res;
}
case SCM_M_APPLY:
/* Evaluate the procedure to be applied. */
proc = eval (CAR (mx), env);

166
libguile/fluids.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1996,1997,2000,2001, 2004, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
/* Copyright (C) 1996,1997,2000,2001, 2004, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@ -263,53 +263,90 @@ SCM_DEFINE (scm_fluid_set_x, "fluid-set!", 2, 0, 0,
}
#undef FUNC_NAME
static void
swap_fluids (SCM data)
{
SCM fluids = SCM_CAR (data), vals = SCM_CDR (data);
while (!SCM_NULL_OR_NIL_P (fluids))
{
SCM fl = SCM_CAR (fluids);
SCM old_val = scm_fluid_ref (fl);
scm_fluid_set_x (fl, SCM_CAR (vals));
SCM_SETCAR (vals, old_val);
fluids = SCM_CDR (fluids);
vals = SCM_CDR (vals);
}
}
/* Swap the fluid values in reverse order. This is important when the
same fluid appears multiple times in the fluids list.
*/
static void
swap_fluids_reverse_aux (SCM fluids, SCM vals)
{
if (!SCM_NULL_OR_NIL_P (fluids))
{
SCM fl, old_val;
swap_fluids_reverse_aux (SCM_CDR (fluids), SCM_CDR (vals));
fl = SCM_CAR (fluids);
old_val = scm_fluid_ref (fl);
scm_fluid_set_x (fl, SCM_CAR (vals));
SCM_SETCAR (vals, old_val);
}
}
static void
swap_fluids_reverse (SCM data)
{
swap_fluids_reverse_aux (SCM_CAR (data), SCM_CDR (data));
}
static SCM
apply_thunk (void *thunk)
{
return scm_call_0 (SCM_PACK (thunk));
}
SCM
scm_i_make_with_fluids (size_t n, SCM *fluids, SCM *vals)
{
SCM ret;
/* Ensure that there are no duplicates in the fluids set -- an N^2 operation,
but N will usually be small, so perhaps that's OK. */
{
size_t i, j = n;
while (j--)
for (i = 0; i < j; i++)
if (fluids[i] == fluids[j])
{
vals[i] = vals[j]; /* later bindings win */
n--;
break;
}
}
ret = scm_words (scm_tc7_with_fluids | (n << 8), 1 + n*2);
SCM_SET_CELL_WORD_1 (ret, n);
while (n--)
{
if (SCM_UNLIKELY (!IS_FLUID (fluids[n])))
scm_wrong_type_arg ("with-fluids", 0, fluids[n]);
SCM_SET_CELL_OBJECT (ret, 1 + n * 2, fluids[n]);
SCM_SET_CELL_OBJECT (ret, 2 + n * 2, vals[n]);
}
return ret;
}
void
scm_i_swap_with_fluids (SCM wf, SCM dynstate)
{
SCM fluids;
size_t i, max = 0;
fluids = DYNAMIC_STATE_FLUIDS (dynstate);
/* We could cache the max in the with-fluids, but that would take more mem,
and we're touching all the fluids anyway, so this per-swap traversal should
be OK. */
for (i = 0; i < SCM_WITH_FLUIDS_LEN (wf); i++)
{
size_t num = FLUID_NUM (SCM_WITH_FLUIDS_NTH_FLUID (wf, i));
max = (max > num) ? max : num;
}
if (SCM_UNLIKELY (max >= SCM_SIMPLE_VECTOR_LENGTH (fluids)))
{
/* We should only get there when the current thread's dynamic state turns
out to be too small compared to the set of currently allocated
fluids. */
assert (SCM_SIMPLE_VECTOR_LENGTH (fluids) < allocated_fluids_num);
/* Lazily grow the current thread's dynamic state. */
grow_dynamic_state (dynstate);
fluids = DYNAMIC_STATE_FLUIDS (dynstate);
}
/* Bind the fluids. Order doesn't matter, as all fluids are distinct. */
for (i = 0; i < SCM_WITH_FLUIDS_LEN (wf); i++)
{
size_t fluid_num;
SCM x;
fluid_num = FLUID_NUM (SCM_WITH_FLUIDS_NTH_FLUID (wf, i));
x = SCM_SIMPLE_VECTOR_REF (fluids, fluid_num);
SCM_SIMPLE_VECTOR_SET (fluids, fluid_num,
SCM_WITH_FLUIDS_NTH_VAL (wf, i));
SCM_WITH_FLUIDS_SET_NTH_VAL (wf, i, x);
}
}
SCM_DEFINE (scm_with_fluids, "with-fluids*", 3, 0, 0,
(SCM fluids, SCM values, SCM thunk),
"Set @var{fluids} to @var{values} temporary, and call @var{thunk}.\n"
@ -327,26 +364,36 @@ SCM
scm_c_with_fluids (SCM fluids, SCM values, SCM (*cproc) (), void *cdata)
#define FUNC_NAME "scm_c_with_fluids"
{
SCM ans, data;
long flen, vlen;
SCM wf, ans;
long flen, vlen, i;
SCM *fluidsv, *valuesv;
SCM_VALIDATE_LIST_COPYLEN (1, fluids, flen);
SCM_VALIDATE_LIST_COPYLEN (2, values, vlen);
if (flen != vlen)
scm_out_of_range (s_scm_with_fluids, values);
if (flen == 1)
return scm_c_with_fluid (SCM_CAR (fluids), SCM_CAR (values),
cproc, cdata);
if (SCM_UNLIKELY (flen == 0))
return cproc (cdata);
fluidsv = alloca (sizeof(SCM)*flen);
valuesv = alloca (sizeof(SCM)*flen);
data = scm_cons (fluids, values);
scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
scm_dynwind_rewind_handler_with_scm (swap_fluids, data,
SCM_F_WIND_EXPLICITLY);
scm_dynwind_unwind_handler_with_scm (swap_fluids_reverse, data,
SCM_F_WIND_EXPLICITLY);
for (i = 0; i < flen; i++)
{
fluidsv[i] = SCM_CAR (fluids);
fluids = SCM_CDR (fluids);
valuesv[i] = SCM_CAR (values);
values = SCM_CDR (values);
}
wf = scm_i_make_with_fluids (flen, fluidsv, valuesv);
scm_i_swap_with_fluids (wf, SCM_I_CURRENT_THREAD->dynamic_state);
scm_i_set_dynwinds (scm_cons (wf, scm_i_dynwinds ()));
ans = cproc (cdata);
scm_dynwind_end ();
scm_i_swap_with_fluids (wf, SCM_I_CURRENT_THREAD->dynamic_state);
scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ()));
return ans;
}
#undef FUNC_NAME
@ -366,12 +413,15 @@ SCM
scm_c_with_fluid (SCM fluid, SCM value, SCM (*cproc) (), void *cdata)
#define FUNC_NAME "scm_c_with_fluid"
{
SCM ans;
SCM ans, wf;
scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
scm_dynwind_fluid (fluid, value);
wf = scm_i_make_with_fluids (1, &fluid, &value);
scm_i_swap_with_fluids (wf, SCM_I_CURRENT_THREAD->dynamic_state);
scm_i_set_dynwinds (scm_cons (wf, scm_i_dynwinds ()));
ans = cproc (cdata);
scm_dynwind_end ();
scm_i_swap_with_fluids (wf, SCM_I_CURRENT_THREAD->dynamic_state);
scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ()));
return ans;
}
#undef FUNC_NAME

17
libguile/fluids.h
View file

@ -3,7 +3,7 @@
#ifndef SCM_FLUIDS_H
#define SCM_FLUIDS_H
/* Copyright (C) 1996,2000,2001, 2006, 2008, 2009 Free Software Foundation, Inc.
/* Copyright (C) 1996,2000,2001, 2006, 2008, 2009, 2010 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@ -27,6 +27,18 @@
#include "libguile/root.h"
#include "libguile/vectors.h"
/* These "with-fluids" objects live on the dynamic stack, and record previous
values of fluids. Guile uses shallow binding, so the current fluid values are
always in the same place for a given thread, in the dynamic-state vector.
*/
#define SCM_WITH_FLUIDS_P(x) (!SCM_IMP (x) && SCM_TYP7(x) == scm_tc7_with_fluids)
#define SCM_WITH_FLUIDS_LEN(x) (SCM_CELL_WORD ((x), 0) >> 8)
#define SCM_WITH_FLUIDS_NTH_FLUID(x,n) (SCM_CELL_OBJECT ((x), 1 + (n)*2))
#define SCM_WITH_FLUIDS_NTH_VAL(x,n) (SCM_CELL_OBJECT ((x), 2 + (n)*2))
#define SCM_WITH_FLUIDS_SET_NTH_VAL(x,n,v) (SCM_SET_CELL_OBJECT ((x), 2 + (n)*2, (v)))
/* Fluids.
Fluids are objects of a certain type that can hold one SCM value per
@ -56,6 +68,9 @@ SCM_API SCM scm_fluid_p (SCM fl);
SCM_API SCM scm_fluid_ref (SCM fluid);
SCM_API SCM scm_fluid_set_x (SCM fluid, SCM value);
SCM_INTERNAL SCM scm_i_make_with_fluids (size_t n, SCM *fluids, SCM *vals);
SCM_INTERNAL void scm_i_swap_with_fluids (SCM with_fluids, SCM dynamic_state);
SCM_API SCM scm_c_with_fluids (SCM fluids, SCM vals,
SCM (*cproc)(void *), void *cdata);
SCM_API SCM scm_c_with_fluid (SCM fluid, SCM val,

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)));

2
libguile/memoize.h
View file

@ -44,6 +44,7 @@ SCM_API SCM scm_sym_quote;
SCM_API SCM scm_sym_quasiquote;
SCM_API SCM scm_sym_unquote;
SCM_API SCM scm_sym_uq_splicing;
SCM_API SCM scm_sym_with_fluids;
SCM_API SCM scm_sym_at;
SCM_API SCM scm_sym_atat;
@ -77,6 +78,7 @@ enum
SCM_M_QUOTE,
SCM_M_DEFINE,
SCM_M_DYNWIND,
SCM_M_WITH_FLUIDS,
SCM_M_APPLY,
SCM_M_CONT,
SCM_M_CALL_WITH_VALUES,

2
libguile/tags.h
View file

@ -422,7 +422,7 @@ typedef scm_t_uintptr scm_t_bits;
#define scm_tc7_vm_cont 71
#define scm_tc7_prompt 61
#define scm_tc7_unused_21 63
#define scm_tc7_with_fluids 63
#define scm_tc7_unused_19 69
#define scm_tc7_program 79
#define scm_tc7_unused_9 85

5
module/ice-9/eval.scm
View file

@ -304,6 +304,11 @@
(lambda () (eval exp env))
(eval out env)))
(('with-fluids (fluids vals . exp))
(let* ((fluids (map (lambda (x) (eval x env)) fluids))
(vals (map (lambda (x) (eval x env)) vals)))
(with-fluids* fluids vals (lambda () (eval exp env)))))
(('call/cc proc)
(call/cc (eval proc env)))

2
test-suite/tests/fluids.test
View file

@ -35,7 +35,7 @@
(with-fluids ((c #t))
c))
(expect-fail "fluids not modified if nonfluid passed to with-fluids"
(pass-if "fluids not modified if nonfluid passed to with-fluids"
(catch 'wrong-type-arg
(lambda ()
(with-fluids ((a #t)