1 /* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 2008, 2010, 2011 Free Software Foundation, Inc.
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public License
5 * as published by the Free Software Foundation; either version 3 of
6 * the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful, but
9 * WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 * Lesser General Public License for more details.
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
15 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
28 #include "libguile/_scm.h"
29 #include "libguile/control.h"
30 #include "libguile/eval.h"
31 #include "libguile/alist.h"
32 #include "libguile/fluids.h"
33 #include "libguile/ports.h"
34 #include "libguile/smob.h"
36 #include "libguile/dynwind.h"
41 Things that can be on the wind list:
47 (enter-proc . leave-proc) dynamic-wind
54 scm_dynamic_wind (SCM in_guard
, SCM thunk
, SCM out_guard
)
55 #define FUNC_NAME "dynamic-wind"
58 SCM_ASSERT (scm_is_true (scm_thunk_p (out_guard
)),
61 scm_call_0 (in_guard
);
62 old_winds
= scm_i_dynwinds ();
63 scm_i_set_dynwinds (scm_acons (in_guard
, out_guard
, old_winds
));
64 ans
= scm_call_0 (thunk
);
65 scm_i_set_dynwinds (old_winds
);
66 scm_call_0 (out_guard
);
71 /* Frames and winders. */
73 static scm_t_bits tc16_frame
;
74 #define FRAME_P(f) SCM_SMOB_PREDICATE (tc16_frame, (f))
76 #define FRAME_F_REWINDABLE (1 << 0)
77 #define FRAME_REWINDABLE_P(f) (SCM_SMOB_FLAGS(f) & FRAME_F_REWINDABLE)
79 static scm_t_bits tc16_winder
;
80 #define WINDER_P(w) SCM_SMOB_PREDICATE (tc16_winder, (w))
81 #define WINDER_PROC(w) ((void (*)(void *))SCM_SMOB_DATA (w))
82 #define WINDER_DATA(w) ((void *)SCM_SMOB_DATA_2 (w))
84 #define WINDER_F_EXPLICIT (1 << 0)
85 #define WINDER_F_REWIND (1 << 1)
86 #define WINDER_F_MARK (1 << 2)
87 #define WINDER_EXPLICIT_P(w) (SCM_SMOB_FLAGS(w) & WINDER_F_EXPLICIT)
88 #define WINDER_REWIND_P(w) (SCM_SMOB_FLAGS(w) & WINDER_F_REWIND)
89 #define WINDER_MARK_P(w) (SCM_SMOB_FLAGS(w) & WINDER_F_MARK)
92 scm_dynwind_begin (scm_t_dynwind_flags flags
)
95 SCM_NEWSMOB (f
, tc16_frame
, 0);
96 if (flags
& SCM_F_DYNWIND_REWINDABLE
)
97 SCM_SET_SMOB_FLAGS (f
, FRAME_F_REWINDABLE
);
98 scm_i_set_dynwinds (scm_cons (f
, scm_i_dynwinds ()));
102 scm_dynwind_end (void)
106 /* Unwind upto and including the next frame entry. We can only
107 encounter #<winder> entries on the way.
110 winds
= scm_i_dynwinds ();
111 while (scm_is_pair (winds
))
113 SCM entry
= SCM_CAR (winds
);
114 winds
= SCM_CDR (winds
);
116 scm_i_set_dynwinds (winds
);
121 assert (WINDER_P (entry
));
122 if (!WINDER_REWIND_P (entry
) && WINDER_EXPLICIT_P (entry
))
123 WINDER_PROC(entry
) (WINDER_DATA (entry
));
130 scm_dynwind_unwind_handler (void (*proc
) (void *), void *data
,
131 scm_t_wind_flags flags
)
134 SCM_NEWSMOB2 (w
, tc16_winder
, (scm_t_bits
) proc
, (scm_t_bits
) data
);
135 if (flags
& SCM_F_WIND_EXPLICITLY
)
136 SCM_SET_SMOB_FLAGS (w
, WINDER_F_EXPLICIT
);
137 scm_i_set_dynwinds (scm_cons (w
, scm_i_dynwinds ()));
141 scm_dynwind_rewind_handler (void (*proc
) (void *), void *data
,
142 scm_t_wind_flags flags
)
145 SCM_NEWSMOB2 (w
, tc16_winder
, (scm_t_bits
) proc
, (scm_t_bits
) data
);
146 SCM_SET_SMOB_FLAGS (w
, WINDER_F_REWIND
);
147 scm_i_set_dynwinds (scm_cons (w
, scm_i_dynwinds ()));
148 if (flags
& SCM_F_WIND_EXPLICITLY
)
153 scm_dynwind_unwind_handler_with_scm (void (*proc
) (SCM
), SCM data
,
154 scm_t_wind_flags flags
)
157 scm_t_bits fl
= ((flags
&SCM_F_WIND_EXPLICITLY
)? WINDER_F_EXPLICIT
: 0);
158 SCM_NEWSMOB2 (w
, tc16_winder
, (scm_t_bits
) proc
, SCM_UNPACK (data
));
159 SCM_SET_SMOB_FLAGS (w
, fl
| WINDER_F_MARK
);
160 scm_i_set_dynwinds (scm_cons (w
, scm_i_dynwinds ()));
164 scm_dynwind_rewind_handler_with_scm (void (*proc
) (SCM
), SCM data
,
165 scm_t_wind_flags flags
)
168 SCM_NEWSMOB2 (w
, tc16_winder
, (scm_t_bits
) proc
, SCM_UNPACK (data
));
169 SCM_SET_SMOB_FLAGS (w
, WINDER_F_REWIND
| WINDER_F_MARK
);
170 scm_i_set_dynwinds (scm_cons (w
, scm_i_dynwinds ()));
171 if (flags
& SCM_F_WIND_EXPLICITLY
)
176 scm_dynwind_free (void *mem
)
178 scm_dynwind_unwind_handler (free
, mem
, SCM_F_WIND_EXPLICITLY
);
182 SCM_DEFINE (scm_wind_chain
, "wind-chain", 0, 0, 0,
184 "Return the current wind chain. The wind chain contains all\n"
185 "information required by @code{dynamic-wind} to call its\n"
186 "argument thunks when entering/exiting its scope.")
187 #define FUNC_NAME s_scm_wind_chain
189 return scm_i_dynwinds ();
195 scm_swap_bindings (SCM vars
, SCM vals
)
198 while (SCM_NIMP (vals
))
200 tmp
= SCM_VARIABLE_REF (SCM_CAR (vars
));
201 SCM_VARIABLE_SET (SCM_CAR (vars
), SCM_CAR (vals
));
202 SCM_SETCAR (vals
, tmp
);
203 vars
= SCM_CDR (vars
);
204 vals
= SCM_CDR (vals
);
209 scm_dowinds (SCM to
, long delta
)
211 scm_i_dowinds (to
, delta
, NULL
, NULL
);
215 scm_i_dowinds (SCM to
, long delta
, void (*turn_func
) (void *), void *data
)
218 if (scm_is_eq (to
, scm_i_dynwinds ()))
227 scm_i_dowinds (SCM_CDR (to
), 1 + delta
, turn_func
, data
);
228 wind_elt
= SCM_CAR (to
);
230 if (FRAME_P (wind_elt
))
232 if (!FRAME_REWINDABLE_P (wind_elt
))
233 scm_misc_error ("dowinds",
234 "cannot invoke continuation from this context",
237 else if (WINDER_P (wind_elt
))
239 if (WINDER_REWIND_P (wind_elt
))
240 WINDER_PROC (wind_elt
) (WINDER_DATA (wind_elt
));
242 else if (SCM_WITH_FLUIDS_P (wind_elt
))
244 scm_i_swap_with_fluids (wind_elt
,
245 SCM_I_CURRENT_THREAD
->dynamic_state
);
247 else if (SCM_PROMPT_P (wind_elt
))
248 ; /* pass -- see vm_reinstate_partial_continuation */
249 else if (scm_is_pair (wind_elt
))
250 scm_call_0 (SCM_CAR (wind_elt
));
252 /* trash on the wind list */
255 scm_i_set_dynwinds (to
);
262 wind
= scm_i_dynwinds ();
263 wind_elt
= SCM_CAR (wind
);
264 scm_i_set_dynwinds (SCM_CDR (wind
));
266 if (FRAME_P (wind_elt
))
270 else if (WINDER_P (wind_elt
))
272 if (!WINDER_REWIND_P (wind_elt
))
273 WINDER_PROC (wind_elt
) (WINDER_DATA (wind_elt
));
275 else if (SCM_WITH_FLUIDS_P (wind_elt
))
277 scm_i_swap_with_fluids (wind_elt
,
278 SCM_I_CURRENT_THREAD
->dynamic_state
);
280 else if (SCM_PROMPT_P (wind_elt
))
281 ; /* pass -- though we could invalidate the prompt */
282 else if (scm_is_pair (wind_elt
))
283 scm_call_0 (SCM_CDR (wind_elt
));
285 /* trash on the wind list */
289 goto tail
; /* scm_dowinds(to, delta-1); */
296 tc16_frame
= scm_make_smob_type ("frame", 0);
298 tc16_winder
= scm_make_smob_type ("winder", 0);
300 #include "libguile/dynwind.x"