269 lines
6.7 KiB
C
269 lines
6.7 KiB
C
/*
|
|
*
|
|
* c o n t . c -- Continuations management
|
|
*
|
|
* Copyright © 1993-1999 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
|
|
*
|
|
*
|
|
* Permission to use, copy, modify, distribute,and license this
|
|
* software and its documentation for any purpose is hereby granted,
|
|
* provided that existing copyright notices are retained in all
|
|
* copies and that this notice is included verbatim in any
|
|
* distributions. No written agreement, license, or royalty fee is
|
|
* required for any of the authorized uses.
|
|
* This software is provided ``AS IS'' without express or implied
|
|
* warranty.
|
|
*
|
|
* Author: Erick Gallesio [eg@kaolin.unice.fr]
|
|
* Creation date: 8-Nov-1993 11:34
|
|
* Last file update: 3-Sep-1999 20:19 (eg)
|
|
*/
|
|
|
|
#include "stk.h"
|
|
#include "gc.h"
|
|
|
|
#ifdef sparc
|
|
#define FLUSH_REGISTERS_WINDOW() asm("t 0x3") /* Stolen in Elk 2.0 source */
|
|
#else
|
|
#define FLUSH_REGISTERS_WINDOW()
|
|
#endif
|
|
|
|
struct cont {
|
|
jmp_buf env;
|
|
struct error_handler *eh;
|
|
SCM *start;
|
|
unsigned length;
|
|
SCM stack[1];
|
|
};
|
|
|
|
#define C_ENV(x) (((struct cont *)((x)->storage_as.cont.data))->env)
|
|
#define C_HANDLER(x) (((struct cont *)((x)->storage_as.cont.data))->eh)
|
|
#define C_START(x) (((struct cont *)((x)->storage_as.cont.data))->start)
|
|
#define C_LEN(x) (((struct cont *)((x)->storage_as.cont.data))->length)
|
|
#define C_STACK(x) (((struct cont *)((x)->storage_as.cont.data))->stack)
|
|
|
|
static SCM values(SCM l, int len);
|
|
static void reenter_cont(struct error_handler *eh);
|
|
|
|
/* Don't allocate these vars on stack */
|
|
static SCM call_cc_escaped_value;
|
|
static SCM *from, *to;
|
|
static long length;
|
|
static int i;
|
|
|
|
|
|
static int get_stack_length(void)
|
|
{
|
|
SCM stack_limit;
|
|
|
|
return (&stack_limit < STk_stack_start_ptr) ? STk_stack_start_ptr - &stack_limit
|
|
: &stack_limit - STk_stack_start_ptr;
|
|
}
|
|
|
|
static SCM prepare_call_cc(SCM proc)
|
|
{
|
|
SCM z;
|
|
|
|
if (STk_procedurep(proc) == Ntruth)
|
|
Err("call-with-current-continuation: Bad procedure", proc);
|
|
|
|
/* Find the start adress and the length of the stack to save */
|
|
length = get_stack_length();
|
|
from = (STk_stack_start_ptr<&z) ? STk_stack_start_ptr
|
|
: STk_stack_start_ptr-length;
|
|
|
|
/* Allocate a new object for this continuation */
|
|
NEWCELL(z, tc_cont);
|
|
|
|
z->storage_as.cont.data = must_malloc(sizeof(struct cont) + length * sizeof(SCM));
|
|
|
|
C_START(z) = from;
|
|
C_HANDLER(z) = STk_err_handler;
|
|
C_LEN(z) = length;
|
|
FLUSH_REGISTERS_WINDOW();
|
|
for (i=length, to = C_STACK(z); i--; ) *to++ = *from++;
|
|
|
|
return z;
|
|
}
|
|
|
|
void STk_mark_continuation(SCM cont)
|
|
{
|
|
STk_mark_stack((SCM *)C_STACK(cont), (SCM *)(C_STACK(cont)+C_LEN(cont)-1));
|
|
}
|
|
|
|
SCM STk_do_call_cc(SCM *x)
|
|
{
|
|
SCM tmp;
|
|
|
|
tmp = prepare_call_cc(*x);
|
|
/* Use a setjmp/longjmp for the continuation */
|
|
if (setjmp(C_ENV(tmp)) == 0) {
|
|
*x = LIST2(*x, tmp);
|
|
return Truth;
|
|
}
|
|
else
|
|
return (*x=call_cc_escaped_value);
|
|
}
|
|
|
|
void STk_throw(SCM fct, SCM vals)
|
|
{
|
|
static SCM tmp;
|
|
union {
|
|
SCM stack_end;
|
|
SCM hole[1024]; /* Reserve 1K-pointers on stack */
|
|
}u;
|
|
|
|
/* Evaluate room on stack. If not enough call throw again to alloc. a new hole */
|
|
if (&u.stack_end < STk_stack_start_ptr) {
|
|
/* Stack grows downward */
|
|
if (&u.stack_end > C_START(fct)) STk_throw(fct, vals);
|
|
}
|
|
else {
|
|
/* Stack grows upward */
|
|
if (&u.stack_end < C_START(fct)+ C_LEN(fct)) STk_throw(fct, vals);
|
|
}
|
|
|
|
/* Save val in a global and reset stack as it was before calling call/cc */
|
|
call_cc_escaped_value = values(vals, STk_llength(vals)); tmp = fct;
|
|
FLUSH_REGISTERS_WINDOW();
|
|
for(to=C_START(fct), from=C_STACK(fct), i=C_LEN(fct); i--; ) *to++ = *from++;
|
|
|
|
/* Everything is restored. Execute the thunk1 of dynamic-wind we enter in back */
|
|
reenter_cont(C_HANDLER(tmp));
|
|
|
|
/* And Go! */
|
|
longjmp(C_ENV(tmp), JMP_THROW);
|
|
}
|
|
|
|
PRIMITIVE STk_continuationp(SCM obj)
|
|
{
|
|
return CONTINUATIONP(obj)? Truth: Ntruth;
|
|
}
|
|
|
|
/******************************************************************************
|
|
*
|
|
* Dynamic wind
|
|
*
|
|
******************************************************************************/
|
|
|
|
|
|
static void reenter_cont(struct error_handler *eh)
|
|
{
|
|
struct error_handler *p, *before;
|
|
SCM thunks1 = NIL;
|
|
SCM thunks2 = NIL;
|
|
|
|
before = STk_err_handler;
|
|
STk_err_handler = eh;
|
|
|
|
/* Scan the stack and collect all the thunk1(s) we'll have to call. Since we
|
|
* have the thunks in reverse order push them in a list
|
|
*/
|
|
for (p = STk_err_handler; p && p != before; p = p->prev) {
|
|
if (NNULLP(p->dynamic_handler)) {
|
|
thunks1 = Cons(CAR(p->dynamic_handler), thunks1);
|
|
thunks2 = Cons(CDR(p->dynamic_handler), thunks2);
|
|
}
|
|
}
|
|
/* Execute all the handler now */
|
|
for ( ; NNULLP(thunks2); thunks2 = CDR(thunks2))
|
|
Apply0(CAR(thunks2));
|
|
/* Execute all the handler now */
|
|
for ( ; NNULLP(thunks1); thunks1 = CDR(thunks1))
|
|
Apply0(CAR(thunks1));
|
|
|
|
}
|
|
|
|
|
|
void STk_unwind_all(void) /* called when we exit the interpreter */
|
|
{
|
|
struct error_handler *p;
|
|
SCM thunks = NIL;
|
|
|
|
/* Scan the stack and collect all the thunk3(s) we'll have to call. Since we
|
|
* have the thunks in reverse order push them in a list
|
|
*/
|
|
for (p = STk_err_handler; p ; p = p->prev) {
|
|
if (NNULLP(p->dynamic_handler))
|
|
thunks = Cons(CDR(p->dynamic_handler), thunks);
|
|
}
|
|
/* Execute all the handler now */
|
|
for ( ; NNULLP(thunks); thunks = CDR(thunks))
|
|
Apply0(CAR(thunks));
|
|
}
|
|
|
|
|
|
static void test_procedure(SCM thunk)
|
|
{
|
|
if (!STk_is_thunk(thunk)) Err("dynamic-wind: bad procedure", thunk);
|
|
}
|
|
|
|
|
|
PRIMITIVE STk_dynamic_wind(SCM thunk1, SCM thunk2, SCM thunk3)
|
|
{
|
|
SCM result;
|
|
|
|
test_procedure(thunk1); test_procedure(thunk2); test_procedure(thunk3);
|
|
|
|
Apply0(thunk1);
|
|
PUSH_ERROR_HANDLER
|
|
{
|
|
STk_err_handler->dynamic_handler = Cons(thunk1, thunk3);
|
|
result = Apply0(thunk2);
|
|
}
|
|
WHEN_ERROR
|
|
{
|
|
Apply0(thunk3);
|
|
PROPAGATE_ERROR();
|
|
}
|
|
POP_ERROR_HANDLER;
|
|
Apply0(thunk3);
|
|
return result;
|
|
}
|
|
|
|
/******************************************************************************
|
|
*
|
|
* R5RS values
|
|
*
|
|
******************************************************************************/
|
|
|
|
static SCM values(SCM l, int len)
|
|
{
|
|
if (len == 1)
|
|
return CAR(l);
|
|
else {
|
|
SCM z;
|
|
|
|
NEWCELL(z, tc_values);
|
|
CAR(z) = l;
|
|
return z;
|
|
}
|
|
}
|
|
|
|
PRIMITIVE STk_values(SCM l, int len)
|
|
{
|
|
SCM tmp;
|
|
|
|
ENTER_PRIMITIVE("values");
|
|
|
|
/* check the args for not being multiple-valued */
|
|
for (tmp = l ; NNULLP(tmp) ; tmp = CDR(tmp))
|
|
if (TYPEP(CAR(tmp), tc_values)) Serror("bad argument", CAR(tmp));
|
|
|
|
return values(l, len);
|
|
}
|
|
|
|
|
|
PRIMITIVE STk_call_with_values(SCM producer, SCM consumer)
|
|
{
|
|
SCM res;
|
|
|
|
ENTER_PRIMITIVE("call-with-values");
|
|
|
|
if (!STk_procedurep(producer)) Serror("bad producer", producer);
|
|
if (!STk_procedurep(consumer)) Serror("bad consumer", consumer);
|
|
|
|
res = Apply0(producer);
|
|
return Apply(consumer, VALUESP(res) ? CAR(res) : LIST1(res));
|
|
}
|