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.

diff --git a/libguile/fluids.c b/libguile/fluids.c
index 8b31c85..6d048a0 100644 (file)
--- 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 d837414..db82203 100644 (file)
--- 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 2e3a876..e69167f 100644 (file)
--- 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 e1aedd7..5b40c1b 100644 (file)
--- 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 8604dcb..23406b2 100644 (file)
--- 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)))))