1 /* Copyright (C) 1996,1997,2000,2001, 2004, 2006, 2007, 2008, 2009, 2010,
2 * 2011, 2012, 2013, 2017 Free Software Foundation, Inc.
3 *
4 * This library is free software; you can redistribute it and/or
5 * modify it under the terms of the GNU Lesser General Public License
6 * as published by the Free Software Foundation; either version 3 of
7 * the License, or (at your option) any later version.
8 *
9 * This library is distributed in the hope that it will be useful, but
10 * WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 * Lesser General Public License for more details.
13 *
14 * You should have received a copy of the GNU Lesser General Public
15 * License along with this library; if not, write to the Free Software
16 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
17 * 02110-1301 USA
18 */
19
20 #ifdef HAVE_CONFIG_H
21 # include <config.h>
22 #endif
23
24 #include <stdio.h>
25 #include <string.h>
26
27 #include "libguile/_scm.h"
28 #include "libguile/atomics-internal.h"
29 #include "libguile/cache-internal.h"
30 #include "libguile/print.h"
31 #include "libguile/dynwind.h"
32 #include "libguile/fluids.h"
33 #include "libguile/alist.h"
34 #include "libguile/eval.h"
35 #include "libguile/ports.h"
36 #include "libguile/deprecation.h"
37 #include "libguile/validate.h"
38 #include "libguile/bdw-gc.h"
39
40 /* A dynamic state associates fluids with values. There are two
41 representations of a dynamic state in Guile: the active
42 representation that is part of each thread, and a frozen
43 representation that can live in Scheme land as a value.
44
45 The active dynamic state has two parts: a locals cache, and a values
46 table. The locals cache stores fluid values that have been recently
47 referenced or set. If a value isn't in the locals cache, Guile then
48 looks for it in the values table, which is a weak-key hash table.
49 Otherwise Guile falls back to the default value of the fluid. In any
50 case, the value is recorded in the locals cache. Likewise setting a
51 fluid's value simply inserts that association into the locals cache.
52
53 The locals cache is not large, so adding an entry to it might evict
54 some other entry. In that case the entry gets flushed to the values
55 table.
56
57 The values table begins as being inherited from the parent dynamic
58 state, and represents a capture of the fluid values at a point in
59 time. A dynamic state records when its values table might be
60 referenced by other dynamic states. If it is aliased, then any
61 update to that table has to start by making a fresh local copy to
62 work on.
63
64 There are two interesting constraints on dynamic states, besides
65 speed. One is that they should hold onto their fluid-value
66 associations weakly: they shouldn't keep fluids alive indefinitely,
67 and if a fluid goes away, its value should become collectible too.
68 This is why the values table is a weak table; it makes access
69 somewhat slower, but this is mitigated by the cache. The cache
70 itself holds onto fluids and values strongly, but if there are more
71 than 8 fluids in use by a dynamic state, this won't be a problem.
72
73 The other interesting constraint is memory usage: you don't want a
74 program with M fluids and N dynamic states to consume N*M memory.
75 Guile associates each thread with a dynamic state, which itself isn't
76 that bad as there are relatively few threads in a program. The
77 problem comes in with "fibers", lightweight user-space threads that
78 can be allocated in the millions. Here you want new fibers to
79 inherit the dynamic state from the fiber that created them, but you
80 really need to limit memory overheads. For reference, in late 2016,
81 non-dynamic-state memory overhead per fiber in one user-space library
82 is around 500 bytes, in a simple "all fibers try to send a message on
83 one channel" test case.
84
85 For this reason the frozen representation of dynamic states is the
86 probably-shared values table at the end of a list of fluid-value
87 pairs, representing entries from the locals cache that differ from
88 the values table. This keeps per-dynamic-state memory usage in
89 check. A family of fibers that uses the same 3 or 4 fluids probably
90 won't ever have to allocate a new values table. Ideally the values
91 table could share more state, as in an immutable weak array-mapped
92 hash trie or something, but we don't have such a data structure. */
93
94 #define FLUID_F_THREAD_LOCAL 0x100
95 #define SCM_I_FLUID_THREAD_LOCAL_P(x) \
96 (SCM_CELL_WORD_0 (x) & FLUID_F_THREAD_LOCAL)
97
98 static inline int
is_dynamic_state(SCM x)99 is_dynamic_state (SCM x)
100 {
101 return SCM_HAS_TYP7 (x, scm_tc7_dynamic_state);
102 }
103
104 static inline SCM
get_dynamic_state(SCM dynamic_state)105 get_dynamic_state (SCM dynamic_state)
106 {
107 return SCM_CELL_OBJECT_1 (dynamic_state);
108 }
109
110 /* Precondition: It's OK to throw away any unflushed data in the current
111 cache. */
112 static inline void
restore_dynamic_state(SCM saved,scm_t_dynamic_state * state)113 restore_dynamic_state (SCM saved, scm_t_dynamic_state *state)
114 {
115 int slot;
116 for (slot = SCM_CACHE_SIZE - 1; slot >= 0; slot--)
117 {
118 struct scm_cache_entry *entry = &state->cache.entries[slot];
119 if (scm_is_pair (saved))
120 {
121 entry->key = SCM_UNPACK (SCM_CAAR (saved));
122 entry->value = SCM_UNPACK (SCM_CDAR (saved));
123 saved = scm_cdr (saved);
124 }
125 else
126 entry->key = entry->value = 0;
127 }
128 state->values = saved;
129 state->has_aliased_values = 1;
130 }
131
132 static inline SCM
save_dynamic_state(scm_t_dynamic_state * state)133 save_dynamic_state (scm_t_dynamic_state *state)
134 {
135 int slot;
136 SCM saved = state->values;
137 for (slot = 0; slot < SCM_CACHE_SIZE; slot++)
138 {
139 struct scm_cache_entry *entry = &state->cache.entries[slot];
140 SCM key = SCM_PACK (entry->key);
141 SCM value = SCM_PACK (entry->value);
142
143 if (!entry->key)
144 continue;
145 if (SCM_I_FLUID_THREAD_LOCAL_P (key))
146 {
147 /* Because we don't include unflushed thread-local fluids in
148 the result, we need to flush them to the table so that
149 restore_dynamic_state can just throw away the current
150 cache. */
151 scm_hashq_set_x (state->thread_local_values, key, value);
152 }
153 else if (!scm_is_eq (scm_weak_table_refq (state->values, key,
154 SCM_UNDEFINED),
155 value))
156 {
157 if (state->has_aliased_values)
158 saved = scm_acons (key, value, saved);
159 else
160 scm_weak_table_putq_x (state->values, key, value);
161 }
162 }
163 state->has_aliased_values = 1;
164 return saved;
165 }
166
167 static SCM
saved_dynamic_state_ref(SCM saved,SCM fluid,SCM dflt)168 saved_dynamic_state_ref (SCM saved, SCM fluid, SCM dflt)
169 {
170 for (; scm_is_pair (saved); saved = SCM_CDR (saved))
171 if (scm_is_eq (SCM_CAAR (saved), fluid))
172 return SCM_CDAR (saved);
173
174 return scm_weak_table_refq (saved, fluid, dflt);
175 }
176
177 static SCM
add_entry(void * data,SCM k,SCM v,SCM result)178 add_entry (void *data, SCM k, SCM v, SCM result)
179 {
180 scm_weak_table_putq_x (result, k, v);
181 return result;
182 }
183
184 static SCM
copy_value_table(SCM tab)185 copy_value_table (SCM tab)
186 {
187 SCM ret = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY);
188 return scm_c_weak_table_fold (add_entry, NULL, ret, tab);
189 }
190
191
192
193
194 void
scm_i_fluid_print(SCM exp,SCM port,scm_print_state * pstate SCM_UNUSED)195 scm_i_fluid_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
196 {
197 if (SCM_I_FLUID_THREAD_LOCAL_P (exp))
198 scm_puts ("#<thread-local-fluid ", port);
199 else
200 scm_puts ("#<fluid ", port);
201 scm_intprint (SCM_UNPACK (exp), 16, port);
202 scm_putc ('>', port);
203 }
204
205 void
scm_i_dynamic_state_print(SCM exp,SCM port,scm_print_state * pstate SCM_UNUSED)206 scm_i_dynamic_state_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
207 {
208 scm_puts ("#<dynamic-state ", port);
209 scm_intprint (SCM_UNPACK (exp), 16, port);
210 scm_putc ('>', port);
211 }
212
213
214
215
216 #define SCM_I_FLUID_DEFAULT(x) (SCM_CELL_OBJECT_1 (x))
217
218 static SCM
new_fluid(SCM init,scm_t_bits flags)219 new_fluid (SCM init, scm_t_bits flags)
220 {
221 return scm_cell (scm_tc7_fluid | flags, SCM_UNPACK (init));
222 }
223
224 SCM
scm_make_fluid(void)225 scm_make_fluid (void)
226 {
227 return new_fluid (SCM_BOOL_F, 0);
228 }
229
230 SCM_DEFINE (scm_make_fluid_with_default, "make-fluid", 0, 1, 0,
231 (SCM dflt),
232 "Return a newly created fluid, whose initial value is @var{dflt},\n"
233 "or @code{#f} if @var{dflt} is not given.\n"
234 "Fluids are objects that can hold one\n"
235 "value per dynamic state. That is, modifications to this value are\n"
236 "only visible to code that executes with the same dynamic state as\n"
237 "the modifying code. When a new dynamic state is constructed, it\n"
238 "inherits the values from its parent. Because each thread normally executes\n"
239 "with its own dynamic state, you can use fluids for thread local storage.")
240 #define FUNC_NAME s_scm_make_fluid_with_default
241 {
242 return new_fluid (SCM_UNBNDP (dflt) ? SCM_BOOL_F : dflt, 0);
243 }
244 #undef FUNC_NAME
245
246 SCM_DEFINE (scm_make_unbound_fluid, "make-unbound-fluid", 0, 0, 0,
247 (),
248 "Make a fluid that is initially unbound.")
249 #define FUNC_NAME s_scm_make_unbound_fluid
250 {
251 return new_fluid (SCM_UNDEFINED, 0);
252 }
253 #undef FUNC_NAME
254
255 SCM_DEFINE (scm_make_thread_local_fluid, "make-thread-local-fluid", 0, 1, 0,
256 (SCM dflt),
257 "Return a newly created fluid, whose initial value is @var{dflt},\n"
258 "or @code{#f} if @var{dflt} is not given. Unlike fluids made\n"
259 "with @code{make-fluid}, thread local fluids are not captured\n"
260 "by @code{make-dynamic-state}. Similarly, a newly spawned\n"
261 "child thread does not inherit thread-local fluid values from\n"
262 "the parent thread.")
263 #define FUNC_NAME s_scm_make_thread_local_fluid
264 {
265 return new_fluid (SCM_UNBNDP (dflt) ? SCM_BOOL_F : dflt,
266 FLUID_F_THREAD_LOCAL);
267 }
268 #undef FUNC_NAME
269
270 SCM_DEFINE (scm_fluid_p, "fluid?", 1, 0, 0,
271 (SCM obj),
272 "Return @code{#t} iff @var{obj} is a fluid; otherwise, return\n"
273 "@code{#f}.")
274 #define FUNC_NAME s_scm_fluid_p
275 {
276 return scm_from_bool (SCM_FLUID_P (obj));
277 }
278 #undef FUNC_NAME
279
280 SCM_DEFINE (scm_fluid_thread_local_p, "fluid-thread-local?", 1, 0, 0,
281 (SCM fluid),
282 "Return @code{#t} if the fluid @var{fluid} is is thread local,\n"
283 "or @code{#f} otherwise.")
284 #define FUNC_NAME s_scm_fluid_thread_local_p
285 {
286 SCM_VALIDATE_FLUID (1, fluid);
287 return scm_from_bool (SCM_I_FLUID_THREAD_LOCAL_P (fluid));
288 }
289 #undef FUNC_NAME
290
291 int
scm_is_fluid(SCM obj)292 scm_is_fluid (SCM obj)
293 {
294 return SCM_FLUID_P (obj);
295 }
296
297 static void
fluid_set_x(scm_t_dynamic_state * dynamic_state,SCM fluid,SCM value)298 fluid_set_x (scm_t_dynamic_state *dynamic_state, SCM fluid, SCM value)
299 {
300 struct scm_cache_entry *entry;
301 struct scm_cache_entry evicted = { 0, 0 };
302
303 entry = scm_cache_lookup (&dynamic_state->cache, fluid);
304 if (scm_is_eq (SCM_PACK (entry->key), fluid))
305 {
306 entry->value = SCM_UNPACK (value);
307 return;
308 }
309
310 scm_cache_insert (&dynamic_state->cache, fluid, value, &evicted);
311
312 if (evicted.key != 0)
313 {
314 fluid = SCM_PACK (evicted.key);
315 value = SCM_PACK (evicted.value);
316
317 if (SCM_I_FLUID_THREAD_LOCAL_P (fluid))
318 {
319 scm_hashq_set_x (dynamic_state->thread_local_values, fluid, value);
320 return;
321 }
322
323 if (dynamic_state->has_aliased_values)
324 {
325 if (scm_is_eq (scm_weak_table_refq (dynamic_state->values,
326 fluid, SCM_UNDEFINED),
327 value))
328 return;
329 dynamic_state->values = copy_value_table (dynamic_state->values);
330 dynamic_state->has_aliased_values = 0;
331 }
332
333 scm_weak_table_putq_x (dynamic_state->values, fluid, value);
334 }
335 }
336
337 /* Return value can be SCM_UNDEFINED; caller checks. */
338 static SCM
fluid_ref(scm_t_dynamic_state * dynamic_state,SCM fluid)339 fluid_ref (scm_t_dynamic_state *dynamic_state, SCM fluid)
340 {
341 SCM val;
342 struct scm_cache_entry *entry;
343
344 entry = scm_cache_lookup (&dynamic_state->cache, fluid);
345 if (scm_is_eq (SCM_PACK (entry->key), fluid))
346 return SCM_PACK (entry->value);
347
348 if (SCM_I_FLUID_THREAD_LOCAL_P (fluid))
349 val = scm_hashq_ref (dynamic_state->thread_local_values, fluid,
350 SCM_I_FLUID_DEFAULT (fluid));
351 else
352 val = scm_weak_table_refq (dynamic_state->values, fluid,
353 SCM_I_FLUID_DEFAULT (fluid));
354
355 /* Cache this lookup. */
356 fluid_set_x (dynamic_state, fluid, val);
357
358 return val;
359 }
360
361 SCM_DEFINE (scm_fluid_ref, "fluid-ref", 1, 0, 0,
362 (SCM fluid),
363 "Return the value associated with @var{fluid} in the current\n"
364 "dynamic root. If @var{fluid} has not been set, then return\n"
365 "its default value.")
366 #define FUNC_NAME s_scm_fluid_ref
367 {
368 SCM ret;
369 SCM_VALIDATE_FLUID (1, fluid);
370 ret = fluid_ref (SCM_I_CURRENT_THREAD->dynamic_state, fluid);
371 if (SCM_UNBNDP (ret))
372 scm_misc_error ("fluid-ref", "unbound fluid: ~S", scm_list_1 (fluid));
373 return ret;
374 }
375 #undef FUNC_NAME
376
377 SCM_DEFINE (scm_fluid_ref_star, "fluid-ref*", 2, 0, 0,
378 (SCM fluid, SCM depth),
379 "Return the @var{depth}th oldest value associated with\n"
380 "@var{fluid} in the current thread. If @var{depth} equals\n"
381 "or exceeds the number of values that have been assigned to\n"
382 "@var{fluid}, return the default value of the fluid.")
383 #define FUNC_NAME s_scm_fluid_ref_star
384 {
385 SCM ret;
386 size_t c_depth;
387
388 SCM_VALIDATE_FLUID (1, fluid);
389 c_depth = SCM_NUM2SIZE (2, depth);
390
391 /* Because this function is called to look up the current exception
392 handler and this can happen in an out-of-memory situation, we avoid
393 cache flushes to the weak table which might cause allocation of a
394 disappearing link. */
395 if (c_depth == 0)
396 {
397 scm_t_dynamic_state *dynamic_state = SCM_I_CURRENT_THREAD->dynamic_state;
398 struct scm_cache_entry *entry;
399
400 entry = scm_cache_lookup (&dynamic_state->cache, fluid);
401 if (scm_is_eq (SCM_PACK (entry->key), fluid))
402 ret = SCM_PACK (entry->value);
403 else
404 {
405 if (SCM_I_FLUID_THREAD_LOCAL_P (fluid))
406 ret = scm_hashq_ref (dynamic_state->thread_local_values, fluid,
407 SCM_UNDEFINED);
408 else
409 ret = scm_weak_table_refq (dynamic_state->values, fluid,
410 SCM_UNDEFINED);
411
412 if (SCM_UNBNDP (ret))
413 ret = SCM_I_FLUID_DEFAULT (fluid);
414
415 /* Don't cache the lookup. */
416 }
417 }
418 else
419 ret = scm_dynstack_find_old_fluid_value (&SCM_I_CURRENT_THREAD->dynstack,
420 fluid, c_depth - 1,
421 SCM_I_FLUID_DEFAULT (fluid));
422
423 if (SCM_UNBNDP (ret))
424 scm_misc_error ("fluid-ref*", "unbound fluid: ~S", scm_list_1 (fluid));
425 return ret;
426 }
427 #undef FUNC_NAME
428
429 SCM_DEFINE (scm_fluid_set_x, "fluid-set!", 2, 0, 0,
430 (SCM fluid, SCM value),
431 "Set the value associated with @var{fluid} in the current dynamic root.")
432 #define FUNC_NAME s_scm_fluid_set_x
433 {
434 SCM_VALIDATE_FLUID (1, fluid);
435 fluid_set_x (SCM_I_CURRENT_THREAD->dynamic_state, fluid, value);
436 return SCM_UNSPECIFIED;
437 }
438 #undef FUNC_NAME
439
440 SCM_DEFINE (scm_fluid_unset_x, "fluid-unset!", 1, 0, 0,
441 (SCM fluid),
442 "Unset the value associated with @var{fluid}.")
443 #define FUNC_NAME s_scm_fluid_unset_x
444 {
445 /* FIXME: really unset the default value, too? The current test
446 suite demands it, but I would prefer not to. */
447 SCM_VALIDATE_FLUID (1, fluid);
448 SCM_SET_CELL_OBJECT_1 (fluid, SCM_UNDEFINED);
449 fluid_set_x (SCM_I_CURRENT_THREAD->dynamic_state, fluid, SCM_UNDEFINED);
450 return SCM_UNSPECIFIED;
451 }
452 #undef FUNC_NAME
453
454 SCM_DEFINE (scm_fluid_bound_p, "fluid-bound?", 1, 0, 0,
455 (SCM fluid),
456 "Return @code{#t} iff @var{fluid} is bound to a value.\n"
457 "Throw an error if @var{fluid} is not a fluid.")
458 #define FUNC_NAME s_scm_fluid_bound_p
459 {
460 SCM val;
461 SCM_VALIDATE_FLUID (1, fluid);
462 val = fluid_ref (SCM_I_CURRENT_THREAD->dynamic_state, fluid);
463 return scm_from_bool (! (SCM_UNBNDP (val)));
464 }
465 #undef FUNC_NAME
466
467 static SCM
apply_thunk(void * thunk)468 apply_thunk (void *thunk)
469 {
470 return scm_call_0 (SCM_PACK (thunk));
471 }
472
473 void
scm_swap_fluid(SCM fluid,SCM value_box,scm_t_dynamic_state * dynstate)474 scm_swap_fluid (SCM fluid, SCM value_box, scm_t_dynamic_state *dynstate)
475 {
476 SCM val = fluid_ref (dynstate, fluid);
477 fluid_set_x (dynstate, fluid, SCM_VARIABLE_REF (value_box));
478 SCM_VARIABLE_SET (value_box, val);
479 }
480
481 SCM_DEFINE (scm_with_fluids, "with-fluids*", 3, 0, 0,
482 (SCM fluids, SCM values, SCM thunk),
483 "Set @var{fluids} to @var{values} temporary, and call @var{thunk}.\n"
484 "@var{fluids} must be a list of fluids and @var{values} must be the same\n"
485 "number of their values to be applied. Each substitution is done\n"
486 "one after another. @var{thunk} must be a procedure with no argument.")
487 #define FUNC_NAME s_scm_with_fluids
488 {
489 return scm_c_with_fluids (fluids, values,
490 apply_thunk, (void *) SCM_UNPACK (thunk));
491 }
492 #undef FUNC_NAME
493
494 SCM
scm_c_with_fluids(SCM fluids,SCM values,SCM (* cproc)(),void * cdata)495 scm_c_with_fluids (SCM fluids, SCM values, SCM (*cproc) (), void *cdata)
496 #define FUNC_NAME "scm_c_with_fluids"
497 {
498 SCM ans;
499 long flen, vlen, i;
500 scm_i_thread *thread = SCM_I_CURRENT_THREAD;
501
502 SCM_VALIDATE_LIST_COPYLEN (1, fluids, flen);
503 SCM_VALIDATE_LIST_COPYLEN (2, values, vlen);
504 if (flen != vlen)
505 scm_out_of_range (s_scm_with_fluids, values);
506
507 for (i = 0; i < flen; i++)
508 {
509 scm_dynstack_push_fluid (&thread->dynstack,
510 SCM_CAR (fluids), SCM_CAR (values),
511 thread->dynamic_state);
512 fluids = SCM_CDR (fluids);
513 values = SCM_CDR (values);
514 }
515
516 ans = cproc (cdata);
517
518 for (i = 0; i < flen; i++)
519 scm_dynstack_unwind_fluid (&thread->dynstack, thread->dynamic_state);
520
521 return ans;
522 }
523 #undef FUNC_NAME
524
525 SCM
scm_with_fluid(SCM fluid,SCM value,SCM thunk)526 scm_with_fluid (SCM fluid, SCM value, SCM thunk)
527 {
528 return scm_c_with_fluid (fluid, value,
529 apply_thunk, (void *) SCM_UNPACK (thunk));
530 }
531
532 SCM
scm_c_with_fluid(SCM fluid,SCM value,SCM (* cproc)(),void * cdata)533 scm_c_with_fluid (SCM fluid, SCM value, SCM (*cproc) (), void *cdata)
534 #define FUNC_NAME "scm_c_with_fluid"
535 {
536 SCM ans;
537 scm_i_thread *thread = SCM_I_CURRENT_THREAD;
538
539 scm_dynstack_push_fluid (&thread->dynstack, fluid, value,
540 thread->dynamic_state);
541 ans = cproc (cdata);
542 scm_dynstack_unwind_fluid (&thread->dynstack, thread->dynamic_state);
543
544 return ans;
545 }
546 #undef FUNC_NAME
547
548 static void
swap_fluid(SCM data)549 swap_fluid (SCM data)
550 {
551 scm_t_dynamic_state *dynstate = SCM_I_CURRENT_THREAD->dynamic_state;
552 SCM f = SCM_CAR (data);
553 SCM t = fluid_ref (dynstate, f);
554 fluid_set_x (dynstate, f, SCM_CDR (data));
555 SCM_SETCDR (data, t);
556 }
557
558 void
scm_dynwind_fluid(SCM fluid,SCM value)559 scm_dynwind_fluid (SCM fluid, SCM value)
560 {
561 SCM data = scm_cons (fluid, value);
562 scm_dynwind_rewind_handler_with_scm (swap_fluid, data, SCM_F_WIND_EXPLICITLY);
563 scm_dynwind_unwind_handler_with_scm (swap_fluid, data, SCM_F_WIND_EXPLICITLY);
564 }
565
566 SCM
scm_i_make_initial_dynamic_state(void)567 scm_i_make_initial_dynamic_state (void)
568 {
569 return scm_cell (scm_tc7_dynamic_state,
570 SCM_UNPACK (scm_c_make_weak_table
571 (0, SCM_WEAK_TABLE_KIND_KEY)));
572 }
573
574 SCM_DEFINE (scm_dynamic_state_p, "dynamic-state?", 1, 0, 0,
575 (SCM obj),
576 "Return @code{#t} if @var{obj} is a dynamic state object;\n"
577 "return @code{#f} otherwise")
578 #define FUNC_NAME s_scm_dynamic_state_p
579 {
580 return scm_from_bool (is_dynamic_state (obj));
581 }
582 #undef FUNC_NAME
583
584 int
scm_is_dynamic_state(SCM obj)585 scm_is_dynamic_state (SCM obj)
586 {
587 return is_dynamic_state (obj);
588 }
589
590 SCM_DEFINE (scm_current_dynamic_state, "current-dynamic-state", 0, 0, 0,
591 (),
592 "Return a snapshot of the current fluid-value associations\n"
593 "as a fresh dynamic state object.")
594 #define FUNC_NAME s_scm_current_dynamic_state
595 {
596 struct scm_dynamic_state *state = SCM_I_CURRENT_THREAD->dynamic_state;
597 return scm_cell (scm_tc7_dynamic_state,
598 SCM_UNPACK (save_dynamic_state (state)));
599 }
600 #undef FUNC_NAME
601
602 SCM_DEFINE (scm_set_current_dynamic_state, "set-current-dynamic-state", 1,0,0,
603 (SCM state),
604 "Set the current dynamic state object to @var{state}\n"
605 "and return the previous current dynamic state object.")
606 #define FUNC_NAME s_scm_set_current_dynamic_state
607 {
608 scm_i_thread *t = SCM_I_CURRENT_THREAD;
609 SCM old = scm_current_dynamic_state ();
610 SCM_ASSERT (is_dynamic_state (state), state, SCM_ARG1, FUNC_NAME);
611 restore_dynamic_state (get_dynamic_state (state), t->dynamic_state);
612 return old;
613 }
614 #undef FUNC_NAME
615
616 SCM
scm_dynamic_state_ref(SCM state,SCM fluid,SCM dflt)617 scm_dynamic_state_ref (SCM state, SCM fluid, SCM dflt)
618 {
619 SCM_ASSERT (is_dynamic_state (state), state, SCM_ARG1,
620 "dynamic-state-ref");
621 return saved_dynamic_state_ref (get_dynamic_state (state), fluid, dflt);
622 }
623
624 static void
swap_dynamic_state(SCM loc)625 swap_dynamic_state (SCM loc)
626 {
627 SCM_SETCAR (loc, scm_set_current_dynamic_state (SCM_CAR (loc)));
628 }
629
630 void
scm_dynwind_current_dynamic_state(SCM state)631 scm_dynwind_current_dynamic_state (SCM state)
632 {
633 SCM loc = scm_cons (state, SCM_EOL);
634 SCM_ASSERT (is_dynamic_state (state), state, SCM_ARG1, NULL);
635 scm_dynwind_rewind_handler_with_scm (swap_dynamic_state, loc,
636 SCM_F_WIND_EXPLICITLY);
637 scm_dynwind_unwind_handler_with_scm (swap_dynamic_state, loc,
638 SCM_F_WIND_EXPLICITLY);
639 }
640
641 void *
scm_c_with_dynamic_state(SCM state,void * (* func)(void *),void * data)642 scm_c_with_dynamic_state (SCM state, void *(*func)(void *), void *data)
643 {
644 void *result;
645 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
646 scm_dynwind_current_dynamic_state (state);
647 result = func (data);
648 scm_dynwind_end ();
649 return result;
650 }
651
652 SCM_DEFINE (scm_with_dynamic_state, "with-dynamic-state", 2, 0, 0,
653 (SCM state, SCM proc),
654 "Call @var{proc} while @var{state} is the current dynamic\n"
655 "state object.")
656 #define FUNC_NAME s_scm_with_dynamic_state
657 {
658 SCM result;
659 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
660 scm_dynwind_current_dynamic_state (state);
661 result = scm_call_0 (proc);
662 scm_dynwind_end ();
663 return result;
664 }
665 #undef FUNC_NAME
666
667
668 void
scm_init_fluids()669 scm_init_fluids ()
670 {
671 #include "libguile/fluids.x"
672 }
673
674 /*
675 Local Variables:
676 c-file-style: "gnu"
677 End:
678 */
679