-/* Copyright (C) 1995,1996, 1997 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998, 1999 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. */
+
+/* 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 "stackchk.h"
#include "dynwind.h"
#include "eval.h"
-#include "genio.h"
#include "smob.h"
#include "pairs.h"
#include "throw.h"
#include "fluids.h"
+#include "ports.h"
#include "root.h"
\f
\f
-static SCM mark_root SCM_P ((SCM));
-
static SCM
-mark_root (root)
- SCM root;
+mark_root (SCM root)
{
scm_root_state *s = SCM_ROOT_STATE (root);
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;
+print_root (SCM exp,SCM port,scm_print_state *pstate)
{
scm_puts ("#<root ", port);
scm_intprint(SCM_SEQ (SCM_ROOT_STATE (exp) -> rootcont), 16, 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))
+ if (SCM_ROOTP (parent))
{
memcpy (root_state, SCM_ROOT_STATE (parent), sizeof (scm_root_state));
scm_copy_fluids (root_state);
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->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_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;
SCM_STACKITEM *stack_start)
{
#ifdef USE_STACKJMPBUF
- scm_contregs static_jmpbuf;
+ scm_contregs static_contregs;
#endif
int old_ints_disabled = scm_ints_disabled;
SCM old_rootcont, old_winds;
SCM_NEWCELL (new_rootcont);
SCM_REDEFER_INTS;
#ifdef USE_STACKJMPBUF
- SCM_SETJMPBUF (new_rootcont, &static_jmpbuf);
+ SCM_SET_CONTREGS (new_rootcont, &static_contregs);
#else
- SCM_SETJMPBUF (new_rootcont,
- scm_must_malloc ((long) sizeof (scm_contregs),
- "inferior root continuation"));
+ SCM_SET_CONTREGS (new_rootcont,
+ scm_must_malloc (sizeof (scm_contregs),
+ "inferior root continuation"));
#endif
SCM_SETCAR (new_rootcont, scm_tc7_contin);
SCM_DYNENV (new_rootcont) = SCM_EOL;
scm_dowinds (old_winds, - scm_ilength (old_winds));
SCM_REDEFER_INTS;
#ifdef USE_STACKCJMPBUF
- SCM_SETJMPBUF (scm_rootcont, NULL);
+ SCM_SET_CONTREGS (scm_rootcont, NULL);
#endif
#ifdef DEBUG_EXTENSIONS
scm_last_debug_frame = SCM_DFRAME (old_rootcont);
stack_start);
}
-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;
+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"
+ "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"
+ "@example\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 example\n\n"
+ "The problem is, on what port will @samp{fnord\n"
+ "} 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);
}
-
-SCM_PROC(s_dynamic_root, "dynamic-root", 0, 0, 0, scm_dynamic_root);
-SCM
-scm_dynamic_root ()
+#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);
SCM
-scm_call_catching_errors (thunk, err_filter, closure)
- SCM (*thunk)();
- SCM (*err_filter)();
- void *closure;
+scm_call_catching_errors (SCM (*thunk)(), SCM (*err_filter)(), void *closure)
{
SCM answer;
setjmp_type i;
void
scm_init_root ()
{
- scm_tc16_root = scm_newsmob (&root_smob);
+ scm_tc16_root = scm_make_smob_type_mfpe ("root", sizeof (struct scm_root_state),
+ mark_root, NULL, print_root, NULL);
+
#include "root.x"
}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
HCoop / bpt / guile.git / blobdiff