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_MSG(pos, a, ASYNCP, "user async")
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 "Mark @var{proc} (a procedure with zero arguments) for future execution\n"
232 "in @var{thread}. If @var{proc} has already been marked for\n"
233 "@var{thread} but has not been executed yet, this call has no effect.\n"
234 "If @var{thread} is omitted, the thread that called\n"
235 "@code{system-async-mark} is used.\n\n"
236 "This procedure is not safe to be called from C signal handlers. Use\n"
237 "@code{scm_sigaction} or @code{scm_sigaction_for_thread} to install\n"
239 #define FUNC_NAME s_scm_system_async_mark_for_thread
242 if (SCM_UNBNDP (thread
))
243 thread
= scm_current_thread ();
245 SCM_VALIDATE_THREAD (2, thread
);
247 scm_i_queue_async_cell (scm_cons (proc
, SCM_BOOL_F
),
248 scm_i_thread_root (thread
));
250 scm_i_queue_async_cell (scm_cons (proc
, SCM_BOOL_F
), scm_root
);
252 return SCM_UNSPECIFIED
;
257 scm_system_async_mark (SCM proc
)
258 #define FUNC_NAME s_scm_system_async_mark_for_thread
260 return scm_system_async_mark_for_thread (proc
, SCM_UNDEFINED
);
267 SCM_DEFINE (scm_noop
, "noop", 0, 0, 1,
269 "Do nothing. When called without arguments, return @code{#f},\n"
270 "otherwise return the first argument.")
271 #define FUNC_NAME s_scm_noop
273 SCM_VALIDATE_REST_ARGUMENT (args
);
274 return (SCM_NULL_OR_NIL_P (args
) ? SCM_BOOL_F
: SCM_CAR (args
));
281 #if (SCM_ENABLE_DEPRECATED == 1)
283 SCM_DEFINE (scm_unmask_signals
, "unmask-signals", 0, 0, 0,
285 "Unmask signals. The returned value is not specified.")
286 #define FUNC_NAME s_scm_unmask_signals
288 scm_c_issue_deprecation_warning
289 ("'unmask-signals' is deprecated. "
290 "Use 'call-with-blocked-asyncs' instead.");
292 if (scm_root
->block_asyncs
== 0)
293 SCM_MISC_ERROR ("signals already unmasked", SCM_EOL
);
294 scm_root
->block_asyncs
= 0;
295 return SCM_UNSPECIFIED
;
300 SCM_DEFINE (scm_mask_signals
, "mask-signals", 0, 0, 0,
302 "Mask signals. The returned value is not specified.")
303 #define FUNC_NAME s_scm_mask_signals
305 scm_c_issue_deprecation_warning
306 ("'mask-signals' is deprecated. Use 'call-with-blocked-asyncs' instead.");
308 if (scm_root
->block_asyncs
> 0)
309 SCM_MISC_ERROR ("signals already masked", SCM_EOL
);
310 scm_root
->block_asyncs
= 1;
311 return SCM_UNSPECIFIED
;
315 #endif /* SCM_ENABLE_DEPRECATED == 1 */
318 increase_block (void *unused
)
320 scm_root
->block_asyncs
++;
324 decrease_block (void *unused
)
326 scm_root
->block_asyncs
--;
329 SCM_DEFINE (scm_call_with_blocked_asyncs
, "call-with-blocked-asyncs", 1, 0, 0,
331 "Call @var{proc} with no arguments and block the execution\n"
332 "of system asyncs by one level for the current thread while\n"
333 "it is running. Return the value returned by @var{proc}.\n")
334 #define FUNC_NAME s_scm_call_with_blocked_asyncs
336 return scm_internal_dynamic_wind (increase_block
,
337 (scm_t_inner
) scm_call_0
,
344 scm_c_call_with_blocked_asyncs (void *(*proc
) (void *data
), void *data
)
346 return scm_internal_dynamic_wind (increase_block
,
353 SCM_DEFINE (scm_call_with_unblocked_asyncs
, "call-with-unblocked-asyncs", 1, 0, 0,
355 "Call @var{proc} with no arguments and unblock the execution\n"
356 "of system asyncs by one level for the current thread while\n"
357 "it is running. Return the value returned by @var{proc}.\n")
358 #define FUNC_NAME s_scm_call_with_unblocked_asyncs
360 if (scm_root
->block_asyncs
== 0)
361 SCM_MISC_ERROR ("asyncs already unblocked", SCM_EOL
);
362 return scm_internal_dynamic_wind (decrease_block
,
363 (scm_t_inner
) scm_call_0
,
370 scm_c_call_with_unblocked_asyncs (void *(*proc
) (void *data
), void *data
)
372 if (scm_root
->block_asyncs
== 0)
373 scm_misc_error ("scm_c_call_with_unblocked_asyncs",
374 "asyncs already unblocked", SCM_EOL
);
375 return scm_internal_dynamic_wind (decrease_block
,
386 scm_asyncs
= SCM_EOL
;
387 tc16_async
= scm_make_smob_type ("async", 0);
388 scm_set_smob_mark (tc16_async
, async_gc_mark
);
390 #include "libguile/async.x"