-/* Copyright (C) 1995,1996,1997,1998, 1999, 2000 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000, 2001, 2002 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
* 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 */
\f
SCM scm_sys_protects[SCM_NUM_PROTECTS];
-scm_bits_t scm_tc16_root;
-
-#ifndef USE_THREADS
-struct scm_root_state *scm_root;
-#endif
+scm_t_bits scm_tc16_root;
\f
scm_gc_mark (s->rootcont);
scm_gc_mark (s->dynwinds);
- scm_gc_mark (s->continuation_stack);
- scm_gc_mark (s->continuation_stack_ptr);
scm_gc_mark (s->progargs);
scm_gc_mark (s->exitval);
scm_gc_mark (s->cur_inp);
scm_gc_mark (s->cur_outp);
scm_gc_mark (s->cur_errp);
- scm_gc_mark (s->def_inp);
- scm_gc_mark (s->def_outp);
- scm_gc_mark (s->def_errp);
/* No need to gc mark def_loadp */
scm_gc_mark (s->fluids);
+ scm_gc_mark (s->active_asyncs);
+ scm_gc_mark (s->signal_asyncs);
return SCM_ROOT_STATE (root) -> parent;
}
static int
-root_print (SCM exp, SCM port, scm_print_state *pstate)
+root_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
scm_puts ("#<root ", port);
scm_intprint(SCM_SEQ (SCM_ROOT_STATE (exp) -> rootcont), 16, port);
SCM root;
scm_root_state *root_state;
- root_state = (scm_root_state *) scm_must_malloc (sizeof (scm_root_state),
- "scm_make_root");
+ root_state = (scm_root_state *) scm_gc_malloc (sizeof (scm_root_state),
+ "root state");
if (SCM_ROOTP (parent))
{
memcpy (root_state, SCM_ROOT_STATE (parent), sizeof (scm_root_state));
/* Initialize everything right now, in case a GC happens early. */
root_state->rootcont
= root_state->dynwinds
- = root_state->continuation_stack
- = root_state->continuation_stack_ptr
= root_state->progargs
= root_state->exitval
= root_state->cur_inp
= root_state->cur_outp
= root_state->cur_errp
- = root_state->def_inp
- = root_state->def_outp
- = root_state->def_errp
= root_state->cur_loadp
= root_state->fluids
= root_state->handle
= root_state->parent
= SCM_BOOL_F;
}
+
+ root_state->active_asyncs = SCM_EOL;
+ root_state->signal_asyncs = SCM_EOL;
+ root_state->block_asyncs = 0;
+ root_state->pending_asyncs = 1;
+
SCM_REDEFER_INTS;
SCM_NEWSMOB (root, scm_tc16_root, root_state);
root_state->handle = root;
#if 0
SCM scm_exitval; /* INUM with return value */
#endif
-static int n_dynamic_roots = 0;
+static long n_dynamic_roots = 0;
/* cwdr fills out both of these structures, and then passes a pointer
* in a messed up state. */
SCM
-scm_internal_cwdr (scm_catch_body_t body, void *body_data,
- scm_catch_handler_t handler, void *handler_data,
+scm_internal_cwdr (scm_t_catch_body body, void *body_data,
+ scm_t_catch_handler handler, void *handler_data,
SCM_STACKITEM *stack_start)
{
int old_ints_disabled = scm_ints_disabled;
SCM_REDEFER_INTS;
{
- scm_contregs *contregs = scm_must_malloc (sizeof (scm_contregs),
- "inferior root continuation");
+ scm_t_contregs *contregs = scm_gc_malloc (sizeof (scm_t_contregs),
+ "continuation");
contregs->num_stack_items = 0;
contregs->dynenv = SCM_EOL;
"Before calling @var{thunk}, the dynamic-wind chain is un-wound back to\n"
"the root and a new chain started for @var{thunk}. Therefore, this call\n"
"may not do what you expect:\n\n"
- "@example\n"
+ "@lisp\n"
";; Almost certainly a bug:\n"
"(with-output-to-port\n"
" some-port\n\n"
" (display 'fnord)\n"
" (newline))\n"
" (lambda (errcode) errcode))))\n"
- "@end example\n\n"
+ "@end lisp\n\n"
"The problem is, on what port will @samp{fnord} be displayed? You\n"
"might expect that because of the @code{with-output-to-port} that\n"
"it will be displayed on the port bound to @code{some-port}. But it\n"
\f
-#if (SCM_DEBUG_DEPRECATED == 0)
-
-/* Call thunk(closure) underneath a top-level error handler.
- * If an error occurs, pass the exitval through err_filter and return it.
- * If no error occurs, return the value of thunk.
- */
-
-#ifdef _UNICOS
-typedef int setjmp_type;
-#else
-typedef long setjmp_type;
-#endif
-
-
-SCM
-scm_call_catching_errors (SCM (*thunk)(), SCM (*err_filter)(), void *closure)
-{
- SCM answer;
- setjmp_type i;
-#ifdef DEBUG_EXTENSIONS
- SCM_DFRAME (scm_rootcont) = scm_last_debug_frame;
-#endif
- i = setjmp (SCM_JMPBUF (scm_rootcont));
- scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
- if (!i)
- {
- scm_gc_heap_lock = 0;
- answer = thunk (closure);
- }
- else
- {
- scm_gc_heap_lock = 1;
- answer = err_filter (scm_exitval, closure);
- }
- return answer;
-}
-
-#endif /* SCM_DEBUG_DEPRECATED == 0 */
-
-
void
scm_init_root ()
{
scm_set_smob_mark (scm_tc16_root, root_mark);
scm_set_smob_print (scm_tc16_root, root_print);
-#ifndef SCM_MAGIC_SNARFER
#include "libguile/root.x"
-#endif
}
/*