diff options
Diffstat (limited to 'libguile/fluids.c')
-rw-r--r-- | libguile/fluids.c | 88 |
1 files changed, 86 insertions, 2 deletions
diff --git a/libguile/fluids.c b/libguile/fluids.c index e71cb5bbf..91419d8eb 100644 --- a/libguile/fluids.c +++ b/libguile/fluids.c @@ -44,7 +44,10 @@ #include "_scm.h" #include "print.h" #include "smob.h" +#include "dynwind.h" #include "fluids.h" +#include "alist.h" +#include "eval.h" #define INITIAL_FLUIDS 10 @@ -146,6 +149,15 @@ scm_make_fluid () return z; } +SCM_PROC (s_fluid_p, "fluid?", 1, 0, 0, scm_fluid_p); + +SCM +scm_fluid_p (fl) + SCM fl; +{ + return (SCM_NIMP (fl) && SCM_FLUIDP (fl))? SCM_BOOL_T : SCM_BOOL_F; +} + SCM_PROC (s_fluid_ref, "fluid-ref", 1, 0, 0, scm_fluid_ref); SCM @@ -154,7 +166,7 @@ scm_fluid_ref (fl) { int n; - SCM_ASSERT (SCM_NIMP (fl) && SCM_FLUIDP (fl), SCM_ARG1, fl, s_fluid_ref); + SCM_ASSERT (SCM_NIMP (fl) && SCM_FLUIDP (fl), fl, SCM_ARG1, s_fluid_ref); n = SCM_FLUID_NUM (fl); assert (n >= 0 && n < n_fluids); @@ -173,7 +185,7 @@ scm_fluid_set_x (fl, val) { int n; - SCM_ASSERT (SCM_NIMP (fl) && SCM_FLUIDP (fl), SCM_ARG1, fl, s_fluid_set_x); + SCM_ASSERT (SCM_NIMP (fl) && SCM_FLUIDP (fl), fl, SCM_ARG1, s_fluid_set_x); n = SCM_FLUID_NUM (fl); assert (n >= 0 && n < n_fluids); @@ -185,6 +197,78 @@ scm_fluid_set_x (fl, val) } void +scm_swap_fluids (fluids, vals) + SCM fluids, vals; +{ + while (SCM_NIMP (fluids)) + { + SCM fl = SCM_CAR (fluids); + SCM old_val = scm_fluid_ref (fl); + scm_fluid_set_x (fl, SCM_CAR (vals)); + SCM_SETCAR (vals, old_val); + fluids = SCM_CDR (fluids); + vals = SCM_CDR (vals); + } +} + +/* Swap the fluid values in reverse order. This is important when the +same fluid appears multiple times in the fluids list. */ + +void +scm_swap_fluids_reverse (fluids, vals) + SCM fluids, vals; +{ + if (SCM_NIMP (fluids)) + { + SCM fl, old_val; + + scm_swap_fluids_reverse (SCM_CDR (fluids), SCM_CDR (vals)); + fl = SCM_CAR (fluids); + old_val = scm_fluid_ref (fl); + scm_fluid_set_x (fl, SCM_CAR (vals)); + SCM_SETCAR (vals, old_val); + } +} + +SCM_PROC (s_with_fluids, "with-fluids*", 3, 0, 0, scm_with_fluids); + +SCM +scm_internal_with_fluids (fluids, vals, cproc, cdata) + SCM fluids, vals; + SCM (*cproc) (); + void *cdata; +{ + SCM ans; + + int flen = scm_ilength (fluids); + int vlen = scm_ilength (vals); + SCM_ASSERT (flen >= 0, fluids, SCM_ARG1, s_with_fluids); + SCM_ASSERT (vlen >= 0, vals, SCM_ARG2, s_with_fluids); + if (flen != vlen) + scm_out_of_range (s_with_fluids, vals); + + scm_swap_fluids (fluids, vals); + scm_dynwinds = scm_acons (fluids, vals, scm_dynwinds); + ans = cproc (cdata); + scm_dynwinds = SCM_CDR (scm_dynwinds); + scm_swap_fluids_reverse (fluids, vals); + return ans; +} + +static SCM +apply_thunk (void *thunk) +{ + return scm_apply ((SCM) thunk, SCM_EOL, SCM_EOL); +} + +SCM +scm_with_fluids (fluids, vals, thunk) + SCM fluids, vals, thunk; +{ + return scm_internal_with_fluids (fluids, vals, apply_thunk, (void *)thunk); +} + +void scm_init_fluids () { scm_tc16_fluid = scm_newsmob(&fluid_smob); |