-/* 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
* 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
-#include <stdio.h>
-#include "_scm.h"
-#include "stackchk.h"
-#include "dynwind.h"
-#include "eval.h"
-#include "genio.h"
-#include "smob.h"
-#include "pairs.h"
-#include "throw.h"
-#include "fluids.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));
/* 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;
}
+
+ 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)
{
-#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;
/* 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_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.
-
-If an error occurs during evaluation, apply @var{handler} to the
-arguments to the throw, just as @code{throw} would. If this happens,
-@var{handler} is called outside the scope of the new root -- it is
-called in the same dynamic context in which
-@code{call-with-dynamic-root} was evaluated.
-
-If @var{thunk} captures a continuation, the continuation is rooted at
-the call to @var{thunk}. In particular, the call to
-@code{call-with-dynamic-root} is not captured. Therefore,
-@code{call-with-dynamic-root} always returns at most one time.
-
-Before calling @var{thunk}, the dynamic-wind chain is un-wound back to
-the root and a new chain started for @var{thunk}. Therefore, this call
-may not do what you expect:
-
-@example
-;; Almost certainly a bug:
-(with-output-to-port
- some-port
-
- (lambda ()
- (call-with-dynamic-root
- (lambda ()
- (display 'fnord)
- (newline))
- (lambda (errcode) errcode))))
-@end example
-
-The problem is, on what port will @samp{fnord\n} be displayed? You
-might expect that because of the @code{with-output-to-port} that
-it will be displayed on the port bound to @code{some-port}. But it
-probably won't -- before evaluating the thunk, dynamic winds are
-unwound, including those created by @code{with-output-to-port}.
-So, the standard output port will have been re-set to its default value
-before @code{display} is evaluated.
-
-(This function was added to Guile mostly to help calls to functions in C
-libraries that can not tolerate non-local exits or calls that return
-multiple times. If such functions call back to the interpreter, it should
-be under a new dynamic root.)")
+ "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"
+ "called in the same dynamic context in which\n"
+ "@code{call-with-dynamic-root} was evaluated.\n\n"
+ "If @var{thunk} captures a continuation, the continuation is rooted at\n"
+ "the call to @var{thunk}. In particular, the call to\n"
+ "@code{call-with-dynamic-root} is not captured. Therefore,\n"
+ "@code{call-with-dynamic-root} always returns at most one time.\n\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"
+ "@lisp\n"
+ ";; Almost certainly a bug:\n"
+ "(with-output-to-port\n"
+ " some-port\n\n"
+ " (lambda ()\n"
+ " (call-with-dynamic-root\n"
+ " (lambda ()\n"
+ " (display 'fnord)\n"
+ " (newline))\n"
+ " (lambda (errcode) errcode))))\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"
+ "unwound, including those created by @code{with-output-to-port}.\n"
+ "So, the standard output port will have been re-set to its default value\n"
+ "before @code{display} is evaluated.\n\n"
+ "(This function was added to Guile mostly to help calls to functions in C\n"
+ "libraries that can not tolerate non-local exits or calls that return\n"
+ "multiple times. If such functions call back to the interpreter, it should\n"
+ "be under a new dynamic root.)")
#define FUNC_NAME s_scm_call_with_dynamic_root
{
SCM_STACKITEM stack_place;
SCM_DEFINE (scm_dynamic_root, "dynamic-root", 0, 0, 0,
(),
-"Return an object representing the current dynamic root.
-
-These objects are only useful for comparison using @code{eq?}.
-They are currently represented as numbers, but your code should
-in no way depend on this.")
+ "Return an object representing the current dynamic root.\n\n"
+ "These objects are only useful for comparison using @code{eq?}.\n"
+ "They are currently represented as numbers, but your code should\n"
+ "in no way depend on this.")
#define FUNC_NAME s_scm_dynamic_root
{
return scm_ulong2num (SCM_SEQ (scm_root->rootcont));
\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