X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/20e6290e38294de51ca0ca2b29c11d0f0042593c..fbf0c8c7b194202e01338f8b5324126bf73af4c9:/libguile/async.c diff --git a/libguile/async.c b/libguile/async.c index 17219d3ef..2728537b3 100644 --- a/libguile/async.c +++ b/libguile/async.c @@ -1,18 +1,19 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * +/* Copyright (C) 1995, 96, 97, 98, 2000 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 * the Free Software Foundation; either version 2, or (at your option) * any later version. - * + * * This program 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 General Public License for more details. - * + * * You should have received a copy of the GNU General Public License * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA * * As a special exception, the Free Software Foundation gives permission * for additional uses of the text contained in its release of GUILE. @@ -36,18 +37,23 @@ * * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ + * 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 "smob.h" +#include "libguile/_scm.h" +#include "libguile/eval.h" +#include "libguile/throw.h" +#include "libguile/root.h" +#include "libguile/smob.h" -#include "async.h" +#include "libguile/validate.h" +#include "libguile/async.h" #ifdef HAVE_STRING_H #include @@ -65,7 +71,7 @@ * * Setting the mark guarantees future execution of the thunk. More * than one set may be satisfied by a single execution. - * + * * scm_tick_clock decremented once per SCM_ALLOW_INTS. * Async execution triggered by SCM_ALLOW_INTS when scm_tick_clock drops to 0. * Async execution prevented by scm_mask_ints != 0. @@ -84,13 +90,15 @@ * */ +/* True between SCM_DEFER_INTS and SCM_ALLOW_INTS, and + * when the interpreter is not running at all. + */ +int scm_ints_disabled = 1; +unsigned int scm_mask_ints = 1; -#define min(A,B) ((A) < (B) ? (A) : (B)) - - +#ifdef GUILE_OLD_ASYNC_CLICK unsigned int scm_async_clock = 20; static unsigned int scm_async_rate = 20; -unsigned int scm_mask_ints = 1; static unsigned int scm_tick_clock = 0; static unsigned int scm_tick_rate = 0; @@ -98,46 +106,35 @@ static unsigned int scm_desired_tick_rate = 0; static unsigned int scm_switch_clock = 0; static unsigned int scm_switch_rate = 0; static unsigned int scm_desired_switch_rate = 0; +#else +int scm_asyncs_pending_p = 0; +#endif -static SCM system_signal_asyncs[SCM_NUM_SIGS]; -static SCM handler_var; -static SCM symbol_signal; - - -struct scm_async -{ - int got_it; /* needs to be delivered? */ - SCM thunk; /* the handler. */ -}; - - -static long scm_tc16_async; - -#define SCM_ASYNCP(X) (scm_tc16_async == SCM_GCTYP16 (X)) -#define SCM_ASYNC(X) ((struct scm_async *)SCM_CDR (X)) +static scm_bits_t 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(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_TYP16 (X) | ((V) << 16))) +#define ASYNC_THUNK(X) SCM_CELL_OBJECT_1 (X) -#ifdef __STDC__ -static int -asyncs_pending (void) -#else -static int -asyncs_pending () -#endif +#ifdef GUILE_OLD_ASYNC_CLICK +int +scm_asyncs_pending () { SCM pos; pos = scm_asyncs; while (pos != SCM_EOL) { - SCM a; - struct scm_async * it; - a = SCM_CAR (pos); - it = SCM_ASYNC (a); - if (it->got_it) + SCM a = SCM_CAR (pos); + if (ASYNC_GOT_IT (a)) return 1; pos = SCM_CDR (pos); } @@ -145,13 +142,8 @@ asyncs_pending () } -#ifdef __STDC__ -void -scm_async_click (void) -#else void scm_async_click () -#endif { int owe_switch; int owe_tick; @@ -194,7 +186,7 @@ scm_async_click () scm_async_clock = 1; return;; } - + if (!scm_tick_rate) { unsigned int r; @@ -227,9 +219,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) { @@ -252,7 +241,7 @@ scm_async_click () scm_run_asyncs (scm_asyncs); SCM_DEFER_INTS; - if (asyncs_pending ()) + if (scm_asyncs_pending ()) { SCM_ALLOW_INTS_ONLY; goto tail; @@ -263,483 +252,222 @@ scm_async_click () scm_switch (); } - - - -#ifdef __STDC__ -void -scm_switch (void) -#else void scm_switch () -#endif -{} - - -#ifdef __STDC__ -static void -scm_deliver_signal (int num) -#else -static void -scm_deliver_signal (num) - int num; -#endif { - SCM handler; - handler = SCM_CDR (handler_var); - if (handler != SCM_BOOL_F) - scm_apply (handler, SCM_MAKINUM (num), scm_listofnull); - else - { - scm_mask_ints = 0; - scm_throw (symbol_signal, - scm_listify (SCM_MAKINUM (num), SCM_UNDEFINED)); - } -} - - - - -#ifdef __STDC__ -static int -print_async (SCM exp, SCM port, int writing) -#else -static int -print_async (exp, port, writing) - SCM exp; - SCM port; - int writing; +#if 0 /* Thread switching code should probably reside here, but the + async switching code doesn't seem to work, so it's put in the + SCM_DEFER_INTS macro instead. /mdj */ + SCM_THREAD_SWITCHING_CODE; #endif -{ - scm_gen_puts (scm_regular_string, "#', port); - return 1; } -#ifdef __STDC__ -static SCM -mark_async (SCM obj) #else -static SCM -mark_async (obj) - SCM obj; -#endif + +void +scm_async_click () { - struct scm_async * it; - if (SCM_GC8MARKP (obj)) - return SCM_BOOL_F; - SCM_SETGC8MARK (obj); - it = SCM_ASYNC (obj); - return it->thunk; + if (!scm_mask_ints) + do + scm_run_asyncs (scm_asyncs); + while (scm_asyncs_pending_p); } -#ifdef __STDC__ -static scm_sizet -free_async (SCM obj) -#else -static scm_sizet -free_async (SCM obj) - SCM obj; #endif -{ - struct scm_async * it; - it = SCM_ASYNC (obj); - scm_must_free ((char *)it); - return (sizeof (*it)); -} -static scm_smobfuns async_smob = -{ - mark_async, - free_async, - print_async, - 0 -}; + +static SCM +async_mark (SCM obj) +{ + return ASYNC_THUNK (obj); +} -SCM_PROC(s_async, "async", 1, 0, 0, scm_async); -#ifdef __STDC__ -SCM -scm_async (SCM thunk) -#else -SCM -scm_async (thunk) - SCM thunk; -#endif +SCM_DEFINE (scm_async, "async", 1, 0, 0, + (SCM thunk), +"") +#define FUNC_NAME s_scm_async { - SCM it; - struct scm_async * async; - - SCM_NEWCELL (it); - SCM_DEFER_INTS; - SCM_SETCDR (it, SCM_EOL); - async = (struct scm_async *)scm_must_malloc (sizeof (*async), s_async); - async->got_it = 0; - async->thunk = thunk; - SCM_SETCDR (it, (SCM)async); - SCM_SETCAR (it, (SCM)scm_tc16_async); - SCM_ALLOW_INTS; - return it; + SCM_RETURN_NEWSMOB (tc16_async, SCM_UNPACK (thunk)); } +#undef FUNC_NAME -SCM_PROC(s_system_async, "system-async", 1, 0, 0, scm_system_async); -#ifdef __STDC__ -SCM -scm_system_async (SCM thunk) -#else -SCM -scm_system_async (thunk) - SCM thunk; -#endif +SCM_DEFINE (scm_system_async, "system-async", 1, 0, 0, + (SCM thunk), +"") +#define FUNC_NAME s_scm_system_async { SCM it; SCM list; it = scm_async (thunk); SCM_NEWCELL (list); - SCM_DEFER_INTS; SCM_SETCAR (list, it); SCM_SETCDR (list, scm_asyncs); scm_asyncs = list; - SCM_ALLOW_INTS; return it; } +#undef FUNC_NAME -SCM_PROC(s_async_mark, "async-mark", 1, 0, 0, scm_async_mark); -#ifdef __STDC__ -SCM -scm_async_mark (SCM a) +SCM_DEFINE (scm_async_mark, "async-mark", 1, 0, 0, + (SCM a), +"") +#define FUNC_NAME s_scm_async_mark +{ + VALIDATE_ASYNC (1, a); +#ifdef GUILE_OLD_ASYNC_CLICK + SET_ASYNC_GOT_IT (a, 1); #else -SCM -scm_async_mark (a) - SCM a; + SET_ASYNC_GOT_IT (a, scm_asyncs_pending_p = 1); #endif -{ - struct scm_async * it; - SCM_ASSERT (SCM_NIMP (a) && SCM_ASYNCP (a), a, SCM_ARG1, s_async_mark); - it = SCM_ASYNC (a); - it->got_it = 1; return SCM_UNSPECIFIED; } +#undef FUNC_NAME -SCM_PROC(s_system_async_mark, "system-async-mark", 1, 0, 0, scm_system_async_mark); -#ifdef __STDC__ -SCM -scm_system_async_mark (SCM a) -#else -SCM -scm_system_async_mark (a) - SCM a; -#endif +SCM_DEFINE (scm_system_async_mark, "system-async-mark", 1, 0, 0, + (SCM a), +"") +#define FUNC_NAME s_scm_system_async_mark { - struct scm_async * it; - SCM_ASSERT (SCM_NIMP (a) && SCM_ASYNCP (a), a, SCM_ARG1, s_async_mark); - it = SCM_ASYNC (a); + VALIDATE_ASYNC (1, a); SCM_REDEFER_INTS; - it->got_it = 1; +#ifdef GUILE_OLD_ASYNC_CLICK + SET_ASYNC_GOT_IT (a, 1); scm_async_rate = 1 + scm_async_rate - scm_async_clock; scm_async_clock = 1; +#else + SET_ASYNC_GOT_IT (a, scm_asyncs_pending_p = 1); +#endif SCM_REALLOW_INTS; return SCM_UNSPECIFIED; } +#undef FUNC_NAME -SCM_PROC(s_run_asyncs, "run-asyncs", 1, 0, 0, scm_run_asyncs); -#ifdef __STDC__ -SCM -scm_run_asyncs (SCM list_of_a) -#else -SCM -scm_run_asyncs (list_of_a) - SCM list_of_a; -#endif +SCM_DEFINE (scm_run_asyncs, "run-asyncs", 1, 0, 0, + (SCM list_of_a), +"") +#define FUNC_NAME s_scm_run_asyncs { - SCM pos; - +#ifdef GUILE_OLD_ASYNC_CLICK if (scm_mask_ints) return SCM_BOOL_F; - pos = list_of_a; - while (pos != SCM_EOL) +#else + scm_asyncs_pending_p = 0; +#endif + while (! SCM_NULLP (list_of_a)) { SCM a; - struct scm_async * it; - SCM_ASSERT (SCM_NIMP (pos) && SCM_CONSP (pos), pos, SCM_ARG1, s_run_asyncs); - a = SCM_CAR (pos); - SCM_ASSERT (SCM_NIMP (a) && SCM_ASYNCP (a), a, SCM_ARG1, s_run_asyncs); - it = SCM_ASYNC (a); + SCM_VALIDATE_CONS (1, list_of_a); + a = SCM_CAR (list_of_a); + VALIDATE_ASYNC (SCM_ARG1, a); scm_mask_ints = 1; - if (it->got_it) + if (ASYNC_GOT_IT (a)) { - it->got_it = 0; - scm_apply (it->thunk, SCM_EOL, SCM_EOL); + SET_ASYNC_GOT_IT (a, 0); + scm_apply (ASYNC_THUNK (a), SCM_EOL, SCM_EOL); } scm_mask_ints = 0; - pos = SCM_CDR (pos); + list_of_a = SCM_CDR (list_of_a); } return SCM_BOOL_T; } +#undef FUNC_NAME -SCM_PROC(s_noop, "noop", 0, 0, 1, scm_noop); -#ifdef __STDC__ -SCM -scm_noop (SCM args) -#else -SCM -scm_noop (args) - SCM args; -#endif +SCM_DEFINE (scm_noop, "noop", 0, 0, 1, + (SCM args), +"") +#define FUNC_NAME s_scm_noop { - return (SCM_NULLP (args) - ? SCM_BOOL_F - : SCM_CAR (args)); + SCM_VALIDATE_REST_ARGUMENT (args); + return (SCM_NULLP (args) ? SCM_BOOL_F : SCM_CAR (args)); } +#undef FUNC_NAME -SCM_PROC(s_set_tick_rate, "set-tick-rate", 1, 0, 0, scm_set_tick_rate); -#ifdef __STDC__ -SCM -scm_set_tick_rate (SCM n) -#else -SCM -scm_set_tick_rate (n) - SCM n; -#endif +#ifdef GUILE_OLD_ASYNC_CLICK + +SCM_DEFINE (scm_set_tick_rate, "set-tick-rate", 1, 0, 0, + (SCM n), +"") +#define FUNC_NAME s_scm_set_tick_rate { - unsigned int old_n; - SCM_ASSERT (SCM_INUMP (n), n, SCM_ARG1, s_set_tick_rate); - old_n = scm_tick_rate; + unsigned int old_n = scm_tick_rate; + SCM_VALIDATE_INUM (1, n); scm_desired_tick_rate = SCM_INUM (n); scm_async_rate = 1 + scm_async_rate - scm_async_clock; scm_async_clock = 1; return SCM_MAKINUM (old_n); } +#undef FUNC_NAME -SCM_PROC(s_set_switch_rate, "set-switch-rate", 1, 0, 0, scm_set_switch_rate); -#ifdef __STDC__ -SCM -scm_set_switch_rate (SCM n) -#else -SCM -scm_set_switch_rate (n) - SCM n; -#endif +SCM_DEFINE (scm_set_switch_rate, "set-switch-rate", 1, 0, 0, + (SCM n), +"") +#define FUNC_NAME s_scm_set_switch_rate { - unsigned int old_n; - SCM_ASSERT (SCM_INUMP (n), n, SCM_ARG1, s_set_switch_rate); - old_n = scm_switch_rate; + unsigned int old_n = scm_switch_rate; + SCM_VALIDATE_INUM (1, n); scm_desired_switch_rate = SCM_INUM (n); scm_async_rate = 1 + scm_async_rate - scm_async_clock; scm_async_clock = 1; return SCM_MAKINUM (old_n); } +#undef FUNC_NAME - - -#ifdef __STDC__ -static SCM -scm_sys_hup_async_thunk (void) -#else -static SCM -scm_sys_hup_async_thunk () -#endif -{ - scm_deliver_signal (SCM_HUP_SIGNAL); - return SCM_BOOL_F; -} - -#ifdef __STDC__ -static SCM -scm_sys_int_async_thunk (void) -#else -static SCM -scm_sys_int_async_thunk () -#endif -{ - scm_deliver_signal (SCM_INT_SIGNAL); - return SCM_BOOL_F; -} - -#ifdef __STDC__ -static SCM -scm_sys_fpe_async_thunk (void) -#else -static SCM -scm_sys_fpe_async_thunk () -#endif -{ - scm_deliver_signal (SCM_FPE_SIGNAL); - return SCM_BOOL_F; -} - -#ifdef __STDC__ -static SCM -scm_sys_bus_async_thunk (void) -#else -static SCM -scm_sys_bus_async_thunk () #endif -{ - scm_deliver_signal (SCM_BUS_SIGNAL); - return SCM_BOOL_F; -} - -#ifdef __STDC__ -static SCM -scm_sys_segv_async_thunk (void) -#else -static SCM -scm_sys_segv_async_thunk () -#endif -{ - scm_deliver_signal (SCM_SEGV_SIGNAL); - return SCM_BOOL_F; -} - -#ifdef __STDC__ -static SCM -scm_sys_alrm_async_thunk (void) -#else -static SCM -scm_sys_alrm_async_thunk () -#endif -{ - scm_deliver_signal (SCM_ALRM_SIGNAL); - return SCM_BOOL_F; -} - -#ifdef __STDC__ -static SCM -scm_sys_gc_async_thunk (void) -#else -static SCM -scm_sys_gc_async_thunk () -#endif -{ - scm_deliver_signal (SCM_GC_SIGNAL); - return SCM_BOOL_F; -} - -#ifdef __STDC__ -static SCM -scm_sys_tick_async_thunk (void) -#else -static SCM -scm_sys_tick_async_thunk () -#endif -{ - scm_deliver_signal (SCM_TICK_SIGNAL); - return SCM_BOOL_F; -} - - -#ifdef __STDC__ -SCM -scm_take_signal (int n) -#else -SCM -scm_take_signal (n) - int n; -#endif -{ - SCM ignored; - if (!scm_ints_disabled) - { - SCM_NEWCELL (ignored); /* In case we interrupted SCM_NEWCELL, - * throw out the possibly already allocated - * free cell. - */ - } - scm_system_async_mark (system_signal_asyncs[SCM_SIG_ORD(n)]); - return SCM_BOOL_F; -} - - - -SCM_PROC(s_unmask_signals, "unmask-signals", 0, 0, 0, scm_unmask_signals); -#ifdef __STDC__ -SCM -scm_unmask_signals (void) -#else -SCM -scm_unmask_signals () -#endif +SCM_DEFINE (scm_unmask_signals, "unmask-signals", 0, 0, 0, + (), +"") +#define FUNC_NAME s_scm_unmask_signals { scm_mask_ints = 0; return SCM_UNSPECIFIED; } +#undef FUNC_NAME -SCM_PROC(s_mask_signals, "mask-signals", 0, 0, 0, scm_mask_signals); -#ifdef __STDC__ -SCM -scm_mask_signals (void) -#else -SCM -scm_mask_signals () -#endif +SCM_DEFINE (scm_mask_signals, "mask-signals", 0, 0, 0, + (), +"") +#define FUNC_NAME s_scm_mask_signals { scm_mask_ints = 1; return SCM_UNSPECIFIED; } +#undef FUNC_NAME -#ifdef __STDC__ -void -scm_init_async (void) -#else void scm_init_async () -#endif { - SCM a_thunk; - scm_tc16_async = scm_newsmob (&async_smob); - symbol_signal = SCM_CAR (scm_sysintern ("signal", strlen ("signal"))); - scm_permanent_object (symbol_signal); - - /* These are in the opposite order of delivery priortity. - * - * Error conditions are given low priority: - */ - a_thunk = scm_make_gsubr ("%hup-thunk", 0, 0, 0, scm_sys_hup_async_thunk); - system_signal_asyncs[SCM_SIG_ORD(SCM_HUP_SIGNAL)] = scm_system_async (a_thunk); - a_thunk = scm_make_gsubr ("%int-thunk", 0, 0, 0, scm_sys_int_async_thunk); - system_signal_asyncs[SCM_SIG_ORD(SCM_INT_SIGNAL)] = scm_system_async (a_thunk); - a_thunk = scm_make_gsubr ("%fpe-thunk", 0, 0, 0, scm_sys_fpe_async_thunk); - system_signal_asyncs[SCM_SIG_ORD(SCM_FPE_SIGNAL)] = scm_system_async (a_thunk); - a_thunk = scm_make_gsubr ("%bus-thunk", 0, 0, 0, scm_sys_bus_async_thunk); - system_signal_asyncs[SCM_SIG_ORD(SCM_BUS_SIGNAL)] = scm_system_async (a_thunk); - a_thunk = scm_make_gsubr ("%segv-thunk", 0, 0, 0, scm_sys_segv_async_thunk); - system_signal_asyncs[SCM_SIG_ORD(SCM_SEGV_SIGNAL)] = scm_system_async (a_thunk); - - - a_thunk = scm_make_gsubr ("%gc-thunk", 0, 0, 0, scm_sys_gc_async_thunk); - system_signal_asyncs[SCM_SIG_ORD(SCM_GC_SIGNAL)] = scm_system_async (a_thunk); - - /* Clock and PC driven conditions are given highest priority. */ - a_thunk = scm_make_gsubr ("%tick-thunk", 0, 0, 0, scm_sys_tick_async_thunk); - system_signal_asyncs[SCM_SIG_ORD(SCM_TICK_SIGNAL)] = scm_system_async (a_thunk); - a_thunk = scm_make_gsubr ("%alrm-thunk", 0, 0, 0, scm_sys_alrm_async_thunk); - system_signal_asyncs[SCM_SIG_ORD(SCM_ALRM_SIGNAL)] = scm_system_async (a_thunk); - - handler_var = scm_sysintern ("signal-handler", strlen ("signal")); - SCM_SETCDR (handler_var, SCM_BOOL_F); - scm_permanent_object (handler_var); -#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 } + +/* + Local Variables: + c-file-style: "gnu" + End: +*/