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/deprecation.h"
54 #include "libguile/validate.h"
55 #include "libguile/async.h"
66 /* {Asynchronous Events}
68 * There are two kinds of asyncs: system asyncs and user asyncs. The
69 * two kinds have some concepts in commen but work slightly
70 * differently and are not interchangeable.
72 * System asyncs are used to run arbitrary code at the next safe point
73 * in a specified thread. You can use them to trigger execution of
74 * Scheme code from signal handlers or to interrupt a thread, for
77 * Each thread has a list of 'activated asyncs', which is a normal
78 * Scheme list of procedures with zero arguments. When a thread
79 * executes a SCM_ASYNC_TICK statement (which is included in
80 * SCM_TICK), it will call all procedures on this list.
82 * Also, a thread will wake up when a procedure is added to its list
83 * of active asyncs and call them. After that, it will go to sleep
84 * again. (Not implemented yet.)
87 * User asyncs are a little data structure that consists of a
88 * procedure of zero arguments and a mark. There are functions for
89 * setting the mark of a user async and for calling all procedures of
90 * marked asyncs in a given list. Nothing you couldn't quickly
94 /* True between SCM_DEFER_INTS and SCM_ALLOW_INTS, and
95 * when the interpreter is not running at all.
97 int scm_ints_disabled
= 1;
98 unsigned int scm_mask_ints
= 1;
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
);
153 if (ASYNC_GOT_IT (a
))
155 SET_ASYNC_GOT_IT (a
, 0);
156 scm_call_0 (ASYNC_THUNK (a
));
159 list_of_a
= SCM_CDR (list_of_a
);
176 while (!SCM_NULLP(asyncs
= scm_active_asyncs
))
178 scm_active_asyncs
= SCM_EOL
;
181 SCM c
= SCM_CDR (asyncs
);
182 SCM_SETCDR (asyncs
, SCM_EOL
);
183 scm_call_0 (SCM_CAR (asyncs
));
186 while (!SCM_NULLP(asyncs
));
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 a asnc 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'.");
205 scm_i_queue_async_cell (SCM c
, scm_root_state
*root
)
207 if (SCM_CDR (c
) == SCM_EOL
)
209 SCM_SETCDR (c
, root
->active_asyncs
);
210 root
->active_asyncs
= c
;
214 SCM_DEFINE (scm_system_async_mark_for_thread
, "system-async-mark", 1, 1, 0,
215 (SCM proc
, SCM thread
),
216 "Register the procedure @var{proc} for future execution\n"
217 "in @var{thread}. When @var{thread} is not specified,\n"
218 "use the current thread.")
219 #define FUNC_NAME s_scm_system_async_mark_for_thread
221 scm_i_queue_async_cell (scm_cons (proc
, SCM_EOL
),
224 : scm_i_thread_root (thread
)));
225 return SCM_UNSPECIFIED
;
230 scm_system_async_mark (SCM proc
)
231 #define FUNC_NAME s_scm_system_async_mark_for_thread
233 return scm_system_async_mark_for_thread (proc
, SCM_UNDEFINED
);
240 SCM_DEFINE (scm_noop
, "noop", 0, 0, 1,
242 "Do nothing. When called without arguments, return @code{#f},\n"
243 "otherwise return the first argument.")
244 #define FUNC_NAME s_scm_noop
246 SCM_VALIDATE_REST_ARGUMENT (args
);
247 return (SCM_NULL_OR_NIL_P (args
) ? SCM_BOOL_F
: SCM_CAR (args
));
254 SCM_DEFINE (scm_unmask_signals
, "unmask-signals", 0, 0, 0,
256 "Unmask signals. The returned value is not specified.")
257 #define FUNC_NAME s_scm_unmask_signals
260 return SCM_UNSPECIFIED
;
265 SCM_DEFINE (scm_mask_signals
, "mask-signals", 0, 0, 0,
267 "Mask signals. The returned value is not specified.")
268 #define FUNC_NAME s_scm_mask_signals
271 return SCM_UNSPECIFIED
;
280 scm_asyncs
= SCM_EOL
;
281 tc16_async
= scm_make_smob_type ("async", 0);
282 scm_set_smob_mark (tc16_async
, async_gc_mark
);
284 #include "libguile/async.x"