summaryrefslogtreecommitdiff
path: root/libguile/fluids.c
diff options
context:
space:
mode:
Diffstat (limited to 'libguile/fluids.c')
-rw-r--r--libguile/fluids.c691
1 files changed, 691 insertions, 0 deletions
diff --git a/libguile/fluids.c b/libguile/fluids.c
new file mode 100644
index 000000000..f62693338
--- /dev/null
+++ b/libguile/fluids.c
@@ -0,0 +1,691 @@
+/* Copyright 1996-1997,2000-2001,2004,2006-2013,2017-2018
+ Free Software Foundation, Inc.
+
+ This file is part of Guile.
+
+ Guile 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 3 of the License, or
+ (at your option) any later version.
+
+ Guile 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 Guile. If not, see
+ <https://www.gnu.org/licenses/>. */
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <stdio.h>
+#include <string.h>
+
+#include "alist.h"
+#include "atomics-internal.h"
+#include "bdw-gc.h"
+#include "cache-internal.h"
+#include "deprecation.h"
+#include "dynwind.h"
+#include "eval.h"
+#include "gsubr.h"
+#include "hashtab.h"
+#include "list.h"
+#include "pairs.h"
+#include "ports.h"
+#include "print.h"
+#include "threads.h"
+#include "variable.h"
+#include "weak-table.h"
+
+#include "fluids.h"
+
+
+/* A dynamic state associates fluids with values. There are two
+ representations of a dynamic state in Guile: the active
+ representation that is part of each thread, and a frozen
+ representation that can live in Scheme land as a value.
+
+ The active dynamic state has two parts: a locals cache, and a values
+ table. The locals cache stores fluid values that have been recently
+ referenced or set. If a value isn't in the locals cache, Guile then
+ looks for it in the values table, which is a weak-key hash table.
+ Otherwise Guile falls back to the default value of the fluid. In any
+ case, the value is recorded in the locals cache. Likewise setting a
+ fluid's value simply inserts that association into the locals cache.
+
+ The locals cache is not large, so adding an entry to it might evict
+ some other entry. In that case the entry gets flushed to the values
+ table.
+
+ The values table begins as being inherited from the parent dynamic
+ state, and represents a capture of the fluid values at a point in
+ time. A dynamic state records when its values table might be
+ referenced by other dynamic states. If it is aliased, then any
+ update to that table has to start by making a fresh local copy to
+ work on.
+
+ There are two interesting constraints on dynamic states, besides
+ speed. One is that they should hold onto their fluid-value
+ associations weakly: they shouldn't keep fluids alive indefinitely,
+ and if a fluid goes away, its value should become collectible too.
+ This is why the values table is a weak table; it makes access
+ somewhat slower, but this is mitigated by the cache. The cache
+ itself holds onto fluids and values strongly, but if there are more
+ than 8 fluids in use by a dynamic state, this won't be a problem.
+
+ The other interesting constraint is memory usage: you don't want a
+ program with M fluids and N dynamic states to consume N*M memory.
+ Guile associates each thread with a dynamic state, which itself isn't
+ that bad as there are relatively few threads in a program. The
+ problem comes in with "fibers", lightweight user-space threads that
+ can be allocated in the millions. Here you want new fibers to
+ inherit the dynamic state from the fiber that created them, but you
+ really need to limit memory overheads. For reference, in late 2016,
+ non-dynamic-state memory overhead per fiber in one user-space library
+ is around 500 bytes, in a simple "all fibers try to send a message on
+ one channel" test case.
+
+ For this reason the frozen representation of dynamic states is the
+ probably-shared values table at the end of a list of fluid-value
+ pairs, representing entries from the locals cache that differ from
+ the values table. This keeps per-dynamic-state memory usage in
+ check. A family of fibers that uses the same 3 or 4 fluids probably
+ won't ever have to allocate a new values table. Ideally the values
+ table could share more state, as in an immutable weak array-mapped
+ hash trie or something, but we don't have such a data structure. */
+
+#define FLUID_F_THREAD_LOCAL 0x100
+#define SCM_I_FLUID_THREAD_LOCAL_P(x) \
+ (SCM_CELL_WORD_0 (x) & FLUID_F_THREAD_LOCAL)
+
+static inline int
+is_dynamic_state (SCM x)
+{
+ return SCM_HAS_TYP7 (x, scm_tc7_dynamic_state);
+}
+
+static inline SCM
+get_dynamic_state (SCM dynamic_state)
+{
+ return SCM_CELL_OBJECT_1 (dynamic_state);
+}
+
+/* Precondition: It's OK to throw away any unflushed data in the current
+ cache. */
+static inline void
+restore_dynamic_state (SCM saved, scm_t_dynamic_state *state)
+{
+ int slot;
+ for (slot = SCM_CACHE_SIZE - 1; slot >= 0; slot--)
+ {
+ struct scm_cache_entry *entry = &state->cache.entries[slot];
+ if (scm_is_pair (saved))
+ {
+ entry->key = SCM_UNPACK (SCM_CAAR (saved));
+ entry->value = SCM_UNPACK (SCM_CDAR (saved));
+ saved = scm_cdr (saved);
+ }
+ else
+ entry->key = entry->value = 0;
+ }
+ state->values = saved;
+ state->has_aliased_values = 1;
+}
+
+static inline SCM
+save_dynamic_state (scm_t_dynamic_state *state)
+{
+ int slot;
+ SCM saved = state->values;
+ for (slot = 0; slot < SCM_CACHE_SIZE; slot++)
+ {
+ struct scm_cache_entry *entry = &state->cache.entries[slot];
+ SCM key = SCM_PACK (entry->key);
+ SCM value = SCM_PACK (entry->value);
+
+ if (!entry->key)
+ continue;
+ if (SCM_I_FLUID_THREAD_LOCAL_P (key))
+ {
+ /* Because we don't include unflushed thread-local fluids in
+ the result, we need to flush them to the table so that
+ restore_dynamic_state can just throw away the current
+ cache. */
+ scm_hashq_set_x (state->thread_local_values, key, value);
+ }
+ else if (!scm_is_eq (scm_weak_table_refq (state->values, key,
+ SCM_UNDEFINED),
+ value))
+ {
+ if (state->has_aliased_values)
+ saved = scm_acons (key, value, saved);
+ else
+ scm_weak_table_putq_x (state->values, key, value);
+ }
+ }
+ state->has_aliased_values = 1;
+ return saved;
+}
+
+static SCM
+saved_dynamic_state_ref (SCM saved, SCM fluid, SCM dflt)
+{
+ for (; scm_is_pair (saved); saved = SCM_CDR (saved))
+ if (scm_is_eq (SCM_CAAR (saved), fluid))
+ return SCM_CDAR (saved);
+
+ return scm_weak_table_refq (saved, fluid, dflt);
+}
+
+static SCM
+add_entry (void *data, SCM k, SCM v, SCM result)
+{
+ scm_weak_table_putq_x (result, k, v);
+ return result;
+}
+
+static SCM
+copy_value_table (SCM tab)
+{
+ SCM ret = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY);
+ return scm_c_weak_table_fold (add_entry, NULL, ret, tab);
+}
+
+
+
+
+void
+scm_i_fluid_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
+{
+ if (SCM_I_FLUID_THREAD_LOCAL_P (exp))
+ scm_puts ("#<thread-local-fluid ", port);
+ else
+ scm_puts ("#<fluid ", port);
+ scm_intprint (SCM_UNPACK (exp), 16, port);
+ scm_putc ('>', port);
+}
+
+void
+scm_i_dynamic_state_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
+{
+ scm_puts ("#<dynamic-state ", port);
+ scm_intprint (SCM_UNPACK (exp), 16, port);
+ scm_putc ('>', port);
+}
+
+
+
+
+#define SCM_I_FLUID_DEFAULT(x) (SCM_CELL_OBJECT_1 (x))
+
+static SCM
+new_fluid (SCM init, scm_t_bits flags)
+{
+ return scm_cell (scm_tc7_fluid | flags, SCM_UNPACK (init));
+}
+
+SCM
+scm_make_fluid (void)
+{
+ return new_fluid (SCM_BOOL_F, 0);
+}
+
+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, 0);
+}
+#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, 0);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_make_thread_local_fluid, "make-thread-local-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. Unlike fluids made\n"
+ "with @code{make-fluid}, thread local fluids are not captured\n"
+ "by @code{make-dynamic-state}. Similarly, a newly spawned\n"
+ "child thread does not inherit thread-local fluid values from\n"
+ "the parent thread.")
+#define FUNC_NAME s_scm_make_thread_local_fluid
+{
+ return new_fluid (SCM_UNBNDP (dflt) ? SCM_BOOL_F : dflt,
+ FLUID_F_THREAD_LOCAL);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_fluid_p, "fluid?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} iff @var{obj} is a fluid; otherwise, return\n"
+ "@code{#f}.")
+#define FUNC_NAME s_scm_fluid_p
+{
+ return scm_from_bool (SCM_FLUID_P (obj));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_fluid_thread_local_p, "fluid-thread-local?", 1, 0, 0,
+ (SCM fluid),
+ "Return @code{#t} if the fluid @var{fluid} is is thread local,\n"
+ "or @code{#f} otherwise.")
+#define FUNC_NAME s_scm_fluid_thread_local_p
+{
+ SCM_VALIDATE_FLUID (1, fluid);
+ return scm_from_bool (SCM_I_FLUID_THREAD_LOCAL_P (fluid));
+}
+#undef FUNC_NAME
+
+int
+scm_is_fluid (SCM obj)
+{
+ return SCM_FLUID_P (obj);
+}
+
+static void
+fluid_set_x (scm_t_dynamic_state *dynamic_state, SCM fluid, SCM value)
+{
+ struct scm_cache_entry *entry;
+ struct scm_cache_entry evicted = { 0, 0 };
+
+ entry = scm_cache_lookup (&dynamic_state->cache, fluid);
+ if (scm_is_eq (SCM_PACK (entry->key), fluid))
+ {
+ entry->value = SCM_UNPACK (value);
+ return;
+ }
+
+ scm_cache_insert (&dynamic_state->cache, fluid, value, &evicted);
+
+ if (evicted.key != 0)
+ {
+ fluid = SCM_PACK (evicted.key);
+ value = SCM_PACK (evicted.value);
+
+ if (SCM_I_FLUID_THREAD_LOCAL_P (fluid))
+ {
+ scm_hashq_set_x (dynamic_state->thread_local_values, fluid, value);
+ return;
+ }
+
+ if (dynamic_state->has_aliased_values)
+ {
+ if (scm_is_eq (scm_weak_table_refq (dynamic_state->values,
+ fluid, SCM_UNDEFINED),
+ value))
+ return;
+ dynamic_state->values = copy_value_table (dynamic_state->values);
+ dynamic_state->has_aliased_values = 0;
+ }
+
+ scm_weak_table_putq_x (dynamic_state->values, fluid, value);
+ }
+}
+
+/* Return value can be SCM_UNDEFINED; caller checks. */
+static SCM
+fluid_ref (scm_t_dynamic_state *dynamic_state, SCM fluid)
+{
+ SCM val;
+ struct scm_cache_entry *entry;
+
+ entry = scm_cache_lookup (&dynamic_state->cache, fluid);
+ if (scm_is_eq (SCM_PACK (entry->key), fluid))
+ val = SCM_PACK (entry->value);
+ else
+ {
+ if (SCM_I_FLUID_THREAD_LOCAL_P (fluid))
+ val = scm_hashq_ref (dynamic_state->thread_local_values, fluid,
+ SCM_UNDEFINED);
+ else
+ val = scm_weak_table_refq (dynamic_state->values, fluid,
+ SCM_UNDEFINED);
+
+ if (SCM_UNBNDP (val))
+ val = SCM_I_FLUID_DEFAULT (fluid);
+
+ /* Cache this lookup. */
+ fluid_set_x (dynamic_state, fluid, val);
+ }
+
+ return val;
+}
+
+SCM
+scm_i_fluid_ref (scm_thread *thread, SCM fluid)
+{
+ SCM ret = fluid_ref (thread->dynamic_state, fluid);
+
+ if (SCM_UNBNDP (ret))
+ scm_misc_error ("fluid-ref", "unbound fluid: ~S", scm_list_1 (fluid));
+
+ 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"
+ "dynamic root. If @var{fluid} has not been set, then return\n"
+ "its default value.")
+#define FUNC_NAME s_scm_fluid_ref
+{
+ SCM_VALIDATE_FLUID (1, fluid);
+ return scm_i_fluid_ref (SCM_I_CURRENT_THREAD, fluid);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_fluid_ref_star, "fluid-ref*", 2, 0, 0,
+ (SCM fluid, SCM depth),
+ "Return the @var{depth}th oldest value associated with\n"
+ "@var{fluid} in the current thread. If @var{depth} equals\n"
+ "or exceeds the number of values that have been assigned to\n"
+ "@var{fluid}, return the default value of the fluid.")
+#define FUNC_NAME s_scm_fluid_ref_star
+{
+ SCM ret;
+ size_t c_depth;
+
+ SCM_VALIDATE_FLUID (1, fluid);
+ c_depth = SCM_NUM2SIZE (2, depth);
+
+ /* Because this function is called to look up the current exception
+ handler and this can happen in an out-of-memory situation, we avoid
+ cache flushes to the weak table which might cause allocation of a
+ disappearing link. */
+ if (c_depth == 0)
+ {
+ scm_t_dynamic_state *dynamic_state = SCM_I_CURRENT_THREAD->dynamic_state;
+ struct scm_cache_entry *entry;
+
+ entry = scm_cache_lookup (&dynamic_state->cache, fluid);
+ if (scm_is_eq (SCM_PACK (entry->key), fluid))
+ ret = SCM_PACK (entry->value);
+ else
+ {
+ if (SCM_I_FLUID_THREAD_LOCAL_P (fluid))
+ ret = scm_hashq_ref (dynamic_state->thread_local_values, fluid,
+ SCM_UNDEFINED);
+ else
+ ret = scm_weak_table_refq (dynamic_state->values, fluid,
+ SCM_UNDEFINED);
+
+ if (SCM_UNBNDP (ret))
+ ret = SCM_I_FLUID_DEFAULT (fluid);
+
+ /* Don't cache the lookup. */
+ }
+ }
+ else
+ ret = scm_dynstack_find_old_fluid_value (&SCM_I_CURRENT_THREAD->dynstack,
+ fluid, c_depth - 1,
+ SCM_I_FLUID_DEFAULT (fluid));
+
+ if (SCM_UNBNDP (ret))
+ scm_misc_error ("fluid-ref*", "unbound fluid: ~S", scm_list_1 (fluid));
+ return ret;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_fluid_set_x, "fluid-set!", 2, 0, 0,
+ (SCM fluid, SCM value),
+ "Set the value associated with @var{fluid} in the current dynamic root.")
+#define FUNC_NAME s_scm_fluid_set_x
+{
+ SCM_VALIDATE_FLUID (1, fluid);
+ fluid_set_x (SCM_I_CURRENT_THREAD->dynamic_state, fluid, value);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+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
+{
+ /* FIXME: really unset the default value, too? The current test
+ suite demands it, but I would prefer not to. */
+ SCM_VALIDATE_FLUID (1, fluid);
+ SCM_SET_CELL_OBJECT_1 (fluid, SCM_UNDEFINED);
+ fluid_set_x (SCM_I_CURRENT_THREAD->dynamic_state, fluid, SCM_UNDEFINED);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+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
+{
+ SCM val;
+ SCM_VALIDATE_FLUID (1, fluid);
+ val = fluid_ref (SCM_I_CURRENT_THREAD->dynamic_state, fluid);
+ return scm_from_bool (! (SCM_UNBNDP (val)));
+}
+#undef FUNC_NAME
+
+static SCM
+apply_thunk (void *thunk)
+{
+ return scm_call_0 (SCM_PACK (thunk));
+}
+
+void
+scm_swap_fluid (SCM fluid, SCM value_box, scm_t_dynamic_state *dynstate)
+{
+ SCM val = fluid_ref (dynstate, fluid);
+ fluid_set_x (dynstate, fluid, SCM_VARIABLE_REF (value_box));
+ SCM_VARIABLE_SET (value_box, val);
+}
+
+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"
+ "@var{fluids} must be a list of fluids and @var{values} must be the same\n"
+ "number of their values to be applied. Each substitution is done\n"
+ "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));
+}
+#undef FUNC_NAME
+
+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, i;
+ scm_thread *thread = SCM_I_CURRENT_THREAD;
+
+ 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);
+
+ for (i = 0; i < flen; i++)
+ {
+ scm_dynstack_push_fluid (&thread->dynstack,
+ SCM_CAR (fluids), SCM_CAR (values),
+ thread->dynamic_state);
+ fluids = SCM_CDR (fluids);
+ values = SCM_CDR (values);
+ }
+
+ ans = cproc (cdata);
+
+ for (i = 0; i < flen; i++)
+ scm_dynstack_unwind_fluid (&thread->dynstack, thread->dynamic_state);
+
+ return ans;
+}
+#undef FUNC_NAME
+
+SCM
+scm_with_fluid (SCM fluid, SCM value, SCM thunk)
+{
+ return scm_c_with_fluid (fluid, value,
+ apply_thunk, (void *) SCM_UNPACK (thunk));
+}
+
+SCM
+scm_c_with_fluid (SCM fluid, SCM value, SCM (*cproc) (), void *cdata)
+#define FUNC_NAME "scm_c_with_fluid"
+{
+ SCM ans;
+ scm_thread *thread = SCM_I_CURRENT_THREAD;
+
+ scm_dynstack_push_fluid (&thread->dynstack, fluid, value,
+ thread->dynamic_state);
+ ans = cproc (cdata);
+ scm_dynstack_unwind_fluid (&thread->dynstack, thread->dynamic_state);
+
+ return ans;
+}
+#undef FUNC_NAME
+
+static void
+swap_fluid (SCM data)
+{
+ scm_t_dynamic_state *dynstate = SCM_I_CURRENT_THREAD->dynamic_state;
+ SCM f = SCM_CAR (data);
+ SCM t = fluid_ref (dynstate, f);
+ fluid_set_x (dynstate, 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 (void)
+{
+ return scm_cell (scm_tc7_dynamic_state,
+ SCM_UNPACK (scm_c_make_weak_table
+ (0, SCM_WEAK_TABLE_KIND_KEY)));
+}
+
+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 a snapshot of the current fluid-value associations\n"
+ "as a fresh dynamic state object.")
+#define FUNC_NAME s_scm_current_dynamic_state
+{
+ struct scm_dynamic_state *state = SCM_I_CURRENT_THREAD->dynamic_state;
+ return scm_cell (scm_tc7_dynamic_state,
+ SCM_UNPACK (save_dynamic_state (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_thread *t = SCM_I_CURRENT_THREAD;
+ SCM old = scm_current_dynamic_state ();
+ SCM_ASSERT (is_dynamic_state (state), state, SCM_ARG1, FUNC_NAME);
+ restore_dynamic_state (get_dynamic_state (state), t->dynamic_state);
+ return old;
+}
+#undef FUNC_NAME
+
+SCM
+scm_dynamic_state_ref (SCM state, SCM fluid, SCM dflt)
+{
+ SCM_ASSERT (is_dynamic_state (state), state, SCM_ARG1,
+ "dynamic-state-ref");
+ return saved_dynamic_state_ref (get_dynamic_state (state), fluid, dflt);
+}
+
+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 ()
+{
+#include "fluids.x"
+}