X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/73be1d9e8ef3744723949752311e60d6a0f89342..7f3be1db9949b0566d3a2cb6bd9d0e84287bbb0a:/libguile/fluids.c diff --git a/libguile/fluids.c b/libguile/fluids.c index 826883e4e..327d12f4c 100644 --- a/libguile/fluids.c +++ b/libguile/fluids.c @@ -1,109 +1,205 @@ -/* Copyright (C) 1996,1997,2000,2001 Free Software Foundation, Inc. +/* Copyright (C) 1996,1997,2000,2001, 2004, 2006, 2007, 2008, 2009, 2010, + * 2011, 2012, 2013 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 as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ +#ifdef HAVE_CONFIG_H +# include +#endif +#include +#include +#include #include "libguile/_scm.h" #include "libguile/print.h" -#include "libguile/smob.h" #include "libguile/dynwind.h" #include "libguile/fluids.h" #include "libguile/alist.h" #include "libguile/eval.h" #include "libguile/ports.h" #include "libguile/deprecation.h" -#include "libguile/lang.h" - -#define INITIAL_FLUIDS 10 #include "libguile/validate.h" +#include "libguile/bdw-gc.h" -static volatile long n_fluids; -scm_t_bits scm_tc16_fluid; +/* Number of additional slots to allocate when ALLOCATED_FLUIDS is full. */ +#define FLUID_GROW 128 -SCM -scm_make_initial_fluids () -{ - return scm_c_make_vector (INITIAL_FLUIDS, SCM_BOOL_F); -} +/* Vector of allocated fluids indexed by fluid numbers. Access is protected by + FLUID_ADMIN_MUTEX. */ +static void **allocated_fluids = NULL; +static size_t allocated_fluids_len = 0; + +static scm_i_pthread_mutex_t fluid_admin_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER; + +#define IS_FLUID(x) SCM_FLUID_P (x) +#define FLUID_NUM(x) SCM_I_FLUID_NUM (x) +#define IS_DYNAMIC_STATE(x) SCM_I_DYNAMIC_STATE_P (x) +#define DYNAMIC_STATE_FLUIDS(x) SCM_I_DYNAMIC_STATE_FLUIDS (x) +#define SET_DYNAMIC_STATE_FLUIDS(x, y) SCM_SET_CELL_WORD_1 ((x), (SCM_UNPACK (y))) + + + +/* Grow STATE so that it can hold up to ALLOCATED_FLUIDS_LEN fluids. This may + be more than necessary since ALLOCATED_FLUIDS is sparse and the current + thread may not access all the fluids anyway. Memory usage could be improved + by using a 2-level array as is done in glibc for pthread keys (TODO). */ static void -grow_fluids (scm_root_state *root_state, int new_length) +grow_dynamic_state (SCM state) { - SCM old_fluids, new_fluids; - long old_length, i; + SCM new_fluids; + SCM old_fluids = DYNAMIC_STATE_FLUIDS (state); + size_t i, len, old_len = SCM_SIMPLE_VECTOR_LENGTH (old_fluids); - old_fluids = root_state->fluids; - old_length = SCM_VECTOR_LENGTH (old_fluids); - new_fluids = scm_c_make_vector (new_length, SCM_BOOL_F); - i = 0; - while (i < old_length) - { - SCM_VECTOR_SET (new_fluids, i, SCM_VELTS(old_fluids)[i]); - i++; - } - while (i < new_length) - { - SCM_VECTOR_SET (new_fluids, i, SCM_BOOL_F); - i++; - } + /* Assume the assignment below is atomic. */ + len = allocated_fluids_len; + + new_fluids = scm_c_make_vector (len, SCM_UNDEFINED); - root_state->fluids = new_fluids; + for (i = 0; i < old_len; i++) + SCM_SIMPLE_VECTOR_SET (new_fluids, i, + SCM_SIMPLE_VECTOR_REF (old_fluids, i)); + SET_DYNAMIC_STATE_FLUIDS (state, new_fluids); } void -scm_copy_fluids (scm_root_state *root_state) +scm_i_fluid_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) { - grow_fluids (root_state, SCM_VECTOR_LENGTH (root_state->fluids)); + scm_puts ("#', port); } -static int -fluid_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) +void +scm_i_dynamic_state_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) { - scm_puts ("#', port); - return 1; } -static long -next_fluid_num () +void +scm_i_with_fluids_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) { - long n; - SCM_CRITICAL_SECTION_START; - n = n_fluids++; - SCM_CRITICAL_SECTION_END; - return n; + scm_puts ("#', port); } -SCM_DEFINE (scm_make_fluid, "make-fluid", 0, 0, 0, - (), - "Return a newly created fluid.\n" - "Fluids are objects of a certain type (a smob) that can hold one SCM\n" - "value per dynamic root. That is, modifications to this value are\n" - "only visible to code that executes within the same dynamic root as\n" - "the modifying code. When a new dynamic root is constructed, it\n" - "inherits the values from its parent. Because each thread executes\n" - "in its own dynamic root, you can use fluids for thread local storage.") -#define FUNC_NAME s_scm_make_fluid + +/* Return a new fluid. */ +static SCM +new_fluid (SCM init) { - long n; + SCM fluid; + size_t trial, n; - n = next_fluid_num (); - SCM_RETURN_NEWSMOB (scm_tc16_fluid, n); + /* Fluids hold the type tag and the fluid number in the first word, + and the default value in the second word. */ + fluid = scm_cell (scm_tc7_fluid, SCM_UNPACK (init)); + SCM_SET_CELL_TYPE (fluid, scm_tc7_fluid); + + scm_dynwind_begin (0); + scm_i_dynwind_pthread_mutex_lock (&fluid_admin_mutex); + + for (trial = 0; trial < 2; trial++) + { + /* Look for a free fluid number. */ + for (n = 0; n < allocated_fluids_len; n++) + /* TODO: Use `__sync_bool_compare_and_swap' where available. */ + if (allocated_fluids[n] == NULL) + break; + + if (trial == 0 && n >= allocated_fluids_len) + /* All fluid numbers are in use. Run a GC and retry. Explicitly + running the GC is costly and bad-style. We only do this because + dynamic state fluid vectors would grow unreasonably if fluid numbers + weren't reused. */ + scm_i_gc ("fluids"); + } + + if (n >= allocated_fluids_len) + { + /* Grow the vector of allocated fluids. */ + void **new_allocated_fluids = + scm_gc_malloc_pointerless ((allocated_fluids_len + FLUID_GROW) + * sizeof (*allocated_fluids), + "allocated fluids"); + + /* Copy over old values and initialize rest. GC can not run + during these two operations since there is no safe point in + them. */ + memcpy (new_allocated_fluids, allocated_fluids, + allocated_fluids_len * sizeof (*allocated_fluids)); + memset (new_allocated_fluids + allocated_fluids_len, 0, + FLUID_GROW * sizeof (*allocated_fluids)); + n = allocated_fluids_len; + + /* Update the vector of allocated fluids. Dynamic states will + eventually be lazily grown to accomodate the new value of + ALLOCATED_FLUIDS_LEN in `fluid-ref' and `fluid-set!'. */ + allocated_fluids = new_allocated_fluids; + allocated_fluids_len += FLUID_GROW; + } + + allocated_fluids[n] = SCM2PTR (fluid); + SCM_SET_CELL_WORD_0 (fluid, (scm_tc7_fluid | (n << 8))); + + GC_GENERAL_REGISTER_DISAPPEARING_LINK (&allocated_fluids[n], + SCM2PTR (fluid)); + + scm_dynwind_end (); + + /* Now null out values. We could (and probably should) do this when + the fluid is collected instead of now. */ + scm_i_reset_fluid (n); + + return fluid; +} + +SCM +scm_make_fluid (void) +{ + return new_fluid (SCM_BOOL_F); +} + +SCM_DEFINE (scm_make_fluid_with_default, "make-fluid", 0, 1, 0, + (SCM dflt), + "Return a newly created fluid, whose initial value is @var{dflt},\n" + "or @code{#f} if @var{dflt} is not given.\n" + "Fluids are objects that can hold one\n" + "value per dynamic state. That is, modifications to this value are\n" + "only visible to code that executes with the same dynamic state as\n" + "the modifying code. When a new dynamic state is constructed, it\n" + "inherits the values from its parent. Because each thread normally executes\n" + "with its own dynamic state, you can use fluids for thread local storage.") +#define FUNC_NAME s_scm_make_fluid_with_default +{ + return new_fluid (SCM_UNBNDP (dflt) ? SCM_BOOL_F : dflt); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_make_unbound_fluid, "make-unbound-fluid", 0, 0, 0, + (), + "Make a fluid that is initially unbound.") +#define FUNC_NAME s_scm_make_unbound_fluid +{ + return new_fluid (SCM_UNDEFINED); } #undef FUNC_NAME @@ -113,10 +209,38 @@ SCM_DEFINE (scm_fluid_p, "fluid?", 1, 0, 0, "@code{#f}.") #define FUNC_NAME s_scm_fluid_p { - return SCM_BOOL(SCM_FLUIDP (obj)); + return scm_from_bool (IS_FLUID (obj)); } #undef FUNC_NAME +int +scm_is_fluid (SCM obj) +{ + return IS_FLUID (obj); +} + +/* Does not check type of `fluid'! */ +static SCM +fluid_ref (SCM fluid) +{ + SCM ret; + SCM fluids = DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD->dynamic_state); + + if (SCM_UNLIKELY (FLUID_NUM (fluid) >= SCM_SIMPLE_VECTOR_LENGTH (fluids))) + { + /* Lazily grow the current thread's dynamic state. */ + grow_dynamic_state (SCM_I_CURRENT_THREAD->dynamic_state); + + fluids = DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD->dynamic_state); + } + + ret = SCM_SIMPLE_VECTOR_REF (fluids, FLUID_NUM (fluid)); + if (SCM_UNBNDP (ret)) + return SCM_I_FLUID_DEFAULT (fluid); + else + return ret; +} + SCM_DEFINE (scm_fluid_ref, "fluid-ref", 1, 0, 0, (SCM fluid), "Return the value associated with @var{fluid} in the current\n" @@ -124,14 +248,13 @@ SCM_DEFINE (scm_fluid_ref, "fluid-ref", 1, 0, 0, "@code{#f}.") #define FUNC_NAME s_scm_fluid_ref { - unsigned long int n; - + SCM val; SCM_VALIDATE_FLUID (1, fluid); - n = SCM_FLUID_NUM (fluid); - - if (SCM_VECTOR_LENGTH (scm_root->fluids) <= n) - grow_fluids (scm_root, n+1); - return SCM_VELTS (scm_root->fluids)[n]; + val = fluid_ref (fluid); + if (SCM_UNBNDP (val)) + SCM_MISC_ERROR ("unbound fluid: ~S", + scm_list_1 (fluid)); + return val; } #undef FUNC_NAME @@ -140,50 +263,47 @@ SCM_DEFINE (scm_fluid_set_x, "fluid-set!", 2, 0, 0, "Set the value associated with @var{fluid} in the current dynamic root.") #define FUNC_NAME s_scm_fluid_set_x { - unsigned long int n; + SCM fluids = DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD->dynamic_state); SCM_VALIDATE_FLUID (1, fluid); - n = SCM_FLUID_NUM (fluid); - if (SCM_VECTOR_LENGTH (scm_root->fluids) <= n) - grow_fluids (scm_root, n+1); - SCM_VECTOR_SET (scm_root->fluids, n, value); + if (SCM_UNLIKELY (FLUID_NUM (fluid) >= SCM_SIMPLE_VECTOR_LENGTH (fluids))) + { + /* Lazily grow the current thread's dynamic state. */ + grow_dynamic_state (SCM_I_CURRENT_THREAD->dynamic_state); + + fluids = DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD->dynamic_state); + } + + SCM_SIMPLE_VECTOR_SET (fluids, FLUID_NUM (fluid), value); return SCM_UNSPECIFIED; } #undef FUNC_NAME -void -scm_swap_fluids (SCM fluids, SCM vals) +SCM_DEFINE (scm_fluid_unset_x, "fluid-unset!", 1, 0, 0, + (SCM fluid), + "Unset the value associated with @var{fluid}.") +#define FUNC_NAME s_scm_fluid_unset_x { - 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); - } + /* FIXME: really unset the default value, too? The current test + suite demands it, but I would prefer not to. */ + SCM_SET_CELL_OBJECT_1 (fluid, SCM_UNDEFINED); + return scm_fluid_set_x (fluid, SCM_UNDEFINED); } +#undef FUNC_NAME -/* Swap the fluid values in reverse order. This is important when the -same fluid appears multiple times in the fluids list. */ - -void -scm_swap_fluids_reverse (SCM fluids, SCM vals) +SCM_DEFINE (scm_fluid_bound_p, "fluid-bound?", 1, 0, 0, + (SCM fluid), + "Return @code{#t} iff @var{fluid} is bound to a value.\n" + "Throw an error if @var{fluid} is not a fluid.") +#define FUNC_NAME s_scm_fluid_bound_p { - if (!SCM_NULL_OR_NIL_P (fluids)) - { - SCM fl, old_val; - - scm_swap_fluids_reverse (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); - } + SCM val; + SCM_VALIDATE_FLUID (1, fluid); + val = fluid_ref (fluid); + return scm_from_bool (! (SCM_UNBNDP (val))); } - +#undef FUNC_NAME static SCM apply_thunk (void *thunk) @@ -191,6 +311,81 @@ 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; + + for (j = n; j--;) + for (i = j; i--;) + if (scm_is_eq (fluids[i], fluids[j])) + { + vals[i] = vals[j]; /* later bindings win */ + n--; + fluids[j] = fluids[n]; + vals[j] = vals[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))) + { + /* 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" @@ -199,7 +394,8 @@ SCM_DEFINE (scm_with_fluids, "with-fluids*", 3, 0, 0, "one after another. @var{thunk} must be a procedure with no argument.") #define FUNC_NAME s_scm_with_fluids { - return scm_c_with_fluids (fluids, values, apply_thunk, (void *) SCM_UNPACK (thunk)); + return scm_c_with_fluids (fluids, values, + apply_thunk, (void *) SCM_UNPACK (thunk)); } #undef FUNC_NAME @@ -207,37 +403,195 @@ SCM scm_c_with_fluids (SCM fluids, SCM values, SCM (*cproc) (), void *cdata) #define FUNC_NAME "scm_c_with_fluids" { - SCM ans; - 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); - scm_swap_fluids (fluids, values); - scm_dynwinds = scm_acons (fluids, values, scm_dynwinds); + if (SCM_UNLIKELY (flen == 0)) + return cproc (cdata); + + fluidsv = alloca (sizeof(SCM)*flen); + valuesv = alloca (sizeof(SCM)*flen); + + 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_dynwinds = SCM_CDR (scm_dynwinds); - scm_swap_fluids_reverse (fluids, values); + 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 +SCM_DEFINE (scm_with_fluid, "with-fluid*", 3, 0, 0, + (SCM fluid, SCM value, SCM thunk), + "Set @var{fluid} to @var{value} temporarily, and call @var{thunk}.\n" + "@var{thunk} must be a procedure with no argument.") +#define FUNC_NAME s_scm_with_fluid +{ + return scm_c_with_fluid (fluid, value, + apply_thunk, (void *) SCM_UNPACK (thunk)); +} +#undef FUNC_NAME + SCM scm_c_with_fluid (SCM fluid, SCM value, SCM (*cproc) (), void *cdata) #define FUNC_NAME "scm_c_with_fluid" { - return scm_c_with_fluids (scm_list_1 (fluid), scm_list_1 (value), - cproc, cdata); + SCM ans, wf; + + 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_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 + +static void +swap_fluid (SCM data) +{ + SCM f = SCM_CAR (data); + SCM t = fluid_ref (f); + scm_fluid_set_x (f, SCM_CDR (data)); + SCM_SETCDR (data, t); +} + +void +scm_dynwind_fluid (SCM fluid, SCM value) +{ + SCM data = scm_cons (fluid, value); + scm_dynwind_rewind_handler_with_scm (swap_fluid, data, SCM_F_WIND_EXPLICITLY); + scm_dynwind_unwind_handler_with_scm (swap_fluid, data, SCM_F_WIND_EXPLICITLY); +} + +SCM +scm_i_make_initial_dynamic_state () +{ + SCM fluids = scm_c_make_vector (allocated_fluids_len, SCM_BOOL_F); + return scm_cell (scm_tc7_dynamic_state, SCM_UNPACK (fluids)); +} + +SCM_DEFINE (scm_make_dynamic_state, "make-dynamic-state", 0, 1, 0, + (SCM parent), + "Return a copy of the dynamic state object @var{parent}\n" + "or of the current dynamic state when @var{parent} is omitted.") +#define FUNC_NAME s_scm_make_dynamic_state +{ + SCM fluids; + + if (SCM_UNBNDP (parent)) + parent = scm_current_dynamic_state (); + + SCM_ASSERT (IS_DYNAMIC_STATE (parent), parent, SCM_ARG1, FUNC_NAME); + fluids = scm_vector_copy (DYNAMIC_STATE_FLUIDS (parent)); + return scm_cell (scm_tc7_dynamic_state, SCM_UNPACK (fluids)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_dynamic_state_p, "dynamic-state?", 1, 0, 0, + (SCM obj), + "Return @code{#t} if @var{obj} is a dynamic state object;\n" + "return @code{#f} otherwise") +#define FUNC_NAME s_scm_dynamic_state_p +{ + return scm_from_bool (IS_DYNAMIC_STATE (obj)); +} +#undef FUNC_NAME + +int +scm_is_dynamic_state (SCM obj) +{ + return IS_DYNAMIC_STATE (obj); +} + +SCM_DEFINE (scm_current_dynamic_state, "current-dynamic-state", 0, 0, 0, + (), + "Return the current dynamic state object.") +#define FUNC_NAME s_scm_current_dynamic_state +{ + return SCM_I_CURRENT_THREAD->dynamic_state; } #undef FUNC_NAME +SCM_DEFINE (scm_set_current_dynamic_state, "set-current-dynamic-state", 1,0,0, + (SCM state), + "Set the current dynamic state object to @var{state}\n" + "and return the previous current dynamic state object.") +#define FUNC_NAME s_scm_set_current_dynamic_state +{ + scm_i_thread *t = SCM_I_CURRENT_THREAD; + SCM old = t->dynamic_state; + SCM_ASSERT (IS_DYNAMIC_STATE (state), state, SCM_ARG1, FUNC_NAME); + t->dynamic_state = state; + return old; +} +#undef FUNC_NAME + +static void +swap_dynamic_state (SCM loc) +{ + SCM_SETCAR (loc, scm_set_current_dynamic_state (SCM_CAR (loc))); +} + +void +scm_dynwind_current_dynamic_state (SCM state) +{ + SCM loc = scm_cons (state, SCM_EOL); + SCM_ASSERT (IS_DYNAMIC_STATE (state), state, SCM_ARG1, NULL); + scm_dynwind_rewind_handler_with_scm (swap_dynamic_state, loc, + SCM_F_WIND_EXPLICITLY); + scm_dynwind_unwind_handler_with_scm (swap_dynamic_state, loc, + SCM_F_WIND_EXPLICITLY); +} + +void * +scm_c_with_dynamic_state (SCM state, void *(*func)(void *), void *data) +{ + void *result; + scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE); + scm_dynwind_current_dynamic_state (state); + result = func (data); + scm_dynwind_end (); + return result; +} + +SCM_DEFINE (scm_with_dynamic_state, "with-dynamic-state", 2, 0, 0, + (SCM state, SCM proc), + "Call @var{proc} while @var{state} is the current dynamic\n" + "state object.") +#define FUNC_NAME s_scm_with_dynamic_state +{ + SCM result; + scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE); + scm_dynwind_current_dynamic_state (state); + result = scm_call_0 (proc); + scm_dynwind_end (); + return result; +} +#undef FUNC_NAME + + void scm_init_fluids () { - scm_tc16_fluid = scm_make_smob_type ("fluid", 0); - scm_set_smob_print (scm_tc16_fluid, fluid_print); #include "libguile/fluids.x" }