summaryrefslogtreecommitdiff
path: root/libguile/root.c
diff options
context:
space:
mode:
authorMarius Vollmer <mvo@zagadka.de>2005-03-02 20:42:01 +0000
committerMarius Vollmer <mvo@zagadka.de>2005-03-02 20:42:01 +0000
commit9de87eea47536e25ef99bc25f07afdd759ee3575 (patch)
tree936d52588ace67469aba68f6ad47cbf1a12462ca /libguile/root.c
parentcb1cfc42a4f5ac4d60a64b425795432a0388ad7e (diff)
downloadguile-9de87eea47536e25ef99bc25f07afdd759ee3575.tar.gz
See ChangeLog from 2005-03-02.
Diffstat (limited to 'libguile/root.c')
-rw-r--r--libguile/root.c171
1 files changed, 18 insertions, 153 deletions
diff --git a/libguile/root.c b/libguile/root.c
index dfe0ae313..07209c95c 100644
--- a/libguile/root.c
+++ b/libguile/root.c
@@ -19,6 +19,8 @@
#include <string.h>
+#include <stdio.h>
+
#include "libguile/_scm.h"
#include "libguile/stackchk.h"
#include "libguile/dynwind.h"
@@ -34,89 +36,8 @@
SCM scm_sys_protects[SCM_NUM_PROTECTS];
-scm_t_bits scm_tc16_root;
-
-
-
-static SCM
-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->progargs);
- scm_gc_mark (s->exitval);
- scm_gc_mark (s->cur_inp);
- scm_gc_mark (s->cur_outp);
- scm_gc_mark (s->cur_errp);
- /* 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 int
-root_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
-{
- scm_puts ("#<root ", port);
- scm_uintprint(SCM_SEQ (SCM_ROOT_STATE (exp) -> rootcont), 16, port);
- scm_putc('>', port);
- return 1;
-}
-
-
-SCM
-scm_make_root (SCM parent)
-{
- SCM root;
- scm_root_state *root_state;
-
- 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;
- }
-
- 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;
-
- if (SCM_ROOTP (parent))
- /* Must be done here so that fluids are GC protected */
- scm_i_copy_fluids (root_state);
-
- return root;
-}
-
/* {call-with-dynamic-root}
*
* Suspending the current thread to evaluate a thunk on the
@@ -125,25 +46,6 @@ scm_make_root (SCM parent)
* 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 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
@@ -201,62 +103,31 @@ cwdr_handler (void *data, SCM tag, SCM 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. */
-
SCM
scm_internal_cwdr (scm_t_catch_body body, void *body_data,
scm_t_catch_handler handler, void *handler_data,
SCM_STACKITEM *stack_start)
{
- SCM old_rootcont, old_winds;
struct cwdr_handler_data my_handler_data;
- SCM answer;
-
- /* Create a fresh root continuation. */
- {
- SCM new_rootcont;
-
- SCM_REDEFER_INTS;
- {
- 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;
- contregs->dframe = 0;
- SCM_NEWSMOB (new_rootcont, scm_tc16_continuation, contregs);
- }
- old_rootcont = scm_rootcont;
- scm_rootcont = new_rootcont;
- SCM_REALLOW_INTS;
- }
+ SCM answer, old_winds;
/* Exit caller's dynamic state.
*/
- old_winds = scm_dynwinds;
- scm_dowinds (SCM_EOL, scm_ilength (scm_dynwinds));
- SCM_DFRAME (old_rootcont) = scm_last_debug_frame;
- scm_last_debug_frame = 0;
-
- {
- my_handler_data.run_handler = 0;
- answer = scm_internal_catch (SCM_BOOL_T,
- body, body_data,
- cwdr_handler, &my_handler_data);
- }
+ old_winds = scm_i_dynwinds ();
+ scm_dowinds (SCM_EOL, scm_ilength (old_winds));
+
+ scm_frame_begin (SCM_F_FRAME_REWINDABLE);
+ scm_frame_current_dynamic_state (scm_make_dynamic_state (SCM_UNDEFINED));
+ my_handler_data.run_handler = 0;
+ answer = scm_i_with_continuation_barrier (body, body_data,
+ cwdr_handler, &my_handler_data);
+
+ scm_frame_end ();
+
+ /* Enter caller's dynamic state.
+ */
scm_dowinds (old_winds, - scm_ilength (old_winds));
- SCM_REDEFER_INTS;
- scm_last_debug_frame = SCM_DFRAME (old_rootcont);
- scm_rootcont = old_rootcont;
- SCM_REALLOW_INTS;
/* Now run the real handler iff the body did a throw. */
if (my_handler_data.run_handler)
@@ -328,12 +199,10 @@ SCM_DEFINE (scm_call_with_dynamic_root, "call-with-dynamic-root", 2, 0, 0,
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.")
+ "These objects are only useful for comparison using @code{eq?}.\n")
#define FUNC_NAME s_scm_dynamic_root
{
- return scm_from_ulong (SCM_SEQ (scm_root->rootcont));
+ return SCM_I_CURRENT_THREAD->continuation_root;
}
#undef FUNC_NAME
@@ -349,10 +218,6 @@ scm_apply_with_dynamic_root (SCM proc, SCM a1, SCM args, SCM handler)
void
scm_init_root ()
{
- 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"
}