X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/104d453328e31200fd6e547d4bbe95fc160080a9..6f29dc6d2f5837a612fe55afe995373d99c67d67:/libguile/fluids.c diff --git a/libguile/fluids.c b/libguile/fluids.c index 225709c92..752ef9c29 100644 --- a/libguile/fluids.c +++ b/libguile/fluids.c @@ -39,6 +39,10 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + + #include "_scm.h" #include "print.h" #include "smob.h" @@ -46,8 +50,10 @@ #include "fluids.h" #include "alist.h" #include "eval.h" +#include "ports.h" #define INITIAL_FLUIDS 10 +#include "validate.h" static volatile int n_fluids; long scm_tc16_fluid; @@ -56,22 +62,18 @@ SCM scm_make_initial_fluids () { return scm_make_vector (SCM_MAKINUM (INITIAL_FLUIDS), - SCM_BOOL_F, SCM_BOOL_F); + SCM_BOOL_F); } -static void grow_fluids SCM_P ((scm_root_state *, int new_length)); static void -grow_fluids (root_state, new_length) - scm_root_state *root_state; - int new_length; +grow_fluids (scm_root_state *root_state, int new_length) { SCM old_fluids, new_fluids; int old_length, i; old_fluids = root_state->fluids; old_length = SCM_LENGTH (old_fluids); - new_fluids = scm_make_vector (SCM_MAKINUM (new_length), - SCM_BOOL_F, SCM_BOOL_F); + new_fluids = scm_make_vector (SCM_MAKINUM (new_length), SCM_BOOL_F); i = 0; while (i < old_length) { @@ -88,33 +90,22 @@ grow_fluids (root_state, new_length) } void -scm_copy_fluids (root_state) - scm_root_state *root_state; +scm_copy_fluids (scm_root_state *root_state) { grow_fluids (root_state, SCM_LENGTH(root_state->fluids)); } -static int print_fluid SCM_P ((SCM exp, SCM port, scm_print_state *pstate)); static int -print_fluid (exp, port, pstate) - SCM exp; - SCM port; - scm_print_state *pstate; +print_fluid (SCM exp, SCM port, scm_print_state *pstate) { - scm_puts ("#', port); - return 1; + scm_puts ("#', port); + return 1; } -static scm_smobfuns fluid_smob = { - scm_mark0, - scm_free0, - print_fluid -}; - -static -int next_fluid_num () +static int +next_fluid_num () { int n; #ifdef USE_THREADS @@ -127,72 +118,71 @@ int next_fluid_num () return n; } -SCM_PROC (s_make_fluid, "make-fluid", 0, 0, 0, scm_make_fluid); - -SCM -scm_make_fluid () +SCM_DEFINE (scm_make_fluid, "make-fluid", 0, 0, 0, + (), + "Return a newly created fluid.\n" + "Fluids are objects of a certain type (a smob) that can hold one SCM\n" + "value per dynamic root. That is, modifications to this value are\n" + "only visible to code that executes within the same dynamic root as\n" + "the modifying code. When a new dynamic root is constructed, it\n" + "inherits the values from its parent. Because each thread executes\n" + "in its own dynamic root, you can use fluids for thread local storage.") +#define FUNC_NAME s_scm_make_fluid { - SCM z; int n; SCM_DEFER_INTS; n = next_fluid_num (); - SCM_NEWCELL (z); - SCM_SETCAR (z, scm_tc16_fluid); - SCM_SETCDR (z, n); - SCM_ALLOW_INTS; - - return z; + SCM_RETURN_NEWSMOB (scm_tc16_fluid, n); } +#undef FUNC_NAME -SCM_PROC (s_fluid_p, "fluid?", 1, 0, 0, scm_fluid_p); - -SCM -scm_fluid_p (fl) - SCM fl; +SCM_DEFINE (scm_fluid_p, "fluid?", 1, 0, 0, + (SCM obj), + "Return #t iff @var{obj} is a fluid; otherwise, return #f.") +#define FUNC_NAME s_scm_fluid_p { - return (SCM_NIMP (fl) && SCM_FLUIDP (fl))? SCM_BOOL_T : SCM_BOOL_F; + return SCM_BOOL(SCM_FLUIDP (obj)); } +#undef FUNC_NAME -SCM_PROC (s_fluid_ref, "fluid-ref", 1, 0, 0, scm_fluid_ref); - -SCM -scm_fluid_ref (fl) - SCM fl; +SCM_DEFINE (scm_fluid_ref, "fluid-ref", 1, 0, 0, + (SCM fluid), + "Return the value associated with @var{fluid} in the current dynamic root.\n" + "If @var{fluid} has not been set, then this returns #f.") +#define FUNC_NAME s_scm_fluid_ref { int n; - SCM_ASSERT (SCM_NIMP (fl) && SCM_FLUIDP (fl), fl, SCM_ARG1, s_fluid_ref); + SCM_VALIDATE_FLUID (1, fluid); - n = SCM_FLUID_NUM (fl); + n = SCM_FLUID_NUM (fluid); if (SCM_LENGTH (scm_root->fluids) <= n) grow_fluids (scm_root, n+1); return SCM_VELTS(scm_root->fluids)[n]; } +#undef FUNC_NAME -SCM_PROC (s_fluid_set_x, "fluid-set!", 2, 0, 0, scm_fluid_set_x); - -SCM -scm_fluid_set_x (fl, val) - SCM fl; - SCM val; +SCM_DEFINE (scm_fluid_set_x, "fluid-set!", 2, 0, 0, + (SCM fluid, SCM value), + "Set the value associated with @var{fluid} in the current dynamic root.") +#define FUNC_NAME s_scm_fluid_set_x { int n; - SCM_ASSERT (SCM_NIMP (fl) && SCM_FLUIDP (fl), fl, SCM_ARG1, s_fluid_set_x); - - n = SCM_FLUID_NUM (fl); + SCM_VALIDATE_FLUID (1, fluid); + n = SCM_FLUID_NUM (fluid); if (SCM_LENGTH (scm_root->fluids) <= n) grow_fluids (scm_root, n+1); - SCM_VELTS(scm_root->fluids)[n] = val; - return val; + SCM_VELTS(scm_root->fluids)[n] = value; + return value; } +#undef FUNC_NAME void -scm_swap_fluids (fluids, vals) - SCM fluids, vals; +scm_swap_fluids (SCM fluids, SCM vals) { while (SCM_NIMP (fluids)) { @@ -209,8 +199,7 @@ scm_swap_fluids (fluids, vals) same fluid appears multiple times in the fluids list. */ void -scm_swap_fluids_reverse (fluids, vals) - SCM fluids, vals; +scm_swap_fluids_reverse (SCM fluids, SCM vals) { if (SCM_NIMP (fluids)) { @@ -224,47 +213,58 @@ scm_swap_fluids_reverse (fluids, vals) } } -SCM_PROC (s_with_fluids, "with-fluids*", 3, 0, 0, scm_with_fluids); + +static SCM +apply_thunk (void *thunk) +{ + return scm_apply ((SCM) thunk, SCM_EOL, SCM_EOL); +} + +SCM_DEFINE (scm_with_fluids, "with-fluids*", 3, 0, 0, + (SCM fluids, SCM values, SCM thunk), + "Set @var{fluids} to @var{values} temporary, and call @var{thunk}.\n" + "@var{fluids} must be a list of fluids and @var{values} must be the same\n" + "number of their values to be applied. Each substitution is done\n" + "one after another. @var{thunk} must be a procedure with no argument.") +#define FUNC_NAME s_scm_with_fluids +{ + return scm_internal_with_fluids (fluids, values, apply_thunk, (void *)thunk); +} +#undef FUNC_NAME SCM -scm_internal_with_fluids (fluids, vals, cproc, cdata) - SCM fluids, vals; - SCM (*cproc) (); - void *cdata; +scm_internal_with_fluids (SCM fluids, SCM values, SCM (*cproc) (), void *cdata) +#define FUNC_NAME "scm_internal_with_fluids" { SCM ans; + int flen, vlen; - 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); + SCM_VALIDATE_LIST_COPYLEN (1, fluids, flen); + SCM_VALIDATE_LIST_COPYLEN (2, values, vlen); if (flen != vlen) - scm_out_of_range (s_with_fluids, vals); + scm_out_of_range (s_scm_with_fluids, values); - scm_swap_fluids (fluids, vals); - scm_dynwinds = scm_acons (fluids, vals, scm_dynwinds); + scm_swap_fluids (fluids, values); + scm_dynwinds = scm_acons (fluids, values, scm_dynwinds); ans = cproc (cdata); scm_dynwinds = SCM_CDR (scm_dynwinds); - scm_swap_fluids_reverse (fluids, vals); + scm_swap_fluids_reverse (fluids, values); return ans; } +#undef FUNC_NAME -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); + scm_tc16_fluid = scm_make_smob_type_mfpe ("fluid", 0, + NULL, NULL, print_fluid, NULL); #include "fluids.x" } + +/* + Local Variables: + c-file-style: "gnu" + End: +*/