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)))))