mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-10 14:00:21 +02:00
* dynwind.c (scm_dowinds): Handle fluids on the wind list.
* fluids.h (scm_internal_with_fluids, scm_with_fluids, scm_swap_fluids, scm_swap_fluids_reverse): New prototypes. * fluids.c (scm_internal_with_fluids, scm_with_fluids, scm_swap_fluids, scm_swap_fluids_reverse): New functions.
This commit is contained in:
Marius Vollmer
parent
485cb6eb4f
commit
b3460a507a
3 changed files with 122 additions and 12 deletions
|
|
@ -44,12 +44,23 @@
|
|||
#include "_scm.h"
|
||||
#include "eval.h"
|
||||
#include "alist.h"
|
||||
#include "fluids.h"
|
||||
|
||||
#include "dynwind.h"
|
||||
|
||||
|
||||
/* {Dynamic wind}
|
||||
*/
|
||||
|
||||
Things that can be on the wind list:
|
||||
|
||||
(enter-proc . leave-proc) dynamic-wind
|
||||
(tag . jmpbuf) catch
|
||||
(tag . lazy-catch) lazy-catch
|
||||
tag is either a symbol or a boolean
|
||||
|
||||
((fluid ...) . (value ...)) with-fluids
|
||||
|
||||
*/
|
||||
|
||||
|
||||
|
||||
|
|
@ -94,10 +105,15 @@ scm_dowinds (to, delta)
|
|||
#endif
|
||||
{
|
||||
wind_key = SCM_CAR (wind_elt);
|
||||
if ( !(SCM_NIMP (wind_key) && SCM_SYMBOLP (wind_key))
|
||||
if (!(SCM_NIMP (wind_key) && SCM_SYMBOLP (wind_key))
|
||||
&& (wind_key != SCM_BOOL_F)
|
||||
&& (wind_key != SCM_BOOL_T))
|
||||
scm_apply (wind_key, SCM_EOL, SCM_EOL);
|
||||
{
|
||||
if (SCM_NIMP (wind_key) && SCM_CONSP (wind_key))
|
||||
scm_swap_fluids (wind_key, SCM_CDR (wind_elt));
|
||||
else
|
||||
scm_apply (wind_key, SCM_EOL, SCM_EOL);
|
||||
}
|
||||
}
|
||||
scm_dynwinds = to;
|
||||
}
|
||||
|
|
@ -119,10 +135,15 @@ scm_dowinds (to, delta)
|
|||
#endif
|
||||
{
|
||||
wind_key = SCM_CAR (wind_elt);
|
||||
if ( !(SCM_NIMP (wind_key) && SCM_SYMBOLP (wind_key))
|
||||
if (!(SCM_NIMP (wind_key) && SCM_SYMBOLP (wind_key))
|
||||
&& (wind_key != SCM_BOOL_F)
|
||||
&& (wind_key != SCM_BOOL_T))
|
||||
scm_apply (from, SCM_EOL, SCM_EOL);
|
||||
{
|
||||
if (SCM_NIMP (wind_key) && SCM_CONSP (wind_key))
|
||||
scm_swap_fluids_reverse (wind_key, from);
|
||||
else
|
||||
scm_apply (from, SCM_EOL, SCM_EOL);
|
||||
}
|
||||
}
|
||||
delta--;
|
||||
goto tail; /* scm_dowinds(to, delta-1); */
|
||||
|
|
@ -136,4 +157,3 @@ scm_init_dynwind ()
|
|||
{
|
||||
#include "dynwind.x"
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
@ -184,6 +196,78 @@ scm_fluid_set_x (fl, val)
|
|||
return 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 ()
|
||||
{
|
||||
|
|
|
|||
|
|
@ -62,10 +62,10 @@
|
|||
to index a vector that holds the values of all fluids. Each root
|
||||
has its own vector.
|
||||
|
||||
Currently, you can't get rid a certain fluid if you don't use any
|
||||
longer. The slot that has been allocated for it in the fluid
|
||||
Currently, you can't get rid a certain fluid if you don't use it
|
||||
any longer. The slot that has been allocated for it in the fluid
|
||||
vector will not be reused for other fluids. Therefore, only use
|
||||
SCM_MAKE_FLUID or it Scheme variant `make-fluid' in initialization
|
||||
SCM_MAKE_FLUID or its Scheme variant `make-fluid' in initialization
|
||||
code that is only run once. Nevertheless, it should be possible to
|
||||
implement a more lightweight version of fluids on top of this basic
|
||||
mechanism. */
|
||||
|
|
@ -76,7 +76,7 @@ extern long scm_tc16_fluid;
|
|||
#define SCM_FLUID_NUM(x) SCM_CDR(x)
|
||||
|
||||
/* The fastest way to acces/modify the value of a fluid. These macros
|
||||
does no error checking at all. You should only use them when you know
|
||||
do no error checking at all. You should only use them when you know
|
||||
that the relevant fluid already exists in the current dynamic root.
|
||||
The easiest way to ensure this is to execute a SCM_FLUID_SET_X in the
|
||||
topmost root, for example right after SCM_MAKE_FLUID in your
|
||||
|
|
@ -91,8 +91,14 @@ SCM scm_make_fluid SCM_P ((void));
|
|||
SCM scm_fluid_ref SCM_P ((SCM fluid));
|
||||
SCM scm_fluid_set_x SCM_P ((SCM fluid, SCM value));
|
||||
|
||||
SCM scm_internal_with_fluids SCM_P ((SCM fluids, SCM vals,
|
||||
SCM (*cproc)(void *), void *cdata));
|
||||
SCM scm_with_fluids SCM_P ((SCM fluids, SCM vals, SCM thunk));
|
||||
|
||||
SCM scm_make_initial_fluids SCM_P ((void));
|
||||
void scm_copy_fluids SCM_P ((scm_root_state *));
|
||||
void scm_swap_fluids SCM_P ((SCM fluids, SCM vals));
|
||||
void scm_swap_fluids_reverse SCM_P ((SCM fluids, SCM vals));
|
||||
|
||||
void scm_init_fluids SCM_P ((void));
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue