-/* Copyright (C) 1995,1996,1997,1998, 1999, 2000 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
* 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 <string.h>
#include "libguile/_scm.h"
#include "libguile/stackchk.h"
#include "libguile/dynwind.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;
+scm_t_bits scm_tc16_root;
#ifndef USE_THREADS
struct scm_root_state *scm_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);
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
#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_contregs;
-#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_SET_CONTREGS (new_rootcont, &static_contregs);
-#else
- SCM_SET_CONTREGS (new_rootcont,
- scm_must_malloc (sizeof (scm_contregs),
- "inferior root continuation"));
-#endif
- SCM_SET_CELL_TYPE (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_SET_CONTREGS (scm_rootcont, NULL);
-#endif
#ifdef DEBUG_EXTENSIONS
scm_last_debug_frame = SCM_DFRAME (old_rootcont);
#endif
"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_tc16_root = scm_make_smob_type ("root", sizeof (struct scm_root_state));
- scm_set_smob_mark (scm_tc16_root, mark_root);
- scm_set_smob_print (scm_tc16_root, print_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
}
/*
HCoop / bpt / guile.git / blobdiff