summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/ChangeLog34
-rw-r--r--libguile/continuations.c209
-rw-r--r--libguile/continuations.h31
-rw-r--r--libguile/debug.c2
-rw-r--r--libguile/eval.c65
-rw-r--r--libguile/gc.c14
-rw-r--r--libguile/hash.c1
-rw-r--r--libguile/init.c14
-rw-r--r--libguile/print.c7
-rw-r--r--libguile/procprop.c1
-rw-r--r--libguile/procs.c4
-rw-r--r--libguile/root.c38
-rw-r--r--libguile/stacks.c6
-rw-r--r--libguile/tags.h2
14 files changed, 229 insertions, 199 deletions
diff --git a/libguile/ChangeLog b/libguile/ChangeLog
index 9d6d19237..d7d3d8ca4 100644
--- a/libguile/ChangeLog
+++ b/libguile/ChangeLog
@@ -1,3 +1,37 @@
+2000-11-25 Gary Houston <ghouston@arglist.com>
+
+ * use an applicable SMOB to represent continuations, instead of a
+ custom tc7 type. This will make it easier to support R5RS
+ multiple value continuations, without the use of a Scheme-level
+ wrapper.
+
+ * continuations.c (scm_tc16_continuation, continuation_mark,
+ continuation_free, continuation_print, continuation_apply):
+ new SMOB support.
+ (scm_make_continuation): new procedure, replaces scm_make_cont
+ with a different interface.
+ (copy_stack_and_call, scm_dynthrow, scm_init_continuations): rewritten.
+ (CHEAP_CONTINUATIONS): removed non-working code completely.
+ (scm_call_continuation): removed.
+ * continuations.h (struct scm_contregs): add num_stack_items and
+ stack fields. previously stack was stored following this struct:
+ use a tail array instead.
+ (SCM_CONTINUATIONP): new macro.
+ (SCM_CONTINUATION_LENGTH, SCM_SET_CONTINUATION_LENGTH):
+ rewritten.
+ (SCM_SET_CONTREGS): removed.
+ * tags.h: removed scm_tc7_contin (was tag 61).
+ * debug.c, gc.c, hash.c, print.c, procprop.c, procs.c:
+ removed scm_tc7_contin support.
+ * eval.c: use scm_make_continuation instead of scm_make_cont.
+ don't set jump buffers here. remove scm_tc7_contin support.
+ * init.c, root.c: create SMOB continuation for rootcont instead
+ of scm_tc7_contin. call scm_init_continuations before
+ scm_init_root.
+ * root.c: remove support for static jmpbuf. It's not used by
+ default and I broke it. create SMOB continuation for rootcont.
+ * stacks.c: use SCM_CONTINUATIONP.
+
2000-11-24 Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de>
* goops.c (filter_cpl, remove_duplicate_slots), goops.h
diff --git a/libguile/continuations.c b/libguile/continuations.c
index ca647b154..108465d03 100644
--- a/libguile/continuations.c
+++ b/libguile/continuations.c
@@ -48,10 +48,13 @@
#include "libguile/_scm.h"
#include "libguile/root.h"
#include "libguile/stackchk.h"
+#include "libguile/smob.h"
+#include "libguile/ports.h"
+#include "libguile/dynwind.h"
+
#ifdef DEBUG_EXTENSIONS
#include "libguile/debug.h"
#endif
-#include "libguile/dynwind.h"
#include "libguile/continuations.h"
@@ -60,52 +63,92 @@
/* {Continuations}
*/
-static char s_cont[] = "continuation";
+scm_bits_t scm_tc16_continuation;
-static void scm_dynthrow (SCM, SCM);
+static SCM continuation_mark (SCM obj)
+{
+ scm_contregs *continuation = SCM_CONTREGS (obj);
+ scm_gc_mark (continuation->throw_value);
+ scm_mark_locations (continuation->stack, continuation->num_stack_items);
+ return continuation->dynenv;
+}
-#ifndef CHEAP_CONTINUATIONS
+static scm_sizet continuation_free (SCM obj)
+{
+ scm_contregs *continuation = SCM_CONTREGS (obj);
+ /* stack array size is 1 if num_stack_items is 0 (rootcont). */
+ scm_sizet extra_items = (continuation->num_stack_items > 0)
+ ? (continuation->num_stack_items - 1)
+ : 0;
+ scm_sizet bytes_free = sizeof (scm_contregs)
+ + extra_items * sizeof (SCM_STACKITEM);
+
+ scm_must_free (continuation);
+ return bytes_free;
+}
+static int continuation_print (SCM obj, SCM port, scm_print_state *state)
+{
+ scm_contregs *continuation = SCM_CONTREGS (obj);
+
+ scm_puts ("#<continuation ", port);
+ scm_intprint (continuation->num_stack_items, 10, port);
+ scm_puts (" @ ", port);
+ scm_intprint (SCM_CELL_WORD_1 (obj), 16, port);
+ scm_putc ('>', port);
+ return 1;
+}
+/* this may return more than once: the first time with the escape
+ procedure, then subsequently with the value to be passed to the
+ continuation. */
+#define FUNC_NAME "scm_make_continuation"
SCM
-scm_make_cont (SCM *answer)
+scm_make_continuation (int *first)
{
- long j;
SCM cont;
+ scm_contregs *continuation;
+ scm_contregs *rootcont = SCM_CONTREGS (scm_rootcont);
+ long stack_size;
SCM_STACKITEM * src;
- SCM_STACKITEM * dst;
- SCM_NEWCELL (cont);
- *answer = cont;
SCM_ENTER_A_SECTION;
SCM_FLUSH_REGISTER_WINDOWS;
- j = scm_stack_size (SCM_BASE (scm_rootcont));
- SCM_SET_CONTREGS (cont,
- scm_must_malloc (sizeof (scm_contregs)
- + j * sizeof (SCM_STACKITEM),
- s_cont));
- SCM_DYNENV (cont) = scm_dynwinds;
- SCM_THROW_VALUE (cont) = SCM_EOL;
- src = SCM_BASE (cont) = SCM_BASE (scm_rootcont);
- SCM_SEQ (cont) = SCM_SEQ (scm_rootcont);
- SCM_SET_CONTINUATION_LENGTH (cont, j);
- SCM_EXIT_A_SECTION;
-#ifndef SCM_STACK_GROWS_UP
- src -= SCM_CONTINUATION_LENGTH (cont);
-#endif /* ndef SCM_STACK_GROWS_UP */
- dst = (SCM_STACKITEM *) ((char *) SCM_CONTREGS (cont) + sizeof (scm_contregs));
-
- /* memcpy should be safe: src and dst will never overlap */
- memcpy (dst, src, sizeof (SCM_STACKITEM) * SCM_CONTINUATION_LENGTH (cont));
-
+ stack_size = scm_stack_size (rootcont->base);
+ continuation = scm_must_malloc (sizeof (scm_contregs)
+ + (stack_size - 1) * sizeof (SCM_STACKITEM),
+ FUNC_NAME);
+ continuation->num_stack_items = stack_size;
+ continuation->dynenv = scm_dynwinds;
+ continuation->throw_value = SCM_EOL;
+ continuation->base = src = rootcont->base;
+ continuation->seq = rootcont->seq;
#ifdef DEBUG_EXTENSIONS
- SCM_DFRAME (cont) = scm_last_debug_frame;
+ continuation->dframe = scm_last_debug_frame;
#endif
+ SCM_NEWSMOB (cont, scm_tc16_continuation, continuation);
+ SCM_EXIT_A_SECTION;
- return cont;
+#ifndef SCM_STACK_GROWS_UP
+ src -= stack_size;
+#endif
+ memcpy (continuation->stack, src, sizeof (SCM_STACKITEM) * stack_size);
+
+ if (setjmp (continuation->jmpbuf))
+ {
+ *first = 0;
+ return continuation->throw_value;
+ }
+ else
+ {
+ *first = 1;
+ return cont;
+ }
}
+#undef FUNC_NAME
+static void scm_dynthrow (SCM, SCM);
/* Grow the stack by a fixed amount to provide space to copy in the
* continuation. Possibly this function has to be called several times
@@ -131,18 +174,18 @@ grow_stack (SCM cont, SCM val)
* own frame are overwritten. Thus, memcpy can be used for best performance.
*/
static void
-copy_stack_and_call (SCM cont, SCM val,
- SCM_STACKITEM * src, SCM_STACKITEM * dst)
+copy_stack_and_call (scm_contregs *continuation, SCM val,
+ SCM_STACKITEM * dst)
{
- /* memcpy should be safe: src and dst will never overlap */
- memcpy (dst, src, sizeof (SCM_STACKITEM) * SCM_CONTINUATION_LENGTH (cont));
+ memcpy (dst, continuation->stack,
+ sizeof (SCM_STACKITEM) * continuation->num_stack_items);
#ifdef DEBUG_EXTENSIONS
- scm_last_debug_frame = SCM_DFRAME (cont);
+ scm_last_debug_frame = continuation->dframe;
#endif
- SCM_THROW_VALUE (cont) = val;
- longjmp (SCM_JMPBUF (cont), 1);
+ continuation->throw_value = val;
+ longjmp (continuation->jmpbuf, 1);
}
@@ -153,94 +196,60 @@ copy_stack_and_call (SCM cont, SCM val,
static void
scm_dynthrow (SCM cont, SCM val)
{
- SCM_STACKITEM * src;
+ scm_contregs *continuation = SCM_CONTREGS (cont);
SCM_STACKITEM * dst = SCM_BASE (scm_rootcont);
SCM_STACKITEM stack_top_element;
#ifdef SCM_STACK_GROWS_UP
- if (SCM_PTR_GE (dst + SCM_CONTINUATION_LENGTH (cont), & stack_top_element))
+ if (SCM_PTR_GE (dst + continuation->num_stack_items, &stack_top_element))
grow_stack (cont, val);
#else
- dst -= SCM_CONTINUATION_LENGTH (cont);
- if (SCM_PTR_LE (dst, & stack_top_element))
+ dst -= continuation->num_stack_items;
+ if (SCM_PTR_LE (dst, &stack_top_element))
grow_stack (cont, val);
#endif /* def SCM_STACK_GROWS_UP */
- SCM_FLUSH_REGISTER_WINDOWS;
- src = (SCM_STACKITEM *) ((char *) SCM_CONTREGS (cont) + sizeof (scm_contregs));
- copy_stack_and_call (cont, val, src, dst);
-}
-
-
-#else /* ifndef CHEAP_CONTINUATIONS */
-
-/* Dirk:FIXME:: It seems that nobody has ever tried to use this code, since it
- * contains syntactic errors and thus would not have compiled anyway.
- */
-
-SCM
-scm_make_cont (SCM *answer)
-{
- SCM cont;
-
- SCM_NEWCELL (cont);
- *answer = cont;
- SCM_ENTER_A_SECTION;
- SCM_SET_CONTREGS (cont, scm_must_malloc (sizeof (scm_contregs), s_cont));
- SCM_DYNENV (cont) = scm_dynwinds;
- SCM_THROW_VALUE = SCM_EOL;
- SCM_BASE (cont) = SCM_BASE (rootcont);
- SCM_SEQ (cont) = SCM_SEQ (rootcont);
- SCM_SETCAR (cont, scm_tc7_contin);
- SCM_EXIT_A_SECTION;
-
-#ifdef DEBUG_EXTENSIONS
- SCM_DFRAME (cont) = scm_last_debug_frame;
-#endif
-
- return cont;
-}
-
-
-static void
-scm_dynthrow (SCM cont, SCM val)
-{
-#ifdef DEBUG_EXTENSIONS
- scm_last_debug_frame = SCM_DFRAME (cont);
-#endif
- SCM_THROW_VALUE (cont) = val;
- longjmp (SCM_JMPBUF (cont), 1);
+ SCM_FLUSH_REGISTER_WINDOWS;
+ copy_stack_and_call (continuation, val, dst);
}
-
-#endif
-
-
-SCM
-scm_call_continuation (SCM cont, SCM val)
+#define FUNC_NAME "continuation_apply"
+static SCM continuation_apply (SCM cont, SCM args)
{
- if ((SCM_SEQ (cont) != SCM_SEQ (scm_rootcont))
- || (SCM_BASE (cont) != SCM_BASE (scm_rootcont)))
- /* base compare not needed */
- scm_wta (cont, "continuation from wrong top level", s_cont);
+ /* FIXME: support R5RS multiple value continuations. */
+ scm_contregs *continuation = SCM_CONTREGS (cont);
+ scm_contregs *rootcont = SCM_CONTREGS (scm_rootcont);
+
+ SCM_ASSERT (scm_ilength (args) == 1, args, SCM_ARGn, FUNC_NAME);
+ if (continuation->seq != rootcont->seq
+ /* this base comparison isn't needed */
+ || continuation->base != rootcont->base)
+ {
+ scm_wta (cont, "continuation from wrong top level", FUNC_NAME);
+ }
- scm_dowinds (SCM_DYNENV (cont),
- scm_ilength (scm_dynwinds) - scm_ilength (SCM_DYNENV (cont)));
+ scm_dowinds (continuation->dynenv,
+ scm_ilength (scm_dynwinds) - continuation->dynenv);
- scm_dynthrow (cont, val);
+ scm_dynthrow (cont, SCM_CAR (args));
return SCM_UNSPECIFIED; /* not reached */
}
-
+#undef FUNC_NAME
void
scm_init_continuations ()
{
+ scm_tc16_continuation = scm_make_smob_type ("continuation", 0);
+ scm_set_smob_mark (scm_tc16_continuation, continuation_mark);
+ scm_set_smob_free (scm_tc16_continuation, continuation_free);
+ scm_set_smob_print (scm_tc16_continuation, continuation_print);
+ scm_set_smob_apply (scm_tc16_continuation, continuation_apply, 0, 0, 1);
+
#ifndef SCM_MAGIC_SNARFER
#include "libguile/continuations.x"
#endif
}
-
/*
Local Variables:
c-file-style: "gnu"
diff --git a/libguile/continuations.h b/libguile/continuations.h
index d107f8797..ba87a3f27 100644
--- a/libguile/continuations.h
+++ b/libguile/continuations.h
@@ -47,25 +47,41 @@
+/* a continuation SCM is a non-immediate pointing to a heap cell with:
+ word 0: bits 0-15: unused.
+ bits 16-31: smob type tag: scm_tc16_continuation.
+ word 1: malloc block containing an scm_contregs structure with a
+ tail array of SCM_STACKITEM. the size of the array is stored
+ in the num_stack_items field of the structure.
+*/
+
+extern scm_bits_t scm_tc16_continuation;
+
typedef struct
{
SCM throw_value;
jmp_buf jmpbuf;
SCM dynenv;
- SCM_STACKITEM *base;
- unsigned long seq;
+ SCM_STACKITEM *base; /* base of the live stack, before it was saved. */
+ scm_sizet num_stack_items; /* size of the saved stack. */
+ unsigned long seq; /* dynamic root identifier. */
#ifdef DEBUG_EXTENSIONS
+ /* the most recently created debug frame on the live stack, before
+ it was saved. */
struct scm_debug_frame *dframe;
#endif
+ SCM_STACKITEM stack[1]; /* copied stack of size num_stack_items. */
} scm_contregs;
+#define SCM_CONTINUATIONP(x)\
+ (SCM_NIMP (x) && (SCM_TYP16 (x) == scm_tc16_continuation))
-#define SCM_CONTREGS(x) ((scm_contregs *) SCM_CELL_WORD_1 (x))
-#define SCM_SET_CONTREGS(x, r) (SCM_SET_CELL_WORD_1 ((x), (scm_bits_t) (r)))
-#define SCM_CONTINUATION_LENGTH(x) (((unsigned long) SCM_CELL_WORD_0 (x)) >> 8)
-#define SCM_SET_CONTINUATION_LENGTH(x, l) (SCM_SET_CELL_WORD_0 ((x), ((l) << 8) + scm_tc7_contin))
+#define SCM_CONTREGS(x) ((scm_contregs *) SCM_CELL_WORD_1 (x))
+#define SCM_CONTINUATION_LENGTH(x) (SCM_CONTREGS (x)->num_stack_items)
+#define SCM_SET_CONTINUATION_LENGTH(x,n)\
+ (SCM_CONTREGS (x)->num_stack_items = (n))
#define SCM_JMPBUF(x) ((SCM_CONTREGS (x))->jmpbuf)
#define SCM_DYNENV(x) ((SCM_CONTREGS (x))->dynenv)
#define SCM_THROW_VALUE(x) ((SCM_CONTREGS (x))->throw_value)
@@ -75,8 +91,7 @@ typedef struct
-extern SCM scm_make_cont (SCM * answer);
-extern SCM scm_call_continuation (SCM cont, SCM val);
+extern SCM scm_make_continuation (int *first);
extern void scm_init_continuations (void);
diff --git a/libguile/debug.c b/libguile/debug.c
index 93cbf6aa9..f530c3f66 100644
--- a/libguile/debug.c
+++ b/libguile/debug.c
@@ -431,7 +431,6 @@ SCM_DEFINE (scm_procedure_source, "procedure-source", 1, 0, 0,
SCM_EOL,
SCM_ENV (proc))));
}
- case scm_tc7_contin:
case scm_tcs_subrs:
#ifdef CCLO
case scm_tc7_cclo:
@@ -455,7 +454,6 @@ SCM_DEFINE (scm_procedure_environment, "procedure-environment", 1, 0, 0,
switch (SCM_TYP7 (proc)) {
case scm_tcs_closures:
return SCM_ENV (proc);
- case scm_tc7_contin:
case scm_tcs_subrs:
#ifdef CCLO
case scm_tc7_cclo:
diff --git a/libguile/eval.c b/libguile/eval.c
index 18d0c315d..3c44fba1a 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -1621,8 +1621,9 @@ do { \
}\
else\
{\
- scm_make_cont (&tmp);\
- if (!setjmp (SCM_JMPBUF (tmp)))\
+ int first;\
+ tmp = scm_make_continuation (&first);\
+ if (first)\
scm_ithrow (scm_sym_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\
}\
}\
@@ -1875,10 +1876,14 @@ start:
t.arg1 = scm_make_debugobj (&debug);
else
{
- scm_make_cont (&t.arg1);
- if (setjmp (SCM_JMPBUF (t.arg1)))
+ int first;
+ SCM val = scm_make_continuation (&first);
+
+ if (first)
+ t.arg1 = val;
+ else
{
- x = SCM_THROW_VALUE (t.arg1);
+ x = val;
if (SCM_IMP (x))
{
RETURN (x);
@@ -2218,13 +2223,15 @@ dispatch:
goto evapply;
case (SCM_ISYMNUM (SCM_IM_CONT)):
- scm_make_cont (&t.arg1);
- if (setjmp (SCM_JMPBUF (t.arg1)))
- {
- SCM val;
- val = SCM_THROW_VALUE (t.arg1);
- RETURN (val)
- }
+ {
+ int first;
+ SCM val = scm_make_continuation (&first);
+
+ if (first)
+ t.arg1 = val;
+ else
+ RETURN (val);
+ }
proc = SCM_CDR (x);
proc = evalcar (proc, env);
SCM_ASRTGO (SCM_NIMP (proc), badfun);
@@ -2681,7 +2688,6 @@ evapply:
else
goto badfun;
}
- case scm_tc7_contin:
case scm_tc7_subr_1:
case scm_tc7_subr_2:
case scm_tc7_subr_2o:
@@ -2815,8 +2821,6 @@ evapply:
env = EXTEND_ENV (SCM_CAR (x), scm_cons (t.arg1, SCM_EOL), SCM_ENV (proc));
#endif
goto cdrxbegin;
- case scm_tc7_contin:
- scm_call_continuation (proc, t.arg1);
case scm_tcs_cons_gloc:
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
{
@@ -2970,7 +2974,6 @@ evapply:
case scm_tc7_subr_1o:
case scm_tc7_subr_1:
case scm_tc7_subr_3:
- case scm_tc7_contin:
goto wrongnumargs;
default:
goto badfun;
@@ -3171,7 +3174,6 @@ evapply:
case scm_tc7_subr_0:
case scm_tc7_cxr:
case scm_tc7_subr_1:
- case scm_tc7_contin:
goto wrongnumargs;
default:
goto badfun;
@@ -3187,10 +3189,14 @@ exit:
t.arg1 = scm_make_debugobj (&debug);
else
{
- scm_make_cont (&t.arg1);
- if (setjmp (SCM_JMPBUF (t.arg1)))
+ int first;
+ SCM val = scm_make_continuation (&first);
+
+ if (first)
+ t.arg1 = val;
+ else
{
- proc = SCM_THROW_VALUE (t.arg1);
+ proc = val;
goto ret;
}
}
@@ -3342,8 +3348,10 @@ SCM_APPLY (SCM proc, SCM arg1, SCM args)
tmp = scm_make_debugobj (&debug);
else
{
- scm_make_cont (&tmp);
- if (setjmp (SCM_JMPBUF (tmp)))
+ int first;
+
+ tmp = scm_make_continuation (&first);
+ if (!first)
goto entap;
}
scm_ithrow (scm_sym_enter_frame, scm_cons (tmp, SCM_EOL), 0);
@@ -3492,9 +3500,6 @@ tail:
RETURN (scm_smob_apply_2 (proc, arg1, SCM_CAR (args)))
else
RETURN (scm_smob_apply_3 (proc, arg1, SCM_CAR (args), SCM_CDR (args)));
- case scm_tc7_contin:
- SCM_ASRTGO (SCM_NULLP (args), wrongnumargs);
- scm_call_continuation (proc, arg1);
#ifdef CCLO
case scm_tc7_cclo:
#ifdef DEVAL
@@ -3565,10 +3570,14 @@ exit:
arg1 = scm_make_debugobj (&debug);
else
{
- scm_make_cont (&arg1);
- if (setjmp (SCM_JMPBUF (arg1)))
+ int first;
+ SCM val = scm_make_continuation (&first);
+
+ if (first)
+ arg1 = val;
+ else
{
- proc = SCM_THROW_VALUE (arg1);
+ proc = val;
goto ret;
}
}
diff --git a/libguile/gc.c b/libguile/gc.c
index 0a6e968f3..5c8a86ac4 100644
--- a/libguile/gc.c
+++ b/libguile/gc.c
@@ -1221,15 +1221,6 @@ gc_mark_nimp:
ptr = SCM_VELTS (ptr)[0];
goto gc_mark_loop;
#endif
- case scm_tc7_contin:
- if (SCM_VELTS (ptr))
- scm_mark_locations (SCM_VELTS_AS_STACKITEMS (ptr),
- (scm_sizet)
- (SCM_CONTINUATION_LENGTH (ptr) +
- (sizeof (SCM_STACKITEM) + -1 +
- sizeof (scm_contregs)) /
- sizeof (SCM_STACKITEM)));
- break;
#ifdef HAVE_ARRAYS
case scm_tc7_bvect:
case scm_tc7_byvect:
@@ -1654,11 +1645,6 @@ scm_gc_sweep ()
m += SCM_SYMBOL_LENGTH (scmptr) + 1;
scm_must_free (SCM_SYMBOL_CHARS (scmptr));
break;
- case scm_tc7_contin:
- m += SCM_CONTINUATION_LENGTH (scmptr) * sizeof (SCM_STACKITEM)
- + sizeof (scm_contregs);
- scm_must_free (SCM_CONTREGS (scmptr));
- break;
case scm_tcs_subrs:
/* the various "subrs" (primitives) are never freed */
continue;
diff --git a/libguile/hash.c b/libguile/hash.c
index b26de9c04..529ad9fa0 100644
--- a/libguile/hash.c
+++ b/libguile/hash.c
@@ -150,7 +150,6 @@ scm_hasher(SCM obj, unsigned long n, scm_sizet d)
case scm_tc7_port:
return ((SCM_RDNG & SCM_CELL_WORD_0 (obj)) ? 260 : 261) % n;
case scm_tcs_closures:
- case scm_tc7_contin:
case scm_tcs_subrs:
return 262 % n;
}
diff --git a/libguile/init.c b/libguile/init.c
index 19530f6b6..16211518a 100644
--- a/libguile/init.c
+++ b/libguile/init.c
@@ -183,11 +183,13 @@ start_stack (void *base)
/* Create an object to hold the root continuation.
*/
- SCM_NEWCELL (scm_rootcont);
- SCM_SET_CONTREGS (scm_rootcont, scm_must_malloc (sizeof (scm_contregs),
- "continuation"));
- SCM_SET_CELL_TYPE (scm_rootcont, scm_tc7_contin);
- SCM_SEQ (scm_rootcont) = 0;
+ {
+ scm_contregs *contregs = scm_must_malloc (sizeof (scm_contregs),
+ "continuation");
+ contregs->num_stack_items = 0;
+ contregs->seq = 0;
+ SCM_NEWSMOB (scm_rootcont, scm_tc16_continuation, contregs);
+ }
/* The root continuation is further initialized by restart_stack. */
/* Create the look-aside stack for variables that are shared between
@@ -488,6 +490,7 @@ scm_init_guile_1 (SCM_STACKITEM *base)
scm_weaks_prehistory (); /* Must come after scm_init_storage */
scm_init_subr_table ();
scm_environments_prehistory (); /* create the root environment */
+ scm_init_continuations ();
scm_init_root ();
#ifdef USE_THREADS
scm_init_threads (base);
@@ -501,7 +504,6 @@ scm_init_guile_1 (SCM_STACKITEM *base)
scm_init_async ();
scm_init_boolean ();
scm_init_chars ();
- scm_init_continuations ();
#ifdef GUILE_DEBUG_MALLOC
scm_init_debug_malloc ();
#endif
diff --git a/libguile/print.c b/libguile/print.c
index 59004fd85..ecdc40d27 100644
--- a/libguile/print.c
+++ b/libguile/print.c
@@ -673,13 +673,6 @@ taloop:
}
scm_putc ('>', port);
break;
- case scm_tc7_contin:
- scm_puts ("#<continuation ", port);
- scm_intprint (SCM_CONTINUATION_LENGTH (exp), 10, port);
- scm_puts (" @ ", port);
- scm_intprint ((long) SCM_CONTREGS (exp), 16, port);
- scm_putc ('>', port);
- break;
case scm_tc7_port:
{
register long i = SCM_PTOBNUM (exp);
diff --git a/libguile/procprop.c b/libguile/procprop.c
index cd458eb99..feb42f7b3 100644
--- a/libguile/procprop.c
+++ b/libguile/procprop.c
@@ -80,7 +80,6 @@ scm_i_procedure_arity (SCM proc)
o = 1;
case scm_tc7_subr_1:
case scm_tc7_cxr:
- case scm_tc7_contin:
a += 1;
break;
case scm_tc7_subr_2:
diff --git a/libguile/procs.c b/libguile/procs.c
index 1e48c3cff..c36871954 100644
--- a/libguile/procs.c
+++ b/libguile/procs.c
@@ -196,7 +196,6 @@ SCM_DEFINE (scm_procedure_p, "procedure?", 1, 0, 0,
if (!SCM_I_OPERATORP (obj))
break;
case scm_tcs_closures:
- case scm_tc7_contin:
case scm_tcs_subrs:
#ifdef CCLO
case scm_tc7_cclo:
@@ -278,8 +277,7 @@ SCM_DEFINE (scm_procedure_documentation, "procedure-documentation", 1, 0, 0,
#define FUNC_NAME s_scm_procedure_documentation
{
SCM code;
- SCM_ASSERT (SCM_EQ_P (scm_procedure_p (proc), SCM_BOOL_T)
- && SCM_NIMP (proc) && SCM_TYP7 (proc) != scm_tc7_contin,
+ SCM_ASSERT (SCM_EQ_P (scm_procedure_p (proc), SCM_BOOL_T) && SCM_NIMP (proc),
proc, SCM_ARG1, FUNC_NAME);
switch (SCM_TYP7 (proc))
{
diff --git a/libguile/root.c b/libguile/root.c
index 86eee6452..c0c8ebfa6 100644
--- a/libguile/root.c
+++ b/libguile/root.c
@@ -58,12 +58,6 @@
#include "libguile/root.h"
-/* 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;
@@ -248,9 +242,6 @@ scm_internal_cwdr (scm_catch_body_t body, void *body_data,
scm_catch_handler_t 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;
@@ -259,22 +250,22 @@ scm_internal_cwdr (scm_catch_body_t body, void *body_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_contregs *contregs = scm_must_malloc (sizeof (scm_contregs),
+ "inferior root 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;
@@ -298,9 +289,6 @@ scm_internal_cwdr (scm_catch_body_t body, void *body_data,
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
diff --git a/libguile/stacks.c b/libguile/stacks.c
index c048d94cd..e3de7eb23 100644
--- a/libguile/stacks.c
+++ b/libguile/stacks.c
@@ -433,7 +433,7 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, FUNC_NAME);
if (SCM_DEBUGOBJP (obj))
dframe = (scm_debug_frame *) SCM_DEBUGOBJ_FRAME (obj);
- else if (scm_tc7_contin == SCM_TYP7 (obj))
+ else if (SCM_CONTINUATIONP (obj))
{
offset = ((SCM_STACKITEM *) ((char *) SCM_CONTREGS (obj) + sizeof (scm_contregs))
- SCM_BASE (obj));
@@ -517,7 +517,7 @@ SCM_DEFINE (scm_stack_id, "stack-id", 1, 0, 0,
SCM_VALIDATE_NIM (1,stack);
if (SCM_DEBUGOBJP (stack))
dframe = (scm_debug_frame *) SCM_DEBUGOBJ_FRAME (stack);
- else if (scm_tc7_contin == SCM_TYP7 (stack))
+ else if (SCM_CONTINUATIONP (stack))
{
offset = ((SCM_STACKITEM *) ((char *) SCM_CONTREGS (stack) + sizeof (scm_contregs))
- SCM_BASE (stack));
@@ -587,7 +587,7 @@ SCM_DEFINE (scm_last_stack_frame, "last-stack-frame", 1, 0, 0,
SCM_VALIDATE_NIM (1,obj);
if (SCM_DEBUGOBJP (obj))
dframe = (scm_debug_frame *) SCM_DEBUGOBJ_FRAME (obj);
- else if (scm_tc7_contin == SCM_TYP7 (obj))
+ else if (SCM_CONTINUATIONP (obj))
{
offset = ((SCM_STACKITEM *) ((char *) SCM_CONTREGS (obj) + sizeof (scm_contregs))
- SCM_BASE (obj));
diff --git a/libguile/tags.h b/libguile/tags.h
index 7082603aa..a3f7ccb0a 100644
--- a/libguile/tags.h
+++ b/libguile/tags.h
@@ -356,7 +356,7 @@ typedef long scm_bits_t;
#define scm_tc7_ivect 79
#endif
-#define scm_tc7_contin 61
+/* free 61 */
#define scm_tc7_cclo 63
#define scm_tc7_rpsubr 69
#define scm_tc7_subr_0 85