summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/fluids.c64
-rw-r--r--libguile/fluids.h3
-rw-r--r--libguile/vm-engine.c7
-rw-r--r--libguile/vm-i-system.c10
-rw-r--r--test-suite/tests/fluids.test20
5 files changed, 92 insertions, 12 deletions
diff --git a/libguile/fluids.c b/libguile/fluids.c
index 8b31c85c6..6d048a005 100644
--- a/libguile/fluids.c
+++ b/libguile/fluids.c
@@ -181,6 +181,17 @@ SCM_DEFINE (scm_make_fluid, "make-fluid", 0, 0, 0,
}
#undef FUNC_NAME
+SCM_DEFINE (scm_make_undefined_fluid, "make-undefined-fluid", 0, 0, 0,
+ (),
+ "")
+#define FUNC_NAME s_scm_make_undefined_fluid
+{
+ SCM f = new_fluid ();
+ scm_fluid_set_x (f, SCM_UNDEFINED);
+ return f;
+}
+#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"
@@ -197,19 +208,12 @@ scm_is_fluid (SCM obj)
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 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. */
@@ -220,6 +224,22 @@ SCM_DEFINE (scm_fluid_ref, "fluid-ref", 1, 0, 0,
return SCM_SIMPLE_VECTOR_REF (fluids, FLUID_NUM (fluid));
}
+
+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
SCM_DEFINE (scm_fluid_set_x, "fluid-set!", 2, 0, 0,
@@ -244,6 +264,28 @@ SCM_DEFINE (scm_fluid_set_x, "fluid-set!", 2, 0, 0,
}
#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
+{
+ 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)
{
@@ -406,7 +448,7 @@ static void
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);
}
diff --git a/libguile/fluids.h b/libguile/fluids.h
index d8374149a..db82203fe 100644
--- a/libguile/fluids.h
+++ b/libguile/fluids.h
@@ -60,10 +60,13 @@
#endif
SCM_API SCM scm_make_fluid (void);
+SCM_API SCM scm_make_undefined_fluid (void);
SCM_API int scm_is_fluid (SCM obj);
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_API SCM scm_fluid_unset_x (SCM fluid);
+SCM_API SCM scm_fluid_bound_p (SCM fluid);
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);
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 2e3a87644..e69167f31 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -146,6 +146,13 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
scm_list_1 (finish_args), SCM_BOOL_F);
goto vm_error;
+ vm_error_unbound_fluid:
+ SYNC_ALL ();
+ err_msg = scm_from_locale_string ("Unbound fluid: ~s");
+ scm_error_scm (scm_misc_error_key, program, err_msg,
+ scm_list_1 (finish_args), SCM_BOOL_F);
+ goto vm_error;
+
vm_error_apply_to_non_list:
scm_error (scm_arg_type_key, "apply", "Apply to non-list: ~S",
finish_args, finish_args);
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index e1aedd7cd..5b40c1b9d 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -1612,7 +1612,15 @@ VM_DEFINE_INSTRUCTION (91, fluid_ref, "fluid-ref", 0, 1, 1)
*sp = scm_fluid_ref (*sp);
}
else
- *sp = SCM_SIMPLE_VECTOR_REF (fluids, num);
+ {
+ SCM val = SCM_SIMPLE_VECTOR_REF (fluids, num);
+ if (SCM_UNLIKELY (val == SCM_UNDEFINED))
+ {
+ finish_args = *sp;
+ goto vm_error_unbound_fluid;
+ }
+ *sp = val;
+ }
NEXT;
}
diff --git a/test-suite/tests/fluids.test b/test-suite/tests/fluids.test
index 8604dcbb2..23406b260 100644
--- a/test-suite/tests/fluids.test
+++ b/test-suite/tests/fluids.test
@@ -147,3 +147,23 @@
(and (eq? inside-a 'inside)
(eq? outside-a 'outside)
(eq? inside-a2 'inside))))))))
+
+(with-test-prefix "unbound fluids"
+ (pass-if "fluid-ref of unbound fluid"
+ (catch #t
+ (lambda () (fluid-ref (make-undefined-fluid)))
+ (lambda (key . args) #t)))
+ (pass-if "fluid-bound? of bound fluid"
+ (fluid-bound? (make-fluid)))
+ (pass-if "fluid-bound? of unbound fluid"
+ (not (fluid-bound? (make-undefined-fluid))))
+ (pass-if "unbound fluids can be set"
+ (let ((fluid (make-undefined-fluid)))
+ (fluid-set! fluid #t)
+ (fluid-ref fluid)))
+ (pass-if "bound fluids can be unset"
+ (let ((fluid (make-fluid)))
+ (fluid-unset! fluid)
+ (catch #t
+ (lambda () (fluid-ref fluid))
+ (lambda (key . args) #t)))))