diff options
-rw-r--r-- | libguile/ChangeLog | 34 | ||||
-rw-r--r-- | libguile/continuations.c | 209 | ||||
-rw-r--r-- | libguile/continuations.h | 31 | ||||
-rw-r--r-- | libguile/debug.c | 2 | ||||
-rw-r--r-- | libguile/eval.c | 65 | ||||
-rw-r--r-- | libguile/gc.c | 14 | ||||
-rw-r--r-- | libguile/hash.c | 1 | ||||
-rw-r--r-- | libguile/init.c | 14 | ||||
-rw-r--r-- | libguile/print.c | 7 | ||||
-rw-r--r-- | libguile/procprop.c | 1 | ||||
-rw-r--r-- | libguile/procs.c | 4 | ||||
-rw-r--r-- | libguile/root.c | 38 | ||||
-rw-r--r-- | libguile/stacks.c | 6 | ||||
-rw-r--r-- | libguile/tags.h | 2 |
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 |