-/* Copyright (C) 1995,1996 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
* 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. */
+
+
\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 "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
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_P ((SCM));
-
static SCM
-mark_root (root)
- SCM root;
+root_mark (SCM root)
{
scm_root_state *s = SCM_ROOT_STATE (root);
- SCM_SETGC8MARK (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);
- scm_gc_mark (s->top_level_lookup_closure_var);
- scm_gc_mark (s->system_transformer);
- scm_gc_mark (s->the_last_stack_var);
+ /* 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 scm_sizet free_root SCM_P ((SCM));
-
-static scm_sizet
-free_root (root)
- SCM root;
-{
- scm_must_free ((char *) SCM_ROOT_STATE (root));
- return sizeof (scm_root_state);
-}
-
-static int print_root SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
static int
-print_root (exp, port, pstate)
- SCM exp;
- SCM port;
- scm_print_state *pstate;
+root_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
- scm_gen_puts (scm_regular_string, "#<root ", port);
+ scm_puts ("#<root ", port);
scm_intprint(SCM_SEQ (SCM_ROOT_STATE (exp) -> rootcont), 16, port);
- scm_gen_putc('>', port);
+ scm_putc('>', port);
return 1;
}
-static scm_smobfuns root_smob =
-{
- mark_root,
- free_root,
- print_root,
- 0
-};
\f
SCM
-scm_make_root (parent)
- SCM parent;
+scm_make_root (SCM parent)
{
SCM root;
scm_root_state *root_state;
- root_state = (scm_root_state *) scm_must_malloc (sizeof (scm_root_state),
- "scm_make_root");
- if (SCM_NIMP (parent) && SCM_ROOTP (parent))
+ 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));
root_state->parent = parent;
else
{
root_state->parent = SCM_BOOL_F;
+
+ /* Initialize everything right now, in case a GC happens early. */
+ root_state->rootcont
+ = root_state->dynwinds
+ = root_state->progargs
+ = root_state->exitval
+ = root_state->cur_inp
+ = root_state->cur_outp
+ = root_state->cur_errp
+ = root_state->cur_loadp
+ = root_state->fluids
+ = root_state->handle
+ = root_state->parent
+ = SCM_BOOL_F;
}
- SCM_NEWCELL (root);
- SCM_REDEFER_INTS;
- SCM_SETCAR (root, scm_tc16_root);
- SCM_SETCDR (root, root_state);
+
+ 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;
}
* same C stack but under a new root.
*
* Calls to call-with-dynamic-root return exactly once (unless
- * the process is somehow exitted).
- */
+ * the process is somehow exitted). */
/* Some questions about cwdr:
#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 one of these structures, and then passes a pointer
- to it through scm_internal_catch to the cwdr_body function, to tell
- it how to behave.
+/* cwdr fills out both of these structures, and then passes a pointer
+ to them through scm_internal_catch to the cwdr_body and
+ cwdr_handler functions, to tell them how to behave and to get
+ information back from them.
A cwdr is a lot like a catch, except there is no tag (all
exceptions are caught), and the body procedure takes the arguments
- passed to cwdr as A1 and ARGS. */
+ passed to cwdr as A1 and ARGS. The handler is also special since
+ it is not directly run from scm_internal_catch. It is executed
+ outside the new dynamic root. */
struct cwdr_body_data {
/* Arguments to pass to the cwdr body function. */
/* Scheme procedure to use as body of cwdr. */
SCM body_proc;
+};
- /* Scheme handler function to establish. */
- SCM handler;
+struct cwdr_handler_data {
+ /* Do we need to run the handler? */
+ int run_handler;
+
+ /* The tag and args to pass it. */
+ SCM tag, args;
};
With a little thought, we could replace this with scm_body_thunk,
but I don't want to mess with that at the moment. */
static SCM
-cwdr_inner_body (void *data, SCM jmpbuf)
+cwdr_body (void *data)
{
struct cwdr_body_data *c = (struct cwdr_body_data *) data;
return scm_apply (c->body_proc, c->a1, c->args);
}
+/* Record the fact that the body of the cwdr has thrown. Record
+ enough information to invoke the handler later when the dynamic
+ root has been deestablished. */
-/* Invoke the body of a cwdr, assuming that the last-ditch handler has
- been established. The structure DATA points to must live on the
- stack, or else it won't be found by the GC. Establish the user's
- handler, and pass control to cwdr_inner_body, which will invoke the
- users' body. Maybe the user has a nice body. */
static SCM
-cwdr_outer_body (void *data, SCM jmpbuf)
+cwdr_handler (void *data, SCM tag, SCM args)
{
- struct cwdr_body_data *c = (struct cwdr_body_data *) data;
+ struct cwdr_handler_data *c = (struct cwdr_handler_data *) data;
- return scm_internal_catch (SCM_BOOL_T,
- cwdr_inner_body, &c,
- scm_handle_by_proc, &c->handler);
+ c->run_handler = 1;
+ c->tag = tag;
+ c->args = args;
+ return SCM_UNSPECIFIED;
}
/* This is the basic code for new root creation.
* critical. E. g., it is essential that an error doesn't leave Guile
* in a messed up state. */
-static SCM
-cwdr (SCM proc, SCM a1, SCM args, SCM handler, SCM_STACKITEM *stack_start)
+SCM
+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 old_rootcont, old_winds;
+ struct cwdr_handler_data my_handler_data;
SCM answer;
- /* Create a fresh root continuation.
- */
+ /* Create a fresh root continuation. */
{
SCM new_rootcont;
- SCM_NEWCELL (new_rootcont);
+
SCM_REDEFER_INTS;
- SCM_SETJMPBUF (new_rootcont,
- scm_must_malloc ((long) sizeof (scm_contregs),
- "inferior root continuation"));
- 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_DFRAME (old_rootcont) = scm_last_debug_frame;
scm_last_debug_frame = 0;
#endif
-
- /* Catch absolutely all errors. We actually use
- scm_handle_by_message_noexit here, and then install HANDLER in
- cwdr_outer_body, because HANDLER might encounter errors itself. */
- {
- struct cwdr_body_data c;
-
- c.a1 = a1;
- c.args = args;
- c.body_proc = proc;
- c.handler = handler;
+ {
+ my_handler_data.run_handler = 0;
answer = scm_internal_catch (SCM_BOOL_T,
- cwdr_outer_body, &c,
- scm_handle_by_message_noexit, 0);
+ body, body_data,
+ cwdr_handler, &my_handler_data);
}
-
+
scm_dowinds (old_winds, - scm_ilength (old_winds));
SCM_REDEFER_INTS;
#ifdef DEBUG_EXTENSIONS
#endif
scm_rootcont = old_rootcont;
SCM_REALLOW_INTS;
- scm_ints_disabled = old_ints_disabled;
- return answer;
+
+ /* Now run the real handler iff the body did a throw. */
+ if (my_handler_data.run_handler)
+ return handler (handler_data, my_handler_data.tag, my_handler_data.args);
+ else
+ return answer;
}
+/* The original CWDR for invoking Scheme code with a Scheme handler. */
-SCM_PROC(s_call_with_dynamic_root, "call-with-dynamic-root", 2, 0, 0, scm_call_with_dynamic_root);
-SCM
-scm_call_with_dynamic_root (thunk, handler)
- SCM thunk;
- SCM handler;
+static SCM
+cwdr (SCM proc, SCM a1, SCM args, SCM handler, SCM_STACKITEM *stack_start)
{
- SCM_STACKITEM stack_place;
+ struct cwdr_body_data c;
+
+ c.a1 = a1;
+ c.args = args;
+ c.body_proc = proc;
- return cwdr (thunk, SCM_EOL, SCM_EOL, handler, &stack_place);
+ return scm_internal_cwdr (cwdr_body, &c,
+ scm_handle_by_proc, &handler,
+ stack_start);
}
-SCM_PROC(s_dynamic_root, "dynamic-root", 0, 0, 0, scm_dynamic_root);
-SCM
-scm_dynamic_root ()
+SCM_DEFINE (scm_call_with_dynamic_root, "call-with-dynamic-root", 2, 0, 0,
+ (SCM thunk, SCM handler),
+ "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;
+ return cwdr (thunk, SCM_EOL, SCM_EOL, handler, &stack_place);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_dynamic_root, "dynamic-root", 0, 0, 0,
+ (),
+ "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));
}
+#undef FUNC_NAME
SCM
-scm_apply_with_dynamic_root (proc, a1, args, handler)
- SCM proc;
- SCM a1;
- SCM args;
- SCM handler;
+scm_apply_with_dynamic_root (SCM proc, SCM a1, SCM args, SCM handler)
{
SCM_STACKITEM stack_place;
return cwdr (proc, a1, args, handler, &stack_place);
\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 (thunk, err_filter, closure)
- 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_newsmob (&root_smob);
-#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