bugfixes

parent cb959603
......@@ -175,21 +175,21 @@
((_ meta e1) (parse<> meta e1))
((_ (cut s pr cc) . l)
(let ((s (gp-newframe-choice s)))
(or-aux (cut s pr cc) . l)))))
((_ (cut ss pr cc) . l)
(let ((s (gp-newframe-choice ss)))
(or-aux ss (cut s pr cc) . l)))))
(define-syntax or-aux
(syntax-rules ()
((_ (cut s p cc) a)
((_ ss (cut s p cc) a)
(begin
(gp-unwind-tail s)
(parse<> (cut s p cc) a)))
((_ (cut s p cc) a . as)
(parse<> (cut ss p cc) a)))
((_ ss (cut s p cc) a . as)
(let ((pp (lambda ()
(gp-unwind s)
(or-aux (cut s p cc) . as))))
(parse<> (cut s pp cc) (<with-fail> pp a))))))
(or-aux ss (cut s p cc) . as))))
(parse<> (cut s pp cc) a)))))
(define-and-log <values>
(syntax-rules ()
......@@ -361,8 +361,8 @@
(define-guile-log <succeds>
(syntax-rules ()
((_ (cut s p cc) g ...)
(let* ((s (gp-newframe s))
(ccc (lambda (ss pp) (gp-unwind-tail s) (cc s p))))
(let* ((ss (gp-newframe s))
(ccc (lambda (ss pp) (gp-unwind-tail ss) (cc s p))))
(parse<> (cut s p ccc) (<and> g ...))))))
......
......@@ -388,12 +388,14 @@
(define (f-clear-body f)
(<p-lambda> (c)
(<let> ((op P)
(os S)
(p (<newframe>)))
(<with-s> p
(.. (c) (f c))
(<code> (<unwind-tail> p))
(<with-fail> op
(<p-cc> c))))))
(<with-s> os
(<p-cc> c)))))))
(define (f-char! ch) (f-test! (lambda (x) (eq? x ch))))
(define (f-char ch) (f-test (lambda (x) (eq? x ch))))
......@@ -440,7 +442,9 @@
(<and!>
(<let> ((val (hash-ref (fluid-ref *freeze-map*)
(cons* N M tok) #f))
(fr (<newframe-choice>)))
(op P)
(os S)
(fr (<newframe>)))
(if (not val)
(<let> ((n N) (m M))
(<or>
......@@ -448,19 +452,25 @@
(.. (cc) (f c))
(<let> ((val2 (mk S c cc)))
(<code>
(<unwind-tail> fr)
(hash-set! (fluid-ref *freeze-map*)
(cons* n m tok) (list X XL N M XX ... val2)))
(<p-cc> val2)))
(<unwind-tail> fr))
(<with-fail> op
(<with-s> os
(<code>
(hash-set! (fluid-ref *freeze-map*)
(cons* n m tok) (list X XL N M XX ... val2)))
(<p-cc> val2)))))
(<let> ((val2 'fail))
(<code>
(<unwind-tail> fr)
(hash-set! (fluid-ref *freeze-map*)
(cons* n m tok) val2))
<fail>)))
(if (pair? val)
(<apply> f-true val)
<fail>))))))
(if (pair? val)
(<and>
(<code> (gp-unwind-tail fr))
(<with-fail> op
(<with-s> os
(<apply> f-true val))))
<fail>))))))
(define (f* f) (letrec ((ret (f-or (s-seq f ret) s-true))) (s-and! ret)))
(define (f+ f) (s-seq f (f* f)))
......
This diff is collapsed.
//#define DB(X) X
#define DB(X)
#define STATE_LOGICAL 0
#define STATE_DYNSTACK 1
......@@ -419,6 +419,10 @@ static void gp_unwind0(SCM *fr, SCM *ci, SCM *si, SCM *cs, struct gp_stack *gp)
if(si < gp->gp_stack ) si = gp->gp_stack;
if(cs < gp->gp_cons_stack) cs = gp->gp_cons_stack;
if(ci < gp->gp_cstack + 1)
scm_misc_error("unwind",
"Strange value in ci ~a",
scm_list_1(scm_from_ulong(ci - gp->gp_cstack)));
// In order to prevent gc issues we must store the SCM value
#define FF(x) GP_UNREF(NUM2PTR(x))
......@@ -454,7 +458,7 @@ static void gp_unwind0(SCM *fr, SCM *ci, SCM *si, SCM *cs, struct gp_stack *gp)
}
}
else
*i = SCM_BOOL_F;
scm_misc_error("unwind","wrong frame format on stack",SCM_EOL);
}
gp->gp_fr = fr;
......@@ -541,6 +545,10 @@ static void gp_unwind0(SCM *fr, SCM *ci, SCM *si, SCM *cs, struct gp_stack *gp)
for(i = ci_old-1; i >= ci; i-=1)
{
if(i == gp->gp_cstack)
scm_misc_error("unwind",
"unwinding the first protected ci stack element",
SCM_EOL);
if(SCM_CONSP(*i))
{
state = gp_do_cons(*i, state, &old, gp_unbd);
......@@ -660,6 +668,10 @@ static void gp_unwind0(SCM *fr, SCM *ci, SCM *si, SCM *cs, struct gp_stack *gp)
{
*i = SCM_BOOL_F;
}
else
{
GP_GETREF(*i)[1] = SCM_UNBOUND;
}
}
else if(scm_is_eq(*i,SCM_BOOL_T))
{
......@@ -700,8 +712,12 @@ static void gp_unwind0(SCM *fr, SCM *ci, SCM *si, SCM *cs, struct gp_stack *gp)
*i = SCM_BOOL_F;
cs_store = 1;
continue;
}
}
} else if(GP(*i))
{
GP_GETREF(*i)[1] = SCM_UNBOUND;
GP_GETREF(*i)[2] = SCM_UNBOUND;
}
}
}
gp_debug1("finishing cs %x\n",gp->gp_cs - cs);
......@@ -823,20 +839,36 @@ static inline void gp_unwind_(SCM s, int ncons, int nvar, int nfr)
fr = gp->gp_fr;
}
ha = GP_GET_HANDLERS(fr);
dyn_n = GP_GET_DLENGTH(fr);
if(GP_VAL_UNBOUND(fr))
{
scm_misc_error("unwind","got not a number at fr1 ~a fr2 ~a fr4 ~a",
scm_list_3(fr[-1],fr[-2],fr[-4]));
}
ci = gp->gp_cstack + GP_GET_VAL_VAL(fr);
ci = gp->gp_cstack + GP_GET_VAL_VAL(fr);
if(!SCM_CONSP(fr) && !scm_is_eq(*ci,GP_GET_VAL(fr)))
scm_misc_error("gp-unwind","ci self entry is not the same~%~a",
scm_list_1(*ci));
if(!SCM_CONSP(fr[-1]) && scm_is_true(fr[-1]) &&
!scm_is_eq(*ci,GP_GET_VAL(fr)))
{
SCM u = gp_gp_cdr(gp_car(s , s), s);
SCM v = GP_GETREF(u)[1];
gp_print_stack(s,SCM_BOOL_T);
scm_misc_error("gp-unwind",
"ci self 1 entry is not the same~%~a at ~a,~a,~a~%",
scm_list_4(*ci,
scm_from_ulong(gp->gp_ci - gp->gp_cstack),
scm_from_ulong(ci - gp->gp_cstack),
v));
}
ci += 1 - nfr;
si = gp->gp_stack + GP_GET_VAR(fr) - nvar;
cs = gp->gp_cons_stack + GP_GET_CONS(fr) - ncons;
gp_debug2("cs> %x %x\n",cs - gp->gp_stack,cs - gp->gp_cons_stack);
gp_debug2("si> %x %x\n",si - gp->gp_stack,si - gp->gp_cons_stack);
......@@ -996,7 +1028,7 @@ SCM_DEFINE(gp_gp_prune_tail, "gp-prune-tail", 1, 0, 0, (SCM fr),
#define FUNC_NAME s_gp_gp_unwind
{
gp_no_gc();
gp_prune(fr, 1);
//gp_prune(fr, 1);
gp_do_gc();
return SCM_UNSPECIFIED;
}
......
......@@ -106,6 +106,11 @@ SCM closure_tag;
scm_from_locale_string(str), \
scm_list_3(x,y,z)))
#define format4(str,x,y,z,w) \
(scm_simple_format(SCM_BOOL_T, \
scm_from_locale_string(str), \
scm_list_4(x,y,z,w)))
SCM gp_name_sym = SCM_BOOL_F;
SCM gp_procedure_name(SCM f)
......@@ -251,7 +256,7 @@ scm_t_bits gp_smob_t;
#define GP_UNREF(x) ((SCM) (x))
#define N_BITS 22
#define N_BITS 26
#define H_BITS 36
#define GP_ATTR_IT(x) ((x) = ((x) | GPI_ATTR))
......@@ -886,6 +891,8 @@ static inline SCM * gp_lookup(SCM *id, SCM l)
}
if(GP_STAR(id) && GP_UNBOUND(id) && !scm_is_eq(l,SCM_EOL)) goto advanced;
gp_debug0("exit simple\n");
gp_debug2("lookup> %x 0 val = %x\n",id,SCM_UNPACK(*id)) ;
return id;
......@@ -1001,7 +1008,7 @@ static inline SCM * gp_lookup2(SCM *id, SCM l)
}
// if(!scm_is_eq(l,SCM_EOL)) goto advanced;
gp_debug2("lookup> %x 0 val = %x\n",id,SCM_UNPACK(*id)) ;
return id;
......@@ -1242,13 +1249,16 @@ static inline SCM gp_newframe(SCM s)
s = SCM_PACK(0);
l = SCM_EOL;
}
{
SCM ret;
SCM *f1, *f2, *cons1, *cons2;
SCM *fr;
GP_TEST_CSTACK;
GP_TEST_FRSTACK;
GP_TEST_CCSTACK;
GP_TEST_STACK;
gp_gc_inc(gp);
......@@ -1306,7 +1316,10 @@ static inline SCM gp_newframe_choice(SCM s)
SCM *fr;
gp_debug0("newframe\n");
GP_TEST_CSTACK;
GP_TEST_FRSTACK;
GP_TEST_CCSTACK;
GP_TEST_STACK;
gp_gc_inc(gp);
fr = gp->gp_fr + GP_FRAMESIZE;
......
......@@ -563,7 +563,7 @@
(define-syntax-rule (mk-failure0-l fr code)
(lambda ()
(gp-unwind-tail fr)
(gp-unwind fr)
(code)))
......
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