tail unwinding works

parent b54898da
......@@ -745,7 +745,7 @@ static void gp_unwind0(SCM *fr, SCM *ci, SCM *si, SCM *cs, struct gp_stack *gp)
}
//#define DB(X)
static inline void gp_unwind_(SCM s, int ncons, int nvar)
static inline void gp_unwind_(SCM s, int ncons, int nvar, int nfr)
{
struct gp_stack *gp = get_gp();
SCM *fr, *ci,*si,*cs,lt;
......@@ -755,16 +755,12 @@ static inline void gp_unwind_(SCM s, int ncons, int nvar)
if((GP(s) && GP_CONSP(s)) || SCM_CONSP(s))
{
tag = gp_car(gp_car(s, s),s);
printf("0");fflush(stdout);
lt = gp_gp_cdr(s,s);
printf("1");fflush(stdout);
fr = gp->gp_frstack + GP_GET_SELF_TAG(tag);
printf("2");fflush(stdout);
if(vlist_p(lt))
{
vhash_truncate_x(lt);
}
printf("3");fflush(stdout);
}
else
{
......@@ -772,22 +768,17 @@ static inline void gp_unwind_(SCM s, int ncons, int nvar)
}
ha = GP_GET_HANDLERS(fr);
printf("4");fflush(stdout);
dyn_n = GP_GET_DLENGTH(fr);
printf("5");fflush(stdout);
ci = gp->gp_cstack + GP_GET_VAL_VAL(fr);
printf("6");fflush(stdout);
si = gp->gp_stack + GP_GET_VAR(fr) - nvar;
printf("7");fflush(stdout);
cs = gp->gp_cons_stack + GP_GET_CONS(fr) - ncons;
printf("8");fflush(stdout);
gp_debug2("er> %x %x %x\n",cs - gp->gp_stack,cs - gp->gp_cons_stack);
gp_debug2("er> %x %x %x\n",si - gp->gp_stack,si - gp->gp_cons_stack);
gp->handlers = ha;
gp_unwind0(fr,ci,si,cs,gp);
gp_unwind0(fr - GP_FRAMESIZE*nfr,ci - nfr, si, cs, gp);
gp_unwind_dynstack(gp, dyn_n);
......@@ -798,7 +789,7 @@ static inline void gp_unwind_(SCM s, int ncons, int nvar)
static inline void gp_unwind(SCM fr)
{
gp_unwind_(fr,0,0);
gp_unwind_(fr,0,0,0);
}
static inline void gp_unwind_soft(int ncons)
......@@ -810,12 +801,12 @@ static inline void gp_unwind_soft(int ncons)
static inline void gp_unwind_ncons(SCM fr, int ncons)
{
gp_unwind_(fr,ncons,0);
gp_unwind_(fr,ncons,0,0);
}
static inline void gp_unwind_tail(SCM fr)
{
gp_unwind_(fr,2,2);
gp_unwind_(fr,2,2,1);
}
SCM_DEFINE(gp_gp_unwind, "gp-unwind", 1, 0, 0, (SCM fr),
......
......@@ -236,7 +236,7 @@
(define gp-unwind-tail
(lambda (fr)
(if (not (pair? fr)) (error "BUG"))
(if (not (or (gp-pair? fr fr) (pair? fr))) (error "BUG"))
(fluid-set! *unwind-hooks* '())
(let ((ll (reverse (fluid-ref *unwind-hooks*))))
(if (pair? ll)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment