all non assoq tests passes

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