-/* Copyright (C) 1996,1997,2000,2001, 2004, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 1996,1997,2000,2001, 2004, 2006, 2007, 2008, 2009, 2010, 2011 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
# include <config.h>
#endif
+#include <alloca.h>
#include <stdio.h>
#include <string.h>
#include "libguile/eval.h"
#include "libguile/ports.h"
#include "libguile/deprecation.h"
-#include "libguile/lang.h"
#include "libguile/validate.h"
#include "libguile/bdw-gc.h"
static scm_i_pthread_mutex_t fluid_admin_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
-#define IS_FLUID(x) SCM_I_FLUID_P (x)
+#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)
/* Assume the assignment below is atomic. */
len = allocated_fluids_len;
- new_fluids = scm_c_make_vector (len, SCM_BOOL_F);
+ new_fluids = scm_c_make_vector (len, SCM_UNDEFINED);
for (i = 0; i < old_len; i++)
SCM_SIMPLE_VECTOR_SET (new_fluids, i,
\f
/* Return a new fluid. */
static SCM
-new_fluid ()
+new_fluid (SCM init)
{
SCM fluid;
size_t trial, n;
- /* Fluids are pointerless cells: the first word is the type tag; the second
- word is the fluid number. */
- fluid = PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_cell), "fluid"));
+ /* 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);
}
allocated_fluids[n] = SCM2PTR (fluid);
- SCM_SET_CELL_WORD_1 (fluid, (scm_t_bits) n);
+ 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_DEFINE (scm_make_fluid, "make-fluid", 0, 0, 0,
- (),
+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.\n"
"Fluids are objects that can hold one\n"
"value per dynamic state. That is, modifications to this value are\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
+#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 ();
+ return new_fluid (SCM_UNDEFINED);
}
#undef FUNC_NAME
return IS_FLUID (obj);
}
-
-
-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"
- "@code{#f}.")
-#define FUNC_NAME s_scm_fluid_ref
+/* 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);
- SCM_VALIDATE_FLUID (1, fluid);
-
if (SCM_UNLIKELY (FLUID_NUM (fluid) >= SCM_SIMPLE_VECTOR_LENGTH (fluids)))
{
/* Lazily grow the current thread's dynamic state. */
fluids = DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD->dynamic_state);
}
- return SCM_SIMPLE_VECTOR_REF (fluids, FLUID_NUM (fluid));
+ 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"
+ "dynamic root. If @var{fluid} has not been set, then return\n"
+ "@code{#f}.")
+#define FUNC_NAME s_scm_fluid_ref
+{
+ SCM val;
+ SCM_VALIDATE_FLUID (1, fluid);
+ val = fluid_ref (fluid);
+ if (SCM_UNBNDP (val))
+ SCM_MISC_ERROR ("unbound fluid: ~S",
+ scm_list_1 (fluid));
+ return val;
}
#undef FUNC_NAME
}
#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_SET_CELL_OBJECT_1 (fluid, SCM_UNDEFINED);
+ return scm_fluid_set_x (fluid, SCM_UNDEFINED);
+}
+#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 (fluid);
+ return scm_from_bool (! (SCM_UNBNDP (val)));
+}
+#undef FUNC_NAME
+
static SCM
apply_thunk (void *thunk)
{
while (j--)
for (i = 0; i < j; i++)
- if (fluids[i] == fluids[j])
+ if (scm_is_eq (fluids[i], fluids[j]))
{
vals[i] = vals[j]; /* later bindings win */
n--;
swap_fluid (SCM data)
{
SCM f = SCM_CAR (data);
- SCM t = scm_fluid_ref (f);
+ SCM t = fluid_ref (f);
scm_fluid_set_x (f, SCM_CDR (data));
SCM_SETCDR (data, t);
}
HCoop / bpt / guile.git / blobdiff