Commit | Line | Data |
---|---|---|
b2feee6b | 1 | /* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 2008, 2010, 2011 Free Software Foundation, Inc. |
0f2d19dd | 2 | * |
73be1d9e | 3 | * This library is free software; you can redistribute it and/or |
53befeb7 NJ |
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. | |
0f2d19dd | 7 | * |
53befeb7 NJ |
8 | * This library is distributed in the hope that it will be useful, but |
9 | * WITHOUT ANY WARRANTY; without even the implied warranty of | |
73be1d9e MV |
10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
11 | * Lesser General Public License for more details. | |
0f2d19dd | 12 | * |
73be1d9e MV |
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 | |
53befeb7 NJ |
15 | * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA |
16 | * 02110-1301 USA | |
73be1d9e | 17 | */ |
1bbd0b84 | 18 | |
1bbd0b84 | 19 | |
0f2d19dd JB |
20 | \f |
21 | ||
dbb605f5 LC |
22 | #ifdef HAVE_CONFIG_H |
23 | # include <config.h> | |
24 | #endif | |
25 | ||
4845bbae MV |
26 | #include <assert.h> |
27 | ||
a0599745 | 28 | #include "libguile/_scm.h" |
2b2746a8 | 29 | #include "libguile/control.h" |
a0599745 MD |
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" | |
0f2d19dd | 35 | |
a0599745 | 36 | #include "libguile/dynwind.h" |
0f2d19dd JB |
37 | \f |
38 | ||
39 | /* {Dynamic wind} | |
b3460a50 MV |
40 | |
41 | Things that can be on the wind list: | |
42 | ||
4845bbae MV |
43 | #<frame> |
44 | #<winder> | |
2b2746a8 AW |
45 | #<with-fluids> |
46 | #<prompt> | |
b3460a50 | 47 | (enter-proc . leave-proc) dynamic-wind |
b3460a50 | 48 | |
b3460a50 | 49 | */ |
0f2d19dd JB |
50 | |
51 | ||
52 | ||
d69531e2 AW |
53 | SCM |
54 | scm_dynamic_wind (SCM in_guard, SCM thunk, SCM out_guard) | |
55 | #define FUNC_NAME "dynamic-wind" | |
0f2d19dd | 56 | { |
9de87eea | 57 | SCM ans, old_winds; |
7888309b | 58 | SCM_ASSERT (scm_is_true (scm_thunk_p (out_guard)), |
1e6808ea | 59 | out_guard, |
1bbd0b84 | 60 | SCM_ARG3, FUNC_NAME); |
fdc28395 | 61 | scm_call_0 (in_guard); |
9de87eea MV |
62 | old_winds = scm_i_dynwinds (); |
63 | scm_i_set_dynwinds (scm_acons (in_guard, out_guard, old_winds)); | |
fdc28395 | 64 | ans = scm_call_0 (thunk); |
9de87eea | 65 | scm_i_set_dynwinds (old_winds); |
fdc28395 | 66 | scm_call_0 (out_guard); |
0f2d19dd JB |
67 | return ans; |
68 | } | |
1bbd0b84 | 69 | #undef FUNC_NAME |
0f2d19dd | 70 | |
4845bbae MV |
71 | /* Frames and winders. */ |
72 | ||
73 | static scm_t_bits tc16_frame; | |
74 | #define FRAME_P(f) SCM_SMOB_PREDICATE (tc16_frame, (f)) | |
75 | ||
f5710d53 MV |
76 | #define FRAME_F_REWINDABLE (1 << 0) |
77 | #define FRAME_REWINDABLE_P(f) (SCM_SMOB_FLAGS(f) & FRAME_F_REWINDABLE) | |
4845bbae MV |
78 | |
79 | static scm_t_bits tc16_winder; | |
14578fa4 | 80 | #define WINDER_P(w) SCM_SMOB_PREDICATE (tc16_winder, (w)) |
f5710d53 MV |
81 | #define WINDER_PROC(w) ((void (*)(void *))SCM_SMOB_DATA (w)) |
82 | #define WINDER_DATA(w) ((void *)SCM_SMOB_DATA_2 (w)) | |
4845bbae | 83 | |
f5710d53 MV |
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) | |
4845bbae MV |
90 | |
91 | void | |
98241dc5 | 92 | scm_dynwind_begin (scm_t_dynwind_flags flags) |
4845bbae MV |
93 | { |
94 | SCM f; | |
f5710d53 | 95 | SCM_NEWSMOB (f, tc16_frame, 0); |
661ae7ab | 96 | if (flags & SCM_F_DYNWIND_REWINDABLE) |
f5710d53 | 97 | SCM_SET_SMOB_FLAGS (f, FRAME_F_REWINDABLE); |
9de87eea | 98 | scm_i_set_dynwinds (scm_cons (f, scm_i_dynwinds ())); |
4845bbae MV |
99 | } |
100 | ||
101 | void | |
661ae7ab | 102 | scm_dynwind_end (void) |
4845bbae | 103 | { |
9de87eea MV |
104 | SCM winds; |
105 | ||
0888de4f MV |
106 | /* Unwind upto and including the next frame entry. We can only |
107 | encounter #<winder> entries on the way. | |
4845bbae MV |
108 | */ |
109 | ||
9de87eea MV |
110 | winds = scm_i_dynwinds (); |
111 | while (scm_is_pair (winds)) | |
4845bbae | 112 | { |
9de87eea MV |
113 | SCM entry = SCM_CAR (winds); |
114 | winds = SCM_CDR (winds); | |
115 | ||
116 | scm_i_set_dynwinds (winds); | |
0888de4f MV |
117 | |
118 | if (FRAME_P (entry)) | |
119 | return; | |
120 | ||
121 | assert (WINDER_P (entry)); | |
122 | if (!WINDER_REWIND_P (entry) && WINDER_EXPLICIT_P (entry)) | |
123 | WINDER_PROC(entry) (WINDER_DATA (entry)); | |
4845bbae MV |
124 | } |
125 | ||
126 | assert (0); | |
127 | } | |
128 | ||
129 | void | |
98241dc5 NJ |
130 | scm_dynwind_unwind_handler (void (*proc) (void *), void *data, |
131 | scm_t_wind_flags flags) | |
4845bbae MV |
132 | { |
133 | SCM w; | |
f5710d53 MV |
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); | |
9de87eea | 137 | scm_i_set_dynwinds (scm_cons (w, scm_i_dynwinds ())); |
4845bbae MV |
138 | } |
139 | ||
140 | void | |
98241dc5 NJ |
141 | scm_dynwind_rewind_handler (void (*proc) (void *), void *data, |
142 | scm_t_wind_flags flags) | |
4845bbae MV |
143 | { |
144 | SCM w; | |
f5710d53 MV |
145 | SCM_NEWSMOB2 (w, tc16_winder, (scm_t_bits) proc, (scm_t_bits) data); |
146 | SCM_SET_SMOB_FLAGS (w, WINDER_F_REWIND); | |
9de87eea | 147 | scm_i_set_dynwinds (scm_cons (w, scm_i_dynwinds ())); |
a520e4f0 MV |
148 | if (flags & SCM_F_WIND_EXPLICITLY) |
149 | proc (data); | |
150 | } | |
151 | ||
152 | void | |
98241dc5 NJ |
153 | scm_dynwind_unwind_handler_with_scm (void (*proc) (SCM), SCM data, |
154 | scm_t_wind_flags flags) | |
a520e4f0 MV |
155 | { |
156 | SCM w; | |
157 | scm_t_bits fl = ((flags&SCM_F_WIND_EXPLICITLY)? WINDER_F_EXPLICIT : 0); | |
f5710d53 MV |
158 | SCM_NEWSMOB2 (w, tc16_winder, (scm_t_bits) proc, SCM_UNPACK (data)); |
159 | SCM_SET_SMOB_FLAGS (w, fl | WINDER_F_MARK); | |
9de87eea | 160 | scm_i_set_dynwinds (scm_cons (w, scm_i_dynwinds ())); |
a520e4f0 MV |
161 | } |
162 | ||
163 | void | |
98241dc5 NJ |
164 | scm_dynwind_rewind_handler_with_scm (void (*proc) (SCM), SCM data, |
165 | scm_t_wind_flags flags) | |
a520e4f0 MV |
166 | { |
167 | SCM w; | |
f5710d53 MV |
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); | |
9de87eea | 170 | scm_i_set_dynwinds (scm_cons (w, scm_i_dynwinds ())); |
a520e4f0 | 171 | if (flags & SCM_F_WIND_EXPLICITLY) |
4845bbae MV |
172 | proc (data); |
173 | } | |
174 | ||
6d5649b7 | 175 | void |
661ae7ab | 176 | scm_dynwind_free (void *mem) |
6d5649b7 | 177 | { |
661ae7ab | 178 | scm_dynwind_unwind_handler (free, mem, SCM_F_WIND_EXPLICITLY); |
6d5649b7 MV |
179 | } |
180 | ||
c2654ef0 | 181 | #ifdef GUILE_DEBUG |
a1ec6916 | 182 | SCM_DEFINE (scm_wind_chain, "wind-chain", 0, 0, 0, |
1bbd0b84 | 183 | (), |
156149ad MG |
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.") | |
1bbd0b84 | 187 | #define FUNC_NAME s_scm_wind_chain |
c2654ef0 | 188 | { |
9de87eea | 189 | return scm_i_dynwinds (); |
c2654ef0 | 190 | } |
1bbd0b84 | 191 | #undef FUNC_NAME |
c2654ef0 MD |
192 | #endif |
193 | ||
2e171178 | 194 | void |
904a077d | 195 | scm_swap_bindings (SCM vars, SCM vals) |
6778caf9 MD |
196 | { |
197 | SCM tmp; | |
198 | while (SCM_NIMP (vals)) | |
199 | { | |
904a077d MV |
200 | tmp = SCM_VARIABLE_REF (SCM_CAR (vars)); |
201 | SCM_VARIABLE_SET (SCM_CAR (vars), SCM_CAR (vals)); | |
6778caf9 | 202 | SCM_SETCAR (vals, tmp); |
904a077d | 203 | vars = SCM_CDR (vars); |
6778caf9 MD |
204 | vals = SCM_CDR (vals); |
205 | } | |
206 | } | |
c2654ef0 | 207 | |
4845bbae | 208 | void |
c014a02e | 209 | scm_dowinds (SCM to, long delta) |
4845bbae | 210 | { |
14578fa4 | 211 | scm_i_dowinds (to, delta, NULL, NULL); |
4845bbae MV |
212 | } |
213 | ||
214 | void | |
14578fa4 | 215 | scm_i_dowinds (SCM to, long delta, void (*turn_func) (void *), void *data) |
0f2d19dd JB |
216 | { |
217 | tail: | |
9de87eea | 218 | if (scm_is_eq (to, scm_i_dynwinds ())) |
4845bbae MV |
219 | { |
220 | if (turn_func) | |
221 | turn_func (data); | |
222 | } | |
1be6b49c | 223 | else if (delta < 0) |
0f2d19dd JB |
224 | { |
225 | SCM wind_elt; | |
0f2d19dd | 226 | |
14578fa4 | 227 | scm_i_dowinds (SCM_CDR (to), 1 + delta, turn_func, data); |
0f2d19dd | 228 | wind_elt = SCM_CAR (to); |
4845bbae | 229 | |
928e0f42 | 230 | if (FRAME_P (wind_elt)) |
0f2d19dd | 231 | { |
928e0f42 MV |
232 | if (!FRAME_REWINDABLE_P (wind_elt)) |
233 | scm_misc_error ("dowinds", | |
234 | "cannot invoke continuation from this context", | |
235 | SCM_EOL); | |
236 | } | |
237 | else if (WINDER_P (wind_elt)) | |
238 | { | |
239 | if (WINDER_REWIND_P (wind_elt)) | |
240 | WINDER_PROC (wind_elt) (WINDER_DATA (wind_elt)); | |
0f2d19dd | 241 | } |
bb0229b5 AW |
242 | else if (SCM_WITH_FLUIDS_P (wind_elt)) |
243 | { | |
244 | scm_i_swap_with_fluids (wind_elt, | |
245 | SCM_I_CURRENT_THREAD->dynamic_state); | |
246 | } | |
2b2746a8 AW |
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)); | |
0f2d19dd | 251 | else |
2b2746a8 AW |
252 | /* trash on the wind list */ |
253 | abort (); | |
928e0f42 | 254 | |
9de87eea | 255 | scm_i_set_dynwinds (to); |
0f2d19dd JB |
256 | } |
257 | else | |
258 | { | |
9de87eea | 259 | SCM wind; |
0f2d19dd | 260 | SCM wind_elt; |
0f2d19dd | 261 | |
9de87eea MV |
262 | wind = scm_i_dynwinds (); |
263 | wind_elt = SCM_CAR (wind); | |
264 | scm_i_set_dynwinds (SCM_CDR (wind)); | |
4845bbae | 265 | |
928e0f42 | 266 | if (FRAME_P (wind_elt)) |
0f2d19dd | 267 | { |
928e0f42 MV |
268 | /* Nothing to do. */ |
269 | } | |
270 | else if (WINDER_P (wind_elt)) | |
271 | { | |
272 | if (!WINDER_REWIND_P (wind_elt)) | |
273 | WINDER_PROC (wind_elt) (WINDER_DATA (wind_elt)); | |
0f2d19dd | 274 | } |
bb0229b5 AW |
275 | else if (SCM_WITH_FLUIDS_P (wind_elt)) |
276 | { | |
277 | scm_i_swap_with_fluids (wind_elt, | |
278 | SCM_I_CURRENT_THREAD->dynamic_state); | |
279 | } | |
2b2746a8 AW |
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)); | |
0f2d19dd | 284 | else |
2b2746a8 AW |
285 | /* trash on the wind list */ |
286 | abort (); | |
928e0f42 | 287 | |
0f2d19dd JB |
288 | delta--; |
289 | goto tail; /* scm_dowinds(to, delta-1); */ | |
290 | } | |
291 | } | |
292 | ||
0f2d19dd JB |
293 | void |
294 | scm_init_dynwind () | |
0f2d19dd | 295 | { |
4845bbae | 296 | tc16_frame = scm_make_smob_type ("frame", 0); |
4845bbae MV |
297 | |
298 | tc16_winder = scm_make_smob_type ("winder", 0); | |
299 | ||
a0599745 | 300 | #include "libguile/dynwind.x" |
0f2d19dd | 301 | } |
89e00824 ML |
302 | |
303 | /* | |
304 | Local Variables: | |
305 | c-file-style: "gnu" | |
306 | End: | |
307 | */ |