mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-18 01:30:27 +02:00
Code Activity

* use an applicable SMOB to represent continuations, instead of a

Browse source 
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.
This commit is contained in:
Gary Houston 2000-11-25 16:58:25 +00:00
parent 7f555fb4ed
commit 5f144b105d
14 changed files with 240 additions and 210 deletions
Download patch file Download diff file Expand all files Collapse all files

34
libguile/ChangeLog
View file

@ -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

231
libguile/continuations.c
View file

@ -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);
#ifndef CHEAP_CONTINUATIONS
SCM
scm_make_cont (SCM *answer)
static SCM continuation_mark (SCM obj)
{
long j;
SCM cont;
SCM_STACKITEM * src;
SCM_STACKITEM * dst;
scm_contregs *continuation = SCM_CONTREGS (obj);
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));
#ifdef DEBUG_EXTENSIONS
SCM_DFRAME (cont) = scm_last_debug_frame;
#endif
return cont;
scm_gc_mark (continuation->throw_value);
scm_mark_locations (continuation->stack, continuation->num_stack_items);
return continuation->dynenv;
}
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_continuation (int *first)
{
SCM cont;
scm_contregs *continuation;
scm_contregs *rootcont = SCM_CONTREGS (scm_rootcont);
long stack_size;
SCM_STACKITEM * src;
SCM_ENTER_A_SECTION;
SCM_FLUSH_REGISTER_WINDOWS;
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
continuation->dframe = scm_last_debug_frame;
#endif
SCM_NEWSMOB (cont, scm_tc16_continuation, continuation);
SCM_EXIT_A_SECTION;
#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);
copy_stack_and_call (continuation, val, 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)
#define FUNC_NAME "continuation_apply"
static SCM continuation_apply (SCM cont, SCM args)
{
SCM cont;
/* FIXME: support R5RS multiple value continuations. */
scm_contregs *continuation = SCM_CONTREGS (cont);
scm_contregs *rootcont = SCM_CONTREGS (scm_rootcont);
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;
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);
}
#ifdef DEBUG_EXTENSIONS
SCM_DFRAME (cont) = scm_last_debug_frame;
#endif
scm_dowinds (continuation->dynenv,
scm_ilength (scm_dynwinds) - continuation->dynenv);
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);
}
#endif
SCM
scm_call_continuation (SCM cont, SCM val)
{
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);
scm_dowinds (SCM_DYNENV (cont),
scm_ilength (scm_dynwinds) - scm_ilength (SCM_DYNENV (cont)));
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"

29
libguile/continuations.h
View file

@ -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_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);

2
libguile/debug.c
View file

@ -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:

61
libguile/eval.c
View file

@ -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,12 +2223,14 @@ 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);
@ -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;
}
}

14
libguile/gc.c
View file

@ -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;

1
libguile/hash.c
View file

@ -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;
}

14
libguile/init.c
View file

@ -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

7
libguile/print.c
View file

@ -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);

1
libguile/procprop.c
View file

@ -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:

4
libguile/procs.c
View file

@ -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))
{

38
libguile/root.c
View file

@ -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

6
libguile/stacks.c
View file

@ -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));

2
libguile/tags.h
View file

@ -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