/* Control points, call-with-current-continuation, dynamic-wind
 */

#include <signal.h>

#include "scheme.h"

WIND *First_Wind, *Last_Wind;

Object P_Control_Pointp (x) Object x; {
    return TYPE(x) == T_Control_Point ? True : False;
}

Object Make_Control_Point (size) {
    Object control;
    register struct S_Control *cp;
    register char *p;

    p = Get_Bytes (size + sizeof (struct S_Control) - 1);
    cp = (struct S_Control *)p;
    SET(control, T_Control_Point, cp);
    cp->env = The_Environment;
    cp->gclist = GC_List;
    cp->firstwind = First_Wind;
    cp->lastwind = Last_Wind;
    cp->tailcall = Tail_Call;
    cp->size = size;
    return control;
}

Object P_Call_CC (proc) Object proc; {
    int size;
    Object control, ret;
    GC_Node;

    Check_Procedure (proc);
    GC_Link (proc);
    size = stksize ();
    control = Make_Control_Point (size);
    SETFAST(ret,saveenv (CONTROL(control)->stack));
    if (TYPE(ret) != T_Special) {
	Enable_Interrupts;
	return ret;
    }
    control = Cons (control, Null);
    ret = Funcall (proc, control, 0);
    GC_Unlink;
    return ret;
}

Funcall_Control_Point (control, argl, eval) Object control, argl; {
    Object val, len;
    register struct S_Control *cp;
    register WIND *wp, *p;
    register delta;
    GC_Node3;

    val = Null;
    GC_Link3 (argl, control, val);
    len = P_Length (argl);
    if (FIXNUM(len) != 1)
	Primitive_Error ("control point expects one argument");
    val = Car (argl);
    if (eval)
	val = Eval (val);
    for (wp = Last_Wind; wp; wp = wp->prev)
	Do_Wind (wp->out);
    delta = *(int *)(CONTROL(control)->stack);
    for (wp = CONTROL(control)->firstwind; wp; wp = p->next) {
	p = (WIND *)NORM(wp);
	Do_Wind (p->in);
    }
    GC_Unlink;
    cp = CONTROL(control);
    Switch_Environment (cp->env);
    GC_List = cp->gclist;
    First_Wind = cp->firstwind;
    Last_Wind = cp->lastwind;
    Tail_Call = cp->tailcall;
    jmpenv (cp->stack, val);
    /*NOTREACHED*/
}

Do_Wind (w) Object w; {
    Object b, sym, val;

    if (TYPE(w) == T_Pair) {
	b = Lookup_Symbol (Car (w), 0);
	if (Nullp (b))
	    Panic ("fluid-let2");
	sym = Car (b);
	val = Cdr (w);
	Cdr (b) = val;
	SYMBOL(sym)->value = val;
    } else {
	(void)Funcall (w, Null, 0);
    }
}

Add_Wind (w, in, out) register WIND *w; Object in, out; {
    w->in = in;
    w->out = out;
    w->next = 0;
    if (First_Wind == 0)
	First_Wind = w;
    else
	Last_Wind->next = w;
    w->prev = Last_Wind;
    Last_Wind = w;
}

Object P_Dynamic_Wind (in, body, out) Object in, body, out; {
    WIND w, *first = First_Wind;
    Object ret;
    GC_Node3;

    Check_Procedure (in);
    Check_Procedure (body);
    Check_Procedure (out);
    ret = Null;
    GC_Link3 (body, out, ret);
    Add_Wind (&w, in, out);
    (void)Funcall (in, Null, 0);
    ret = Funcall (body, Null, 0);
    (void)Funcall (out, Null, 0);
    if (Last_Wind = w.prev)
	Last_Wind->next = 0;
    First_Wind = first;
    GC_Unlink;
    return ret;
}

Object P_Control_Point_Env (c) Object c; {
    Check_Type (c, T_Control_Point);
    return CONTROL(c)->env;
}