X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/e93ffe595cf5eee18fb7cdd4e04be37ae1d38423..9bc6fb0a7d91ae9a6c57cedb76022043db413ba5:/libguile/root.c diff --git a/libguile/root.c b/libguile/root.c index 9fb6fbd8b..389c2247b 100644 --- a/libguile/root.c +++ b/libguile/root.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999,2000, 2001 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 @@ -12,7 +12,8 @@ * * 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,26 +37,28 @@ * * 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. */ + + -#include -#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 +#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" SCM scm_sys_protects[SCM_NUM_PROTECTS]; -long scm_tc16_root; +scm_t_bits scm_tc16_root; #ifndef USE_THREADS struct scm_root_state *scm_root; @@ -63,18 +66,13 @@ struct scm_root_state *scm_root; -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); @@ -83,123 +81,185 @@ mark_root (root) 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_thunk_var); - scm_gc_mark (s->system_transformer); + /* No need to gc mark def_loadp */ + scm_gc_mark (s->fluids); 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, "# rootcont), 16, port); - scm_gen_putc('>', port); + scm_putc('>', port); return 1; } -static scm_smobfuns root_smob = -{ - mark_root, - free_root, - print_root, - 0 -}; 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)); + scm_copy_fluids (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->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; } - SCM_NEWCELL (root); SCM_REDEFER_INTS; - SCM_SETCAR (root, scm_tc16_root); - SCM_SETCDR (root, root_state); + SCM_NEWSMOB (root, scm_tc16_root, root_state); root_state->handle = root; SCM_REALLOW_INTS; return root; } -/* {call-with-new-root} +/* {call-with-dynamic-root} * * Suspending the current thread to evaluate a thunk on the * same C stack but under a new root. * - * Calls to call-with-new-root return exactly once (unless - * the process is somehow exitted). - */ + * Calls to call-with-dynamic-root return exactly once (unless + * the process is somehow exitted). */ + +/* Some questions about cwdr: + + Couldn't the body just be a closure? Do we really need to pass + args through to it? + + The semantics are a lot like catch's; in fact, we call + scm_internal_catch to take care of that part of things. Wouldn't + it be cleaner to say that uncaught throws just disappear into the + ether (or print a message to stderr), and let the caller use catch + themselves if they want to? + + -JimB */ #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 + 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. The handler is also special since + it is not directly run from scm_internal_catch. It is executed + outside the new dynamic root. */ -static SCM cwdr SCM_P ((SCM thunk, SCM a1, SCM args, SCM handler, SCM_STACKITEM *stack_start)); +struct cwdr_body_data { + /* Arguments to pass to the cwdr body function. */ + SCM a1, args; + + /* Scheme procedure to use as body of cwdr. */ + SCM body_proc; +}; + +struct cwdr_handler_data { + /* Do we need to run the handler? */ + int run_handler; + + /* The tag and args to pass it. */ + SCM tag, args; +}; + + +/* Invoke the body of a cwdr, assuming that the throw handler has + already been set up. DATA points to a struct set up by cwdr that + says what proc to call, and what args to apply it to. + + 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_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. */ + +static SCM +cwdr_handler (void *data, SCM tag, SCM args) +{ + struct cwdr_handler_data *c = (struct cwdr_handler_data *) data; + + c->run_handler = 1; + c->tag = tag; + c->args = args; + return SCM_UNSPECIFIED; +} /* This is the basic code for new root creation. * * WARNING! The order of actions in this routine is in many ways * critical. E. g., it is essential that an error doesn't leave Guile - * in a messed up state. - */ + * in a messed up state. */ -static SCM -cwdr (proc, a1, args, handler, stack_start) - 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 (regs), - "inferior root continuation")); - SCM_CAR (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; @@ -210,63 +270,107 @@ cwdr (proc, a1, args, handler, stack_start) old_winds = scm_dynwinds; scm_dowinds (SCM_EOL, scm_ilength (scm_dynwinds)); #ifdef DEBUG_EXTENSIONS + SCM_DFRAME (old_rootcont) = scm_last_debug_frame; scm_last_debug_frame = 0; #endif - - /* Catch all errors. */ - answer = scm_catch_apply (SCM_BOOL_T, proc, a1, args, handler); - + + { + my_handler_data.run_handler = 0; + answer = scm_internal_catch (SCM_BOOL_T, + body, body_data, + cwdr_handler, &my_handler_data); + } + scm_dowinds (old_winds, - scm_ilength (old_winds)); SCM_REDEFER_INTS; - scm_rootcont = old_rootcont; #ifdef DEBUG_EXTENSIONS - scm_last_debug_frame = SCM_DFRAME (scm_rootcont); + scm_last_debug_frame = SCM_DFRAME (old_rootcont); #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); -#ifdef __STDC__ -SCM -scm_call_with_dynamic_root (SCM thunk, SCM handler) -#else -SCM -scm_call_with_dynamic_root (thunk, handler) - SCM thunk; - SCM handler; -#endif +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); -#ifdef __STDC__ -SCM -scm_dynamic_root (void) -#else -SCM -scm_dynamic_root () -#endif +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 -#ifdef __STDC__ SCM scm_apply_with_dynamic_root (SCM proc, SCM a1, SCM args, SCM handler) -#else -SCM -scm_apply_with_dynamic_root (proc, a1, args, handler) - SCM proc; - SCM a1; - SCM args; - SCM error; -#endif { SCM_STACKITEM stack_place; return cwdr (proc, a1, args, handler, &stack_place); @@ -274,55 +378,20 @@ scm_apply_with_dynamic_root (proc, a1, args, handler) -/* 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 - - -#ifdef __STDC__ -SCM -scm_call_catching_errors (SCM (*thunk)(), SCM (*err_filter)(), void *closure) -#else -SCM -scm_call_catching_errors (thunk, err_filter, closure) - SCM (*thunk)(); - SCM (*err_filter)(); - void *closure; -#endif -{ - SCM answer; - setjmp_type i; -#ifdef DEBUG_EXTENSIONS - SCM_DFRAME (scm_rootcont) = scm_last_debug_frame; -#endif - i = setjmp (SCM_JMPBUF (scm_rootcont)); -#ifdef STACK_CHECKING - scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P; -#endif - 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); + +#ifndef SCM_MAGIC_SNARFER +#include "libguile/root.x" +#endif } + +/* + Local Variables: + c-file-style: "gnu" + End: +*/