1 /* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002 Free Software Foundation, Inc.
3 * This program is free software; you can redistribute it and/or modify
4 * it under the terms of the GNU General Public License as published by
5 * the Free Software Foundation; either version 2, or (at your option)
8 * This program is distributed in the hope that it will be useful,
9 * but WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
11 * GNU General Public License for more details.
13 * You should have received a copy of the GNU General Public License
14 * along with this software; see the file COPYING. If not, write to
15 * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
16 * Boston, MA 02111-1307 USA
18 * As a special exception, the Free Software Foundation gives permission
19 * for additional uses of the text contained in its release of GUILE.
21 * The exception is that, if you link the GUILE library with other files
22 * to produce an executable, this does not by itself cause the
23 * resulting executable to be covered by the GNU General Public License.
24 * Your use of that executable is in no way restricted on account of
25 * linking the GUILE library code into it.
27 * This exception does not however invalidate any other reasons why
28 * the executable file might be covered by the GNU General Public License.
30 * This exception applies only to the code released by the
31 * Free Software Foundation under the name GUILE. If you copy
32 * code from other Free Software Foundation releases into a copy of
33 * GUILE, as the General Public License permits, the exception does
34 * not apply to the code that you add in this way. To avoid misleading
35 * anyone as to the status of such modified files, you must delete
36 * this exception notice from them.
38 * If you write modifications of your own for GUILE, it is your choice
39 * whether to permit this exception to apply to your modifications.
40 * If you do not wish that, delete this exception notice. */
46 #include "libguile/_scm.h"
47 #include "libguile/eval.h"
48 #include "libguile/throw.h"
49 #include "libguile/root.h"
50 #include "libguile/smob.h"
51 #include "libguile/lang.h"
52 #include "libguile/dynwind.h"
53 #include "libguile/deprecation.h"
55 #include "libguile/validate.h"
56 #include "libguile/async.h"
65 /* This is not used for anything except checking that DEFER_INTS and
66 ALLOW_INTS are used properly.
68 int scm_ints_disabled
= 1;
71 /* {Asynchronous Events}
73 * There are two kinds of asyncs: system asyncs and user asyncs. The
74 * two kinds have some concepts in commen but work slightly
75 * differently and are not interchangeable.
77 * System asyncs are used to run arbitrary code at the next safe point
78 * in a specified thread. You can use them to trigger execution of
79 * Scheme code from signal handlers or to interrupt a thread, for
82 * Each thread has a list of 'activated asyncs', which is a normal
83 * Scheme list of procedures with zero arguments. When a thread
84 * executes a SCM_ASYNC_TICK statement (which is included in
85 * SCM_TICK), it will call all procedures on this list.
87 * Also, a thread will wake up when a procedure is added to its list
88 * of active asyncs and call them. After that, it will go to sleep
89 * again. (Not implemented yet.)
92 * User asyncs are a little data structure that consists of a
93 * procedure of zero arguments and a mark. There are functions for
94 * setting the mark of a user async and for calling all procedures of
95 * marked asyncs in a given list. Nothing you couldn't quickly
104 static scm_t_bits tc16_async
;
106 /* cmm: this has SCM_ prefix because SCM_MAKE_VALIDATE expects it.
108 #define SCM_ASYNCP(X) SCM_TYP16_PREDICATE (tc16_async, X)
109 #define VALIDATE_ASYNC(pos, a) SCM_MAKE_VALIDATE(pos, a, ASYNCP)
111 #define ASYNC_GOT_IT(X) (SCM_CELL_WORD_0 (X) >> 16)
112 #define SET_ASYNC_GOT_IT(X, V) (SCM_SET_CELL_WORD_0 ((X), SCM_TYP16 (X) | ((V) << 16)))
113 #define ASYNC_THUNK(X) SCM_CELL_OBJECT_1 (X)
116 async_gc_mark (SCM obj
)
118 return ASYNC_THUNK (obj
);
121 SCM_DEFINE (scm_async
, "async", 1, 0, 0,
123 "Create a new async for the procedure @var{thunk}.")
124 #define FUNC_NAME s_scm_async
126 SCM_RETURN_NEWSMOB (tc16_async
, SCM_UNPACK (thunk
));
130 SCM_DEFINE (scm_async_mark
, "async-mark", 1, 0, 0,
132 "Mark the async @var{a} for future execution.")
133 #define FUNC_NAME s_scm_async_mark
135 VALIDATE_ASYNC (1, a
);
136 SET_ASYNC_GOT_IT (a
, 1);
137 return SCM_UNSPECIFIED
;
141 SCM_DEFINE (scm_run_asyncs
, "run-asyncs", 1, 0, 0,
143 "Execute all thunks from the asyncs of the list @var{list_of_a}.")
144 #define FUNC_NAME s_scm_run_asyncs
146 while (! SCM_NULL_OR_NIL_P (list_of_a
))
149 SCM_VALIDATE_CONS (1, list_of_a
);
150 a
= SCM_CAR (list_of_a
);
151 VALIDATE_ASYNC (SCM_ARG1
, a
);
152 if (ASYNC_GOT_IT (a
))
154 SET_ASYNC_GOT_IT (a
, 0);
155 scm_call_0 (ASYNC_THUNK (a
));
157 list_of_a
= SCM_CDR (list_of_a
);
172 if (scm_root
->block_asyncs
== 0)
174 while (!SCM_NULLP(asyncs
= scm_root
->active_asyncs
))
176 scm_root
->active_asyncs
= SCM_EOL
;
179 SCM c
= SCM_CDR (asyncs
);
180 SCM_SETCDR (asyncs
, SCM_BOOL_F
);
181 scm_call_0 (SCM_CAR (asyncs
));
184 while (!SCM_NULLP(asyncs
));
189 #if (SCM_ENABLE_DEPRECATED == 1)
191 SCM_DEFINE (scm_system_async
, "system-async", 1, 0, 0,
193 "This function is deprecated. You can use @var{thunk} directly\n"
194 "instead of explicitely creating an async object.\n")
195 #define FUNC_NAME s_scm_system_async
197 scm_c_issue_deprecation_warning
198 ("'system-async' is deprecated. "
199 "Use the procedure directly with 'system-async-mark'.");
204 #endif /* SCM_ENABLE_DEPRECATED == 1 */
207 scm_i_queue_async_cell (SCM c
, scm_root_state
*root
)
209 if (SCM_CDR (c
) == SCM_BOOL_F
)
211 SCM p
= root
->active_asyncs
;
212 SCM_SETCDR (c
, SCM_EOL
);
214 root
->active_asyncs
= c
;
218 while ((pp
= SCM_CDR(p
)) != SCM_EOL
)
220 if (SCM_CAR (p
) == SCM_CAR (c
))
229 SCM_DEFINE (scm_system_async_mark_for_thread
, "system-async-mark", 1, 1, 0,
230 (SCM proc
, SCM thread
),
231 "Register the procedure @var{proc} for future execution\n"
232 "in @var{thread}. When @var{thread} is not specified,\n"
233 "use the current thread.")
234 #define FUNC_NAME s_scm_system_async_mark_for_thread
237 if (SCM_UNBNDP (thread
))
238 thread
= scm_current_thread ();
240 SCM_VALIDATE_THREAD (2, thread
);
242 scm_i_queue_async_cell (scm_cons (proc
, SCM_BOOL_F
),
243 scm_i_thread_root (thread
));
245 scm_i_queue_async_cell (scm_cons (proc
, SCM_BOOL_F
), scm_root
);
247 return SCM_UNSPECIFIED
;
252 scm_system_async_mark (SCM proc
)
253 #define FUNC_NAME s_scm_system_async_mark_for_thread
255 return scm_system_async_mark_for_thread (proc
, SCM_UNDEFINED
);
262 SCM_DEFINE (scm_noop
, "noop", 0, 0, 1,
264 "Do nothing. When called without arguments, return @code{#f},\n"
265 "otherwise return the first argument.")
266 #define FUNC_NAME s_scm_noop
268 SCM_VALIDATE_REST_ARGUMENT (args
);
269 return (SCM_NULL_OR_NIL_P (args
) ? SCM_BOOL_F
: SCM_CAR (args
));
276 #if (SCM_ENABLE_DEPRECATED == 1)
278 SCM_DEFINE (scm_unmask_signals
, "unmask-signals", 0, 0, 0,
280 "Unmask signals. The returned value is not specified.")
281 #define FUNC_NAME s_scm_unmask_signals
283 scm_c_issue_deprecation_warning
284 ("'unmask-signals' is deprecated. "
285 "Use 'call-with-blocked-asyncs' instead.");
287 if (scm_root
->block_asyncs
== 0)
288 SCM_MISC_ERROR ("signals already unmasked", SCM_EOL
);
289 scm_root
->block_asyncs
= 0;
290 return SCM_UNSPECIFIED
;
295 SCM_DEFINE (scm_mask_signals
, "mask-signals", 0, 0, 0,
297 "Mask signals. The returned value is not specified.")
298 #define FUNC_NAME s_scm_mask_signals
300 scm_c_issue_deprecation_warning
301 ("'mask-signals' is deprecated. Use 'call-with-blocked-asyncs' instead.");
303 if (scm_root
->block_asyncs
> 0)
304 SCM_MISC_ERROR ("signals already masked", SCM_EOL
);
305 scm_root
->block_asyncs
= 1;
306 return SCM_UNSPECIFIED
;
310 #endif /* SCM_ENABLE_DEPRECATED == 1 */
313 increase_block (void *unused
)
315 scm_root
->block_asyncs
++;
319 decrease_block (void *unused
)
321 scm_root
->block_asyncs
--;
324 SCM_DEFINE (scm_call_with_blocked_asyncs
, "call-with-blocked-asyncs", 1, 0, 0,
326 "Call @var{proc} with no arguments and block the execution\n"
327 "of system asyncs by one level for the current thread while\n"
328 "it is running. Return the value returned by @var{proc}.\n")
329 #define FUNC_NAME s_scm_call_with_blocked_asyncs
331 return scm_internal_dynamic_wind (increase_block
,
332 (scm_t_inner
) scm_call_0
,
339 scm_c_call_with_blocked_asyncs (void *(*proc
) (void *data
), void *data
)
341 return scm_internal_dynamic_wind (increase_block
,
348 SCM_DEFINE (scm_call_with_unblocked_asyncs
, "call-with-unblocked-asyncs", 1, 0, 0,
350 "Call @var{proc} with no arguments and unblock the execution\n"
351 "of system asyncs by one level for the current thread while\n"
352 "it is running. Return the value returned by @var{proc}.\n")
353 #define FUNC_NAME s_scm_call_with_unblocked_asyncs
355 if (scm_root
->block_asyncs
== 0)
356 SCM_MISC_ERROR ("asyncs already unblocked", SCM_EOL
);
357 return scm_internal_dynamic_wind (decrease_block
,
358 (scm_t_inner
) scm_call_0
,
365 scm_c_call_with_unblocked_asyncs (void *(*proc
) (void *data
), void *data
)
367 if (scm_root
->block_asyncs
== 0)
368 scm_misc_error ("scm_c_call_with_unblocked_asyncs",
369 "asyncs already unblocked", SCM_EOL
);
370 return scm_internal_dynamic_wind (decrease_block
,
381 scm_asyncs
= SCM_EOL
;
382 tc16_async
= scm_make_smob_type ("async", 0);
383 scm_set_smob_mark (tc16_async
, async_gc_mark
);
385 #include "libguile/async.x"