-/* Copyright (C) 1995,1996,1997,1998, 1999 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
- * 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, 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.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
*
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
+ * This library 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
+ * Lesser General Public License for more details.
*
- * 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. */
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+ */
-/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
- gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
\f
-#include <stdio.h>
-#include "_scm.h"
-#include "stackchk.h"
-#include "dynwind.h"
-#include "eval.h"
-#include "smob.h"
-#include "pairs.h"
-#include "throw.h"
-#include "fluids.h"
-#include "ports.h"
-
-#include "root.h"
+#include <string.h>
+#include "libguile/_scm.h"
+#include "libguile/stackchk.h"
+#include "libguile/dynwind.h"
+#include "libguile/eval.h"
+#include "libguile/smob.h"
+#include "libguile/pairs.h"
+#include "libguile/throw.h"
+#include "libguile/fluids.h"
+#include "libguile/ports.h"
+
+#include "libguile/root.h"
\f
-/* Define this if you want to try out the stack allocation of cwdr's
- jumpbuf. It works for me but I'm still worried that the dynwinds
- might be able to make a mess. */
-
-#undef USE_STACKJMPBUF
-
SCM scm_sys_protects[SCM_NUM_PROTECTS];
-long scm_tc16_root;
-
-#ifndef USE_THREADS
-struct scm_root_state *scm_root;
-#endif
+scm_t_bits scm_tc16_root;
\f
static SCM
-mark_root (SCM root)
+root_mark (SCM root)
{
scm_root_state *s = SCM_ROOT_STATE (root);
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->top_level_lookup_closure_var);
- scm_gc_mark (s->system_transformer);
+ scm_gc_mark (s->active_asyncs);
+ scm_gc_mark (s->signal_asyncs);
return SCM_ROOT_STATE (root) -> parent;
}
static int
-print_root (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));
- scm_copy_fluids (root_state);
root_state->parent = parent;
}
else
/* 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->system_transformer
- = root_state->top_level_lookup_closure_var
= root_state->handle
= root_state->parent
= SCM_BOOL_F;
}
- SCM_REDEFER_INTS;
+
+ root_state->active_asyncs = SCM_EOL;
+ root_state->signal_asyncs = SCM_EOL;
+ root_state->block_asyncs = 0;
+ root_state->pending_asyncs = 1;
+
SCM_NEWSMOB (root, scm_tc16_root, root_state);
root_state->handle = root;
- SCM_REALLOW_INTS;
+
+ if (SCM_ROOTP (parent))
+ /* Must be done here so that fluids are GC protected */
+ scm_copy_fluids (root_state);
+
return 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)
{
-#ifdef USE_STACKJMPBUF
- scm_contregs static_jmpbuf;
-#endif
- int old_ints_disabled = scm_ints_disabled;
SCM old_rootcont, old_winds;
struct cwdr_handler_data my_handler_data;
SCM answer;
/* Create a fresh root continuation. */
{
SCM new_rootcont;
- SCM_NEWCELL (new_rootcont);
+
SCM_REDEFER_INTS;
-#ifdef USE_STACKJMPBUF
- SCM_SETJMPBUF (new_rootcont, &static_jmpbuf);
-#else
- SCM_SETJMPBUF (new_rootcont,
- scm_must_malloc ((long) sizeof (scm_contregs),
- "inferior root continuation"));
-#endif
- SCM_SETCAR (new_rootcont, scm_tc7_contin);
- SCM_DYNENV (new_rootcont) = SCM_EOL;
- SCM_BASE (new_rootcont) = stack_start;
- SCM_SEQ (new_rootcont) = ++n_dynamic_roots;
+ {
+ scm_t_contregs *contregs = scm_gc_malloc (sizeof (scm_t_contregs),
+ "continuation");
+
+ contregs->num_stack_items = 0;
+ contregs->dynenv = SCM_EOL;
+ contregs->base = stack_start;
+ contregs->seq = ++n_dynamic_roots;
+ contregs->throw_value = SCM_BOOL_F;
#ifdef DEBUG_EXTENSIONS
- SCM_DFRAME (new_rootcont) = 0;
+ contregs->dframe = 0;
#endif
+ SCM_NEWSMOB (new_rootcont, scm_tc16_continuation, contregs);
+ }
old_rootcont = scm_rootcont;
scm_rootcont = new_rootcont;
SCM_REALLOW_INTS;
scm_dowinds (old_winds, - scm_ilength (old_winds));
SCM_REDEFER_INTS;
-#ifdef USE_STACKCJMPBUF
- SCM_SETJMPBUF (scm_rootcont, NULL);
-#endif
#ifdef DEBUG_EXTENSIONS
scm_last_debug_frame = SCM_DFRAME (old_rootcont);
#endif
scm_rootcont = old_rootcont;
SCM_REALLOW_INTS;
- scm_ints_disabled = old_ints_disabled;
/* Now run the real handler iff the body did a throw. */
if (my_handler_data.run_handler)
SCM_DEFINE (scm_call_with_dynamic_root, "call-with-dynamic-root", 2, 0, 0,
(SCM thunk, SCM handler),
- "Evaluate @var{(thunk)} in a new dynamic context, returning its value.\n\n"
+ "Evaluate @code{(thunk)} in a new dynamic context, returning its value.\n\n"
"If an error occurs during evaluation, apply @var{handler} to the\n"
"arguments to the throw, just as @code{throw} would. If this happens,\n"
"@var{handler} is called outside the scope of the new root -- it is\n"
"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"
- "The problem is, on what port will @samp{fnord\n"
- "} be displayed? You\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"
"probably won't -- before evaluating the thunk, dynamic winds are\n"
\f
-/* 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;
-}
-
void
scm_init_root ()
{
- scm_tc16_root = scm_make_smob_type_mfpe ("root", sizeof (struct scm_root_state),
- mark_root, NULL, print_root, NULL);
-
-#include "root.x"
+ scm_tc16_root = scm_make_smob_type ("root", sizeof (struct scm_root_state));
+ scm_set_smob_mark (scm_tc16_root, root_mark);
+ scm_set_smob_print (scm_tc16_root, root_print);
+
+#include "libguile/root.x"
}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
HCoop / bpt / guile.git / blobdiff