X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/e94e3f21d68575cded1b03fb07a66ae622b321e6..c96d76b88dcb7805311d14e6e408d064211fde20:/libguile/async.c diff --git a/libguile/async.c b/libguile/async.c index 718a9a126..e3b7d33f3 100644 --- a/libguile/async.c +++ b/libguile/async.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995, 96, 97, 98, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,2000,2001 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -39,21 +39,19 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ -#include #include -#include "_scm.h" -#include "eval.h" -#include "throw.h" -#include "root.h" -#include "smob.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 "validate.h" -#include "async.h" +#include "libguile/validate.h" +#include "libguile/async.h" #ifdef HAVE_STRING_H #include @@ -110,18 +108,17 @@ static unsigned int scm_desired_switch_rate = 0; int scm_asyncs_pending_p = 0; #endif -static long tc16_async; +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_NIMP(X) && (tc16_async == SCM_GCTYP16 (X))) - -#define VALIDATE_ASYNC(pos,a) SCM_MAKE_VALIDATE(pos, a, ASYNCP) +#define SCM_ASYNCP(X) SCM_TYP16_PREDICATE (tc16_async, X) +#define VALIDATE_ASYNC(pos,a) SCM_MAKE_VALIDATE(pos, a, ASYNCP) #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_CELL_WORD_0 (X) & ((1 << 16) - 1)) | ((V) << 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) @@ -132,7 +129,7 @@ scm_asyncs_pending () { SCM pos; pos = scm_asyncs; - while (pos != SCM_EOL) + while (!SCM_NULL_OR_NIL_P (pos)) { SCM a = SCM_CAR (pos); if (ASYNC_GOT_IT (a)) @@ -142,14 +139,6 @@ scm_asyncs_pending () return 0; } -#if 0 -static SCM -scm_sys_tick_async_thunk (void) -{ - scm_deliver_signal (SCM_TICK_SIGNAL); - return SCM_BOOL_F; -} -#endif void scm_async_click () @@ -228,10 +217,6 @@ scm_async_click () } } - /* - if (owe_tick) - scm_async_mark (system_signal_asyncs[SCM_SIG_ORD(SCM_TICK_SIGNAL)]); */ - SCM_DEFER_INTS; if (scm_tick_rate && scm_switch_rate) { @@ -292,7 +277,7 @@ scm_async_click () static SCM -mark_async (SCM obj) +async_mark (SCM obj) { return ASYNC_THUNK (obj); } @@ -300,8 +285,8 @@ mark_async (SCM obj) SCM_DEFINE (scm_async, "async", 1, 0, 0, - (SCM thunk), -"") + (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)); @@ -310,24 +295,19 @@ SCM_DEFINE (scm_async, "async", 1, 0, 0, SCM_DEFINE (scm_system_async, "system-async", 1, 0, 0, (SCM thunk), -"") + "Create a new async for the procedure @var{thunk}. Also\n" + "add it to the system's list of active async objects.") #define FUNC_NAME s_scm_system_async { - SCM it; - SCM list; - - it = scm_async (thunk); - SCM_NEWCELL (list); - SCM_SETCAR (list, it); - SCM_SETCDR (list, scm_asyncs); - scm_asyncs = list; + SCM it = scm_async (thunk); + scm_asyncs = scm_cons (it, scm_asyncs); return it; } #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); @@ -343,7 +323,7 @@ SCM_DEFINE (scm_async_mark, "async-mark", 1, 0, 0, SCM_DEFINE (scm_system_async_mark, "system-async-mark", 1, 0, 0, (SCM a), -"") + "Mark the async @var{a} for future execution.") #define FUNC_NAME s_scm_system_async_mark { VALIDATE_ASYNC (1, a); @@ -360,10 +340,15 @@ SCM_DEFINE (scm_system_async_mark, "system-async-mark", 1, 0, 0, } #undef FUNC_NAME +void +scm_system_async_mark_from_signal_handler (SCM a) +{ + SET_ASYNC_GOT_IT (a, scm_asyncs_pending_p = 1); +} SCM_DEFINE (scm_run_asyncs, "run-asyncs", 1, 0, 0, - (SCM list_of_a), -"") + (SCM list_of_a), + "Execute all thunks from the asyncs of the list @var{list_of_a}.") #define FUNC_NAME s_scm_run_asyncs { #ifdef GUILE_OLD_ASYNC_CLICK @@ -372,7 +357,7 @@ SCM_DEFINE (scm_run_asyncs, "run-asyncs", 1, 0, 0, #else scm_asyncs_pending_p = 0; #endif - while (! SCM_NULLP (list_of_a)) + while (! SCM_NULL_OR_NIL_P (list_of_a)) { SCM a; SCM_VALIDATE_CONS (1, list_of_a); @@ -382,7 +367,7 @@ SCM_DEFINE (scm_run_asyncs, "run-asyncs", 1, 0, 0, if (ASYNC_GOT_IT (a)) { SET_ASYNC_GOT_IT (a, 0); - scm_apply (ASYNC_THUNK (a), SCM_EOL, SCM_EOL); + scm_call_0 (ASYNC_THUNK (a)); } scm_mask_ints = 0; list_of_a = SCM_CDR (list_of_a); @@ -395,11 +380,13 @@ SCM_DEFINE (scm_run_asyncs, "run-asyncs", 1, 0, 0, SCM_DEFINE (scm_noop, "noop", 0, 0, 1, - (SCM args), -"") + (SCM args), + "Do nothing. When called without arguments, return @code{#f},\n" + "otherwise return the first argument.") #define FUNC_NAME s_scm_noop { - return (SCM_NULLP (args) ? SCM_BOOL_F : SCM_CAR (args)); + SCM_VALIDATE_REST_ARGUMENT (args); + return (SCM_NULL_OR_NIL_P (args) ? SCM_BOOL_F : SCM_CAR (args)); } #undef FUNC_NAME @@ -409,8 +396,9 @@ SCM_DEFINE (scm_noop, "noop", 0, 0, 1, #ifdef GUILE_OLD_ASYNC_CLICK SCM_DEFINE (scm_set_tick_rate, "set-tick-rate", 1, 0, 0, - (SCM n), -"") + (SCM n), + "Set the rate of async ticks to @var{n}. Return the old rate\n" + "value.") #define FUNC_NAME s_scm_set_tick_rate { unsigned int old_n = scm_tick_rate; @@ -426,8 +414,9 @@ SCM_DEFINE (scm_set_tick_rate, "set-tick-rate", 1, 0, 0, SCM_DEFINE (scm_set_switch_rate, "set-switch-rate", 1, 0, 0, - (SCM n), -"") + (SCM n), + "Set the async switch rate to @var{n}. Return the old value\n" + "of the switch rate.") #define FUNC_NAME s_scm_set_switch_rate { unsigned int old_n = scm_switch_rate; @@ -440,34 +429,12 @@ SCM_DEFINE (scm_set_switch_rate, "set-switch-rate", 1, 0, 0, #undef FUNC_NAME #endif - - -/* points to the GC system-async, so that scm_gc_end can find it. */ -SCM scm_gc_async; - -/* the vcell for gc-thunk. */ -static SCM scm_gc_vcell; - -/* the thunk installed in the GC system-async, which is marked at the - end of garbage collection. */ -static SCM -scm_sys_gc_async_thunk (void) -{ - if (SCM_NFALSEP (scm_gc_vcell)) - { - SCM proc = SCM_CDR (scm_gc_vcell); - - if (SCM_NFALSEP (proc) && !SCM_UNBNDP (proc)) - scm_apply (proc, SCM_EOL, SCM_EOL); - } - return SCM_UNSPECIFIED; -} 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_mask_ints = 0; @@ -477,8 +444,8 @@ SCM_DEFINE (scm_unmask_signals, "unmask-signals", 0, 0, 0, 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_mask_ints = 1; @@ -491,14 +458,13 @@ SCM_DEFINE (scm_mask_signals, "mask-signals", 0, 0, 0, void scm_init_async () { - SCM a_thunk; - tc16_async = scm_make_smob_type_mfpe ("async", 0, - mark_async, NULL, NULL, NULL); - scm_gc_vcell = scm_sysintern ("gc-thunk", SCM_BOOL_F); - a_thunk = scm_make_gsubr ("%gc-thunk", 0, 0, 0, scm_sys_gc_async_thunk); - scm_gc_async = scm_system_async (a_thunk); - -#include "async.x" + scm_asyncs = SCM_EOL; + tc16_async = scm_make_smob_type ("async", 0); + scm_set_smob_mark (tc16_async, async_mark); + +#ifndef SCM_MAGIC_SNARFER +#include "libguile/async.x" +#endif } /*