1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
|
/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2004 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
* License as published by the Free Software Foundation; either
* version 2.1 of the License, or (at your option) any later version.
*
* This library is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*/
#if HAVE_CONFIG_H
# include <config.h>
#endif
#include <signal.h>
#include "libguile/_scm.h"
#include "libguile/eval.h"
#include "libguile/throw.h"
#include "libguile/root.h"
#include "libguile/smob.h"
#include "libguile/lang.h"
#include "libguile/dynwind.h"
#include "libguile/deprecation.h"
#include "libguile/validate.h"
#include "libguile/async.h"
#ifdef HAVE_STRING_H
#include <string.h>
#endif
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif
/* {Asynchronous Events}
*
* There are two kinds of asyncs: system asyncs and user asyncs. The
* two kinds have some concepts in commen but work slightly
* differently and are not interchangeable.
*
* System asyncs are used to run arbitrary code at the next safe point
* in a specified thread. You can use them to trigger execution of
* Scheme code from signal handlers or to interrupt a thread, for
* example.
*
* Each thread has a list of 'activated asyncs', which is a normal
* Scheme list of procedures with zero arguments. When a thread
* executes a SCM_ASYNC_TICK statement (which is included in
* SCM_TICK), it will call all procedures on this list.
*
* Also, a thread will wake up when a procedure is added to its list
* of active asyncs and call them. After that, it will go to sleep
* again. (Not implemented yet.)
*
*
* User asyncs are a little data structure that consists of a
* procedure of zero arguments and a mark. There are functions for
* setting the mark of a user async and for calling all procedures of
* marked asyncs in a given list. Nothing you couldn't quickly
* implement yourself.
*/
/* User asyncs. */
static scm_t_bits tc16_async;
/* cmm: this has SCM_ prefix because SCM_MAKE_VALIDATE expects it.
this is ugly. */
#define SCM_ASYNCP(X) SCM_TYP16_PREDICATE (tc16_async, X)
#define VALIDATE_ASYNC(pos, a) SCM_MAKE_VALIDATE_MSG(pos, a, ASYNCP, "user async")
#define ASYNC_GOT_IT(X) (SCM_CELL_WORD_0 (X) >> 16)
#define SET_ASYNC_GOT_IT(X, V) (SCM_SET_CELL_WORD_0 ((X), SCM_TYP16 (X) | ((V) << 16)))
#define ASYNC_THUNK(X) SCM_CELL_OBJECT_1 (X)
static SCM
async_gc_mark (SCM obj)
{
return ASYNC_THUNK (obj);
}
SCM_DEFINE (scm_async, "async", 1, 0, 0,
(SCM thunk),
"Create a new async for the procedure @var{thunk}.")
#define FUNC_NAME s_scm_async
{
SCM_RETURN_NEWSMOB (tc16_async, SCM_UNPACK (thunk));
}
#undef FUNC_NAME
SCM_DEFINE (scm_async_mark, "async-mark", 1, 0, 0,
(SCM a),
"Mark the async @var{a} for future execution.")
#define FUNC_NAME s_scm_async_mark
{
VALIDATE_ASYNC (1, a);
SET_ASYNC_GOT_IT (a, 1);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_DEFINE (scm_run_asyncs, "run-asyncs", 1, 0, 0,
(SCM list_of_a),
"Execute all thunks from the asyncs of the list @var{list_of_a}.")
#define FUNC_NAME s_scm_run_asyncs
{
while (! SCM_NULL_OR_NIL_P (list_of_a))
{
SCM a;
SCM_VALIDATE_CONS (1, list_of_a);
a = SCM_CAR (list_of_a);
VALIDATE_ASYNC (SCM_ARG1, a);
if (ASYNC_GOT_IT (a))
{
SET_ASYNC_GOT_IT (a, 0);
scm_call_0 (ASYNC_THUNK (a));
}
list_of_a = SCM_CDR (list_of_a);
}
return SCM_BOOL_T;
}
#undef FUNC_NAME
/* System asyncs. */
void
scm_async_click ()
{
/* Reset pending_asyncs even when asyncs are blocked and not really
executed.
*/
scm_root->pending_asyncs = 0;
if (scm_root->block_asyncs == 0)
{
SCM asyncs;
while (!SCM_NULLP(asyncs = scm_root->active_asyncs))
{
scm_root->active_asyncs = SCM_EOL;
do
{
scm_call_0 (SCM_CAR (asyncs));
asyncs = SCM_CDR (asyncs);
}
while (!SCM_NULLP(asyncs));
}
for (asyncs = scm_root->signal_asyncs; !SCM_NULLP(asyncs);
asyncs = SCM_CDR (asyncs))
{
if (scm_is_true (SCM_CAR (asyncs)))
{
SCM proc = SCM_CAR (asyncs);
SCM_SETCAR (asyncs, SCM_BOOL_F);
scm_call_0 (proc);
}
}
}
}
#if (SCM_ENABLE_DEPRECATED == 1)
SCM_DEFINE (scm_system_async, "system-async", 1, 0, 0,
(SCM thunk),
"This function is deprecated. You can use @var{thunk} directly\n"
"instead of explicitely creating an async object.\n")
#define FUNC_NAME s_scm_system_async
{
scm_c_issue_deprecation_warning
("'system-async' is deprecated. "
"Use the procedure directly with 'system-async-mark'.");
return thunk;
}
#undef FUNC_NAME
#endif /* SCM_ENABLE_DEPRECATED == 1 */
void
scm_i_queue_async_cell (SCM c, scm_root_state *root)
{
SCM p = root->active_asyncs;
SCM_SETCDR (c, SCM_EOL);
if (p == SCM_EOL)
root->active_asyncs = c;
else
{
SCM pp;
while ((pp = SCM_CDR(p)) != SCM_EOL)
{
if (SCM_CAR (p) == SCM_CAR (c))
return;
p = pp;
}
SCM_SETCDR (p, c);
}
root->pending_asyncs = 1;
}
SCM_DEFINE (scm_system_async_mark_for_thread, "system-async-mark", 1, 1, 0,
(SCM proc, SCM thread),
"Mark @var{proc} (a procedure with zero arguments) for future execution\n"
"in @var{thread}. If @var{proc} has already been marked for\n"
"@var{thread} but has not been executed yet, this call has no effect.\n"
"If @var{thread} is omitted, the thread that called\n"
"@code{system-async-mark} is used.\n\n"
"This procedure is not safe to be called from C signal handlers. Use\n"
"@code{scm_sigaction} or @code{scm_sigaction_for_thread} to install\n"
"signal handlers.")
#define FUNC_NAME s_scm_system_async_mark_for_thread
{
if (SCM_UNBNDP (thread))
thread = scm_current_thread ();
else
{
SCM_VALIDATE_THREAD (2, thread);
if (scm_c_thread_exited_p (thread))
SCM_MISC_ERROR ("thread has already exited", SCM_EOL);
}
scm_i_queue_async_cell (scm_cons (proc, SCM_BOOL_F),
scm_i_thread_root (thread));
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM
scm_system_async_mark (SCM proc)
#define FUNC_NAME s_scm_system_async_mark_for_thread
{
return scm_system_async_mark_for_thread (proc, SCM_UNDEFINED);
}
#undef FUNC_NAME
SCM_DEFINE (scm_noop, "noop", 0, 0, 1,
(SCM args),
"Do nothing. When called without arguments, return @code{#f},\n"
"otherwise return the first argument.")
#define FUNC_NAME s_scm_noop
{
SCM_VALIDATE_REST_ARGUMENT (args);
return (SCM_NULL_OR_NIL_P (args) ? SCM_BOOL_F : SCM_CAR (args));
}
#undef FUNC_NAME
#if (SCM_ENABLE_DEPRECATED == 1)
SCM_DEFINE (scm_unmask_signals, "unmask-signals", 0, 0, 0,
(),
"Unmask signals. The returned value is not specified.")
#define FUNC_NAME s_scm_unmask_signals
{
scm_c_issue_deprecation_warning
("'unmask-signals' is deprecated. "
"Use 'call-with-blocked-asyncs' instead.");
if (scm_root->block_asyncs == 0)
SCM_MISC_ERROR ("signals already unmasked", SCM_EOL);
scm_root->block_asyncs = 0;
scm_async_click ();
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_DEFINE (scm_mask_signals, "mask-signals", 0, 0, 0,
(),
"Mask signals. The returned value is not specified.")
#define FUNC_NAME s_scm_mask_signals
{
scm_c_issue_deprecation_warning
("'mask-signals' is deprecated. Use 'call-with-blocked-asyncs' instead.");
if (scm_root->block_asyncs > 0)
SCM_MISC_ERROR ("signals already masked", SCM_EOL);
scm_root->block_asyncs = 1;
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
#endif /* SCM_ENABLE_DEPRECATED == 1 */
static void
increase_block (void *unused)
{
scm_root->block_asyncs++;
}
static void
decrease_block (void *unused)
{
scm_root->block_asyncs--;
if (scm_root->block_asyncs == 0)
scm_async_click ();
}
SCM_DEFINE (scm_call_with_blocked_asyncs, "call-with-blocked-asyncs", 1, 0, 0,
(SCM proc),
"Call @var{proc} with no arguments and block the execution\n"
"of system asyncs by one level for the current thread while\n"
"it is running. Return the value returned by @var{proc}.\n")
#define FUNC_NAME s_scm_call_with_blocked_asyncs
{
return scm_internal_dynamic_wind (increase_block,
(scm_t_inner) scm_call_0,
decrease_block,
(void *)proc, NULL);
}
#undef FUNC_NAME
void *
scm_c_call_with_blocked_asyncs (void *(*proc) (void *data), void *data)
{
return (void *)scm_internal_dynamic_wind (increase_block,
(scm_t_inner) proc,
decrease_block,
data, NULL);
}
SCM_DEFINE (scm_call_with_unblocked_asyncs, "call-with-unblocked-asyncs", 1, 0, 0,
(SCM proc),
"Call @var{proc} with no arguments and unblock the execution\n"
"of system asyncs by one level for the current thread while\n"
"it is running. Return the value returned by @var{proc}.\n")
#define FUNC_NAME s_scm_call_with_unblocked_asyncs
{
if (scm_root->block_asyncs == 0)
SCM_MISC_ERROR ("asyncs already unblocked", SCM_EOL);
return scm_internal_dynamic_wind (decrease_block,
(scm_t_inner) scm_call_0,
increase_block,
(void *)proc, NULL);
}
#undef FUNC_NAME
void *
scm_c_call_with_unblocked_asyncs (void *(*proc) (void *data), void *data)
{
if (scm_root->block_asyncs == 0)
scm_misc_error ("scm_c_call_with_unblocked_asyncs",
"asyncs already unblocked", SCM_EOL);
return (void *)scm_internal_dynamic_wind (decrease_block,
(scm_t_inner) proc,
increase_block,
data, NULL);
}
void
scm_frame_block_asyncs ()
{
scm_frame_rewind_handler (increase_block, NULL, SCM_F_WIND_EXPLICITLY);
scm_frame_unwind_handler (decrease_block, NULL, SCM_F_WIND_EXPLICITLY);
}
void
scm_frame_unblock_asyncs ()
{
if (scm_root->block_asyncs == 0)
scm_misc_error ("scm_with_unblocked_asyncs",
"asyncs already unblocked", SCM_EOL);
scm_frame_rewind_handler (decrease_block, NULL, SCM_F_WIND_EXPLICITLY);
scm_frame_unwind_handler (increase_block, NULL, SCM_F_WIND_EXPLICITLY);
}
void
scm_init_async ()
{
scm_asyncs = SCM_EOL;
tc16_async = scm_make_smob_type ("async", 0);
scm_set_smob_mark (tc16_async, async_gc_mark);
#include "libguile/async.x"
}
/*
Local Variables:
c-file-style: "gnu"
End:
*/
|