unbound fluids

* libguile/fluids.c (scm_make_undefined_fluid, scm_fluid_unset_x)
  (scm_fluid_bound_p): New functions.

  (fluid_ref): New function; like scm_fluid_ref, but will not throw an
  error for unbound fluids.
  (scm_fluid_ref, swap_fluid): Use `fluid_ref'.

* libguile/fluids.h (scm_make_undefined_fluid, scm_fluid_unset_x)
  (scm_fluid_bound_p): New prototypes.

* libguile/vm-i-system.c (fluid_ref): If fluid is unbound, jump to
  `vm_error_unbound_fluid'.
* libguile/vm-engine.c (VM_NAME)[vm_error_unbound_fluid]: New error
  message.

* test-suite/tests/fluids.test ("unbound fluids")["fluid-ref of unbound
  fluid", "fluid-bound? of bound fluid", "fluid-bound? of unbound
  fluid", "unbound fluids can be set", "bound fluids can be unset"]: New
  tests.

5 files changed, 90 insertions, 13 deletions

diff --git a/libguile/fluids.c b/libguile/fluids.c
index 636c78d89..c10f96db5 100644
--- a/libguile/fluids.c
+++ b/libguile/fluids.c
@@ -180,6 +180,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"
@@ -196,19 +207,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.  */
@@ -219,6 +223,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,
@@ -243,6 +263,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)
 {
@@ -405,7 +447,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 ff41ce4b6..ee9f969e2 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -145,6 +145,10 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
     err_msg  = scm_from_locale_string ("VM: Unbound variable: ~s");
     goto vm_error;
 
+  vm_error_unbound_fluid:
+    err_msg = scm_from_locale_string ("VM: Unbound fluid: ~s");
+    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 9ba287d5a..fe8582ce7 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -1594,7 +1594,7 @@ VM_DEFINE_INSTRUCTION (91, unwind_fluids, "unwind-fluids", 0, 0, 0)
 VM_DEFINE_INSTRUCTION (92, fluid_ref, "fluid-ref", 0, 1, 1)
 {
   size_t num;
-  SCM fluids;
+  SCM fluids, val;
   
   CHECK_UNDERFLOW ();
   fluids = SCM_I_DYNAMIC_STATE_FLUIDS (dynstate);
@@ -1606,7 +1606,15 @@ VM_DEFINE_INSTRUCTION (92, fluid_ref, "fluid-ref", 0, 1, 1)
       *sp = scm_fluid_ref (*sp);
     }
   else
-    *sp = SCM_SIMPLE_VECTOR_REF (fluids, num);
+    {
+      val = SCM_SIMPLE_VECTOR_REF (fluids, num);
+      if (val == SCM_UNDEFINED)
+        {
+          finish_args = scm_list_1 (*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)))))