all non assoq tests passes

parent 12bf0583
......@@ -10,7 +10,7 @@
<def> <<define>> <with-fail> <dynwind> parse<>
let<> <or-i> <or-union> <stall> <continue> <take>
<state-ref> <state-set!> <lv*> <clear>
<and-i> and-interleave interleave tr
<and-i> and-interleave interleave tr S
<letg> <set!> define-guarded *gp-var-tr* *kanren-assq* <scm> <zip> <cons>)
(re-export define-guile-log guile-log-macro? log-code-macro log-code-macro?)
......@@ -626,15 +626,14 @@
((_ w () code ...)
(parse<> w (<and> code ...)))))
(define (pku x) (pk (syntax->datum x)) x)
(define-syntax letify
(lambda (x)
(syntax-case x ()
((_ w ((m f) pat val) code ...)
#`(let<>0 w (m #,(pku (tr-pat #'pat)) (f val)) code ...))
#`(let<>0 w (m #,(tr-pat #'pat) (f val)) code ...))
((_ w (m pat val) code ...)
#`(let<>0 w (m #,(pku (tr-pat #'pat)) val) code ...)))))
#`(let<>0 w (m #,(tr-pat #'pat) val) code ...)))))
(define (tr-pat x)
......
......@@ -2,10 +2,9 @@
#define gp_redo 2
#define gp_redo_tag 2
#define gp_save_tag 6
#define gp_unbd SCM_PACK(GP_MK_FRAME_UNBD(gp_type))
//#define DB(X) X
static inline SCM gp_handle(SCM item, int ret)
static inline SCM gp_handle(SCM item, int ret, SCM gp_unbd)
{
SCM x = SCM_BOOL_F,q,a,b,*id;
......@@ -54,7 +53,7 @@ static inline SCM gp_handle(SCM item, int ret)
}
}
static inline int gp_advanced(SCM item, int state, SCM *old)
static inline int gp_advanced(SCM item, int state, SCM *old, SCM gp_unbd)
{
SCM redo;
scm_t_bits tag = SCM_UNPACK(SCM_CAR(item));
......@@ -72,7 +71,7 @@ static inline int gp_advanced(SCM item, int state, SCM *old)
case 0:
*old = item;
item = SCM_CDR(item);
SCM_SETCAR(*old, gp_handle(item, 1));
SCM_SETCAR(*old, gp_handle(item, 1, gp_unbd));
SCM_SETCDR(*old, SCM_EOL);
return gp_store;
}
......@@ -82,7 +81,7 @@ static inline int gp_advanced(SCM item, int state, SCM *old)
redo = SCM_CAR(item);
if(state == gp_store)
SCM_SETCDR(*old, redo);
gp_handle(SCM_CDR(item), 0);
gp_handle(SCM_CDR(item), 0, gp_unbd);
*old = redo;
return gp_redo;
default:
......@@ -97,7 +96,7 @@ item
(i . l)
*/
static inline int gp_do_cons(SCM item, int state, SCM *old)
static inline int gp_do_cons(SCM item, int state, SCM *old, SCM gp_unbd)
{
SCM q,a,b,*id,tag;
......@@ -106,7 +105,7 @@ static inline int gp_do_cons(SCM item, int state, SCM *old)
tag = SCM_CAR(item);
if(SCM_I_INUMP(tag))
return gp_advanced(item,state,old);
return gp_advanced(item,state,old,gp_unbd);
gp_debug0("not inum tag\n");
......@@ -171,12 +170,22 @@ static inline int gp_do_cons(SCM item, int state, SCM *old)
static inline void gp_unwind0(SCM *ci, SCM *si, struct gp_stack *gp)
{
SCM val, old = SCM_EOL;
SCM *i, *ci_old, *id;
SCM *i, *ci_old,*si_old, *id;
int state = 0;
SCM gp_unbd;
mask_on(gp->id,&gp_unbd,SCM_PACK(GP_MK_FRAME_UNBD(gp_type)));
DB(printf("unwind> %x %x\n",ci - gp->gp_cstack, gp->gp_ci - gp->gp_cstack);fflush(stdout));
if(gp->gp_ci < ci || gp->gp_si < si)
{
scm_misc_error("gp_unwind","wrong unwind forward in time",SCM_EOL);
}
ci_old = gp->gp_ci;
si_old = gp->gp_si;
gp->gp_ci = ci;
gp->gp_si = si;
......@@ -186,7 +195,7 @@ static inline void gp_unwind0(SCM *ci, SCM *si, struct gp_stack *gp)
gp_debug1("iter %x\n",i - gp->gp_cstack);
if(SCM_CONSP(*i))
{
state = gp_do_cons(*i, state, &old);
state = gp_do_cons(*i, state, &old, gp_unbd);
continue;
}
......@@ -216,10 +225,33 @@ static inline void gp_unwind0(SCM *ci, SCM *si, struct gp_stack *gp)
old = SCM_CDR(old);
}
}
id[0] = gp_unbd;
id[1] = SCM_UNBOUND;
}
if(0)
{ //Check the si stack that everything is unbounded
int found = 0;
for(i = si; i < si_old; i+=2)
{
if (! (i[0] == gp_unbd && i[1] == SCM_UNBOUND))
found = 1;
}
if(found)
{
for(i = si; i < si_old; i+=2)
{
printf("examine %x\n",(i - gp->gp_stack)/2);
if (! (i[0] == gp_unbd && i[1] == SCM_UNBOUND))
printf("failure at var %x, (%x ~ %x), (%x ~ %x)\n",
(i - gp->gp_stack)/2,
SCM_UNPACK(i[0]), SCM_UNPACK(gp_unbd),
SCM_UNPACK(i[1]), SCM_UNPACK(SCM_UNBOUND));
}
scm_misc_error("gp_unwind","si not cleaned",SCM_EOL);
}
}
gp_debug1("last routines %x\n",gp->gp_ci - gp->gp_cstack);
if(state)
......@@ -554,6 +586,8 @@ static void gp_restore_state(SCM data, struct gp_stack *gp)
int n, m;
SCM *ci,*ci_x,pp_x;
int restored;
SCM gp_unbd;
mask_on(gp->id,&gp_unbd,SCM_PACK(GP_MK_FRAME_UNBD(gp_type)));
gp_debug0("to restore\n");
......
......@@ -388,6 +388,7 @@ static inline SCM gp_newframe(SCM s)
return scm_cons(SCM_CAR(sss),scm_cons(cons,ss));
}
#define GP_TEST_STACK if(gp->gp_si > gp->gp_nns) scm_out_of_range(NULL, SCM_I_MAKINUM(gp->gp_ns))
static inline SCM* gp_mk_var(SCM s)
{
......@@ -431,7 +432,8 @@ static inline SCM gp_mk_cons(SCM s)
fi = GP_MK_FRAME_CONS(gp_type);
mask_on(gp->id,(ret+4),SCM_PACK(fi));
*(ret+5) = SCM_UNDEFINED;
gp_store_var_2(ret+4,1,gp);
fi = GP_MK_FRAME_UNBD(gp_type);
mask_on(gp->id,(ret+2),SCM_PACK(fi));
mask_on(gp->id,(ret+0),SCM_PACK(fi));
......
......@@ -15,7 +15,7 @@
(define (translate x) x)
#;
(define (check? x y)
(let ((ret (translate x)))
(format #t "check> ~a == ~a~%" ret y)
......@@ -23,7 +23,7 @@
(equal? ret y)))
#;
(define-syntax check?
(syntax-rules ()
((_ x y)
......@@ -1426,14 +1426,13 @@
(+o m k n))
(<define> (*o n m p)
(<pp> `(*o ,n ,m ,p))
(<if> (<==> ((_ . _) . _) m) (<code> (error "bail out *o")) <cc>)
(<condi>
((<=> '() n) (<=> '() p))
((poso n) (<=> '() m) (<=> '() p))
((<=> '(1) n) (poso m) (<=> m p))
((>1o n) (<=> '(1) m) (<=> n p))
((<var> (x z)
(<if> (<==> ((_ . _) . _) m) (<code> (error "bail out *o10")) <cc>)
(<=> (0 . x) n) (poso x)
(<=> (0 . z) p) (poso z)
(>1o m)
......
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