logical assoc vars debugged for engines

parent d435426c
(define-module (logic guile-log paralell)
#:use-module (logic guile-log)
#:use-module (logic guile-log umatch)
#:export (<pand> <pzip> f test1 test2))
#:export (<pand> <pzip> f test1 test2 test3 test4))
(<define-guile-log-rule> (<pit> cc p s code ...)
(<define-guile-log-rule> (<pit> s p cc code ...)
(<letrec> ((cc-internal
(lambda (s0 p0)
(set! cc-internal cc)
......@@ -21,12 +21,15 @@
(cc CC))
(<code> (gp-combine-engines data))
(<let*> ((s frame)
(ccc (lambda (ss pp) (cc s p))))
(ccc (lambda (ss pp)
(cc (gp-combine-state
s (list se ...))
p))))
(<with-s> s
(<pit> ccc p s
(<pit> s p ccc
(<with-fail> p
(<with-s> (gp-push-engine frame engine)
(<set> v (gp-peek-engine))
(<code> (gp-var-set v (gp-peek-engine) S))
code ...
(<code> (set! se S))
(<code> (gp-pop-engine))))))
......@@ -35,7 +38,7 @@
(<with-fail> p <cc>))))))
(<define-guile-log-rule> (<pzip> (v p se code ...) ...)
(<define-guile-log-rule> (<pzip> (v se p code ...) ...)
(<var> (p ...)
(<let*> ((l '())
(pwork
......@@ -47,26 +50,48 @@
(q))))
(ccwork
(lambda (s pp cc)
(pwork (lambda () (cc s pp)))))
(pend
(pwork (lambda () (cc s pp))))))
(<pand> (v se (gp-make-engine 100) code ... (<set> p P)) ...)
(ccwork)
(let ((pend
(lambda ()
(set! l (list (<lookup> p) ...))
(pwork #f))))
(<pand> (v se (gp-make-engine 100) code ... (<set> p P)) ...)
(ccwork)
(<with-fail> pend <cc>))))
(<with-fail> pend <cc>)))))
(<define> (g x n)
(<recur> lp ((i 0) (x x))
(if (< i n)
(<var> (l)
(<or> (<=> x (1 . l))
(<=> x (2 . l)))
(lp (+ i 1) l))
(<=> x '()))))
(<define> (f x n)
(<recur> lp ((i 0))
(if (< i n)
(<or> (<=> x i) (lp (+ i 1))))))
(<define> (test1 x y)
(<pzip> (v1 p1 s1 (f x 3)) (v2 p2 s2 (f y 3))))
(<pzip> (v1 s1 p1 (f x 3)) (v2 s2 p2 (f y 3))))
(<define> (test2 x y)
(<pzip> (v1 p1 s1 (<member> 1 x)) (v2 p2 s2 (<member> 2 y))))
(<pzip> (v1 s1 p1 (<member> 1 x)) (v2 s2 p2 (<member> 2 y))))
(<define> (test3 x y)
(<logical++>)
(<pzip> (v1 s1 p1 (g x 10)) (v2 s2 p2 (g y 10)))
(<logical-->))
(<define> (test4 x y z w)
(<logical++>)
(<pzip> (v1 s1 p1 (test3 x y)) (v2 s2 p2 (test3 z w)))
(<logical-->))
......@@ -105,7 +105,7 @@ inline void gp_gc_inc(struct gp_stack *gp)
enlarge_csstack(gp,Nc,2*Nc);
nc = gp->gp_nncs - gp->gp_cs;
}
if(nf < 5)
if(nf < 10)
{
enlarge_frstack(gp,Nf,2*Nf);
nf = gp->gp_nnfr - gp->gp_fr;
......
......@@ -48,8 +48,8 @@ inline SCM get_l(SCM l)
return SCM_CAR(l);
}
inline SCM logical_lookup3_(SCM x, SCM l, SCM rest, int refp);
inline SCM logical_lookup(SCM x, SCM l, SCM rest, int refp)
inline SCM logical_lookup3_(SCM x, SCM l, SCM rest, int refp, int *found);
inline SCM logical_lookup(SCM x, SCM l, SCM rest, int refp, int *found)
{
/*
{
......@@ -84,7 +84,8 @@ inline SCM logical_lookup(SCM x, SCM l, SCM rest, int refp)
if(scm_is_eq(SCM_CAR(car),x))
{
SCM y = SCM_CDR(car);
if(!GP(x))
*found = 1;
if(!GP(y))
{
if(refp)
return x;
......@@ -92,8 +93,8 @@ inline SCM logical_lookup(SCM x, SCM l, SCM rest, int refp)
return y;
}
if(!GP_UNBOUND(GP_GETREF(x)))
return x;
if(!GP_UNBOUND(GP_GETREF(y)))
return y;
return x;
}
......@@ -103,31 +104,42 @@ inline SCM logical_lookup(SCM x, SCM l, SCM rest, int refp)
goto retry;
}
}
else if SCM_NULLP(l)
{
return x;
}
else if (vlist_p(car))
{
SCM y = logical_lookup3_(x, car, rest, refp);
if(scm_is_eq(x,y))
SCM y = logical_lookup3_(x, car, rest, refp, found);
if(!*found)
{
l = SCM_CDR(l);
goto retry;
}
return y;
}
else if (SCM_I_IS_VECTOR(car))
{
SCM list_of_engines = SCM_SIMPLE_VECTOR_REF(car,0);
SCM rest = SCM_CDR(l);
SCM rest2 = SCM_CDR(l);
recur:
if(!SCM_CONSP(list_of_engines))
{
return x;
l = rest2;
goto retry;
}
SCM engine = SCM_CAR(list_of_engines);
if(scm_is_eq(engine, rest))
return x;
{
list_of_engines = SCM_CDR(list_of_engines);
goto recur;
}
SCM y = logical_lookup3_(x, engine, rest, refp);
if(scm_is_eq(x,y))
SCM y = logical_lookup3_(x, engine, rest, refp, found);
if(!*found)
{
list_of_engines = SCM_CDR(list_of_engines);
goto recur;
......@@ -135,14 +147,16 @@ inline SCM logical_lookup(SCM x, SCM l, SCM rest, int refp)
return y;
}
else
scm_misc_error("logical_lookup","malformed assoc",SCM_EOL);
}
return x;
}
inline SCM logical_lookup3_(SCM x, SCM l, SCM rest, int refp)
inline SCM logical_lookup3_(SCM x, SCM l, SCM rest, int refp, int *found)
{
gp_debug1("logical lookup %d\n", refp);
if(!GP(x))
{
return x;
......@@ -160,7 +174,7 @@ inline SCM logical_lookup3_(SCM x, SCM l, SCM rest, int refp)
if(SCM_CONSP(l))
{
return logical_lookup(x,l,rest,refp);
return logical_lookup(x,l,rest,refp, found);
}
{
......@@ -175,6 +189,7 @@ inline SCM logical_lookup3_(SCM x, SCM l, SCM rest, int refp)
if(!scm_is_eq(v, SCM_UNSPECIFIED))
{
*found = 1;
if(!GP(v))
{
if(refp)
......@@ -192,12 +207,17 @@ inline SCM logical_lookup3_(SCM x, SCM l, SCM rest, int refp)
inline SCM logical_lookup_all(SCM x, SCM l, int refp)
{
int found = 0;
recur:
{
SCM y = logical_lookup3_(x,l, SCM_EOL, refp);
if(GP(y) && GP_UNBOUND(GP_GETREF(y)) && !scm_is_eq(x,y))
SCM y = logical_lookup3_(x,l, SCM_EOL, refp, &found);
if(found)
{
if(x==y)
return x;
x = y;
found = 0;
goto recur;
}
else
......@@ -209,7 +229,7 @@ inline SCM logical_lookup_all(SCM x, SCM l, int refp)
inline SCM logical_lookup_l(SCM x, SCM *l)
{
SCM ll = GP_UNREF(l);
SCM ll = l[0];
return logical_lookup_all(x,ll,0);
}
......@@ -224,13 +244,15 @@ inline SCM logical_lookup4(SCM x, SCM l)
}
SCM wrap(SCM l, SCM x)
inline SCM wrap(SCM l, SCM x)
{
return x;
}
SCM logical_add2__(SCM x, SCM v, SCM l)
{
//format3("add ~a . ~a in ~a~%",x,v,l);
gp_debug0("logical add__\n");
int n;SCM pt;
for(n = 0,pt = l;SCM_CONSP(pt);pt = SCM_CDR(pt),n++);
......@@ -260,6 +282,8 @@ SCM logical_add2_(SCM x, SCM v, SCM l)
SCM logical_add2(SCM x, SCM v, SCM ll)
{
gp_debug0("logical add\n");
if(scm_is_eq(x,v))
return ll;
......@@ -296,6 +320,7 @@ SCM inline wrap_l(SCM *l, SCM val)
SCM inline logical_add2_l__(SCM x, SCM v, SCM *l)
{
//gp_debug0("logical add_l__\n");
if(SCM_CONSP(*l) || SCM_NULLP(*l))
{
int n;SCM pt;
......@@ -341,6 +366,8 @@ SCM inline logical_add2_l_(SCM x, SCM v, SCM *l)
SCM inline logical_add2_l(SCM x, SCM v, SCM *l)
{
gp_debug0("logical add_l\n");
//format3("add_l ~a . ~a in ~a~%",x,v,*l);
if(scm_is_eq(x,v))
return SCM_BOOL_T;
......@@ -360,7 +387,7 @@ SCM inline logical_add2_l(SCM x, SCM v, SCM *l)
return wrap_l(l, scm_cons(new_vlist, ll));
}
else
return wrap_l(l, logical_add2_l__(x, v, l));
return logical_add2_l__(x, v, l);
}
if(SCM_NULLP(ll))
......
......@@ -1544,6 +1544,8 @@ SCM_DEFINE(gp_pop_engine, "gp-pop-engine", 0, 0, 0, (),
return SCM_BOOL_F;
}
gp_debug0("Pop Engine>\n");
SCM s_stack = SCM_CAR(gp_engine_path);
gp_engine_path = SCM_CDR(gp_engine_path);
......@@ -1578,10 +1580,17 @@ SCM_DEFINE(gp_push_engine, "gp-push-engine", 2, 0, 0, (SCM s, SCM e),
{
SCM x = scm_cons(SCM_BOOL_F,e);
SCM cdr;
gp_debug0("Push Engine>\n");
struct gp_stack *gp = get_gp();
int logical = gp->_logical_;
gp_engine_path = scm_cons(x , gp_engine_path);
scm_fluid_set_x(gp_current_stack,e);
gp = get_gp();
gp_clear(SCM_BOOL_F);
gp->_logical_ = logical;
SCM ss = scm_fluid_ref(current_stack); //Sooo confusing TODO: FIXME
SCM carss = gp_car(ss,ss);
......@@ -1595,7 +1604,7 @@ SCM_DEFINE(gp_push_engine, "gp-push-engine", 2, 0, 0, (SCM s, SCM e),
cdr = scm_cons(SCM_EOL,SCM_EOL);
}
ss = scm_cons(carss , scm_cons(SCM_CAR(cdr), gp_engine_path));
ss = scm_cons(carss , scm_cons(SCM_CAR(cdr), gp_engine_path));
SCM_SETCAR(x, s);
......@@ -1624,9 +1633,9 @@ SCM_DEFINE(gp_combine_state, "gp-combine-state", 2, 0, 0, (SCM s, SCM l),
#define FUNC_NAME s_gp_combine_engine
{
SCM data = gp_gp_cdr(s,s);
SCM l0 = SCM_CAR(data);
SCM l0 = SCM_CAR(data);
SCM ll = SCM_EOL;
SCM ll = SCM_EOL;
while(SCM_CONSP(l))
{
SCM sx = SCM_CAR(l);
......@@ -1634,8 +1643,8 @@ SCM_DEFINE(gp_combine_state, "gp-combine-state", 2, 0, 0, (SCM s, SCM l),
if(!scm_is_eq(e,l0))
{
ll = scm_cons(e, ll);
l = SCM_CDR(l);
}
l = SCM_CDR(l);
}
SCM sout;
......
......@@ -129,7 +129,7 @@ SCM gp_procedure_name(SCM f)
#define DB(X)
#define DS(X)
#define DS(X)
#define gp_debug0(s) DB(printf(s) ; fflush(stdout))
#define gp_debug1(s,a) DB(printf(s,a) ; fflush(stdout))
#define gp_debug2(s,a,b) DB(printf(s,a,b) ; fflush(stdout))
......@@ -346,24 +346,26 @@ static inline SCM gp_make_closure_heap(int n, SCM **closure)
SCM a; \
a = scm_fluid_ref(gp_current_stack); \
if(!GP_STACKP(a)) \
scm_misc_error("unpack_s2",err,SCM_EOL); \
{ \
scm_misc_error("unpack_s2",err,scm_list_2(s,a)); \
} \
gp = GET_GP(a); \
gp_debug0(err); \
if(GP_CONSP(s)) \
{ \
ll = GP_GETREF(s)[2]; \
l = GET_L(ll); \
} \
else if(SCM_CONSP(s)) \
{ \
ll = SCM_CDR(s); \
l = GET_L(ll); \
} \
else \
{ \
l = SCM_EOL; \
ll = scm_cons(SCM_EOL,SCM_EOL); \
} \
if(GP_CONSP(s)) \
{ \
ll = GP_GETREF(s)[2]; \
l = GET_L(ll); \
} \
else if(SCM_CONSP(s)) \
{ \
ll = SCM_CDR(s); \
l = GET_L(ll); \
} \
else \
{ \
l = SCM_EOL; \
ll = scm_cons(SCM_EOL,SCM_EOL); \
} \
}
#define UNPACK_S0(l,s,err) \
......@@ -388,6 +390,7 @@ static inline SCM gp_make_closure_heap(int n, SCM **closure)
#define UNPACK_ALL(fr,ll,l,ggp,gp,s,err) \
{ \
gp_format1("s: ~a~%",s); \
ggp = scm_fluid_ref(gp_current_stack); \
if(!GP_STACKP(ggp)) \
scm_misc_error("unpack_a2",err,SCM_EOL); \
......@@ -443,7 +446,7 @@ static inline SCM gp_make_closure_heap(int n, SCM **closure)
#define PACK_ALL(fr,ll,l,lnew,gp,s) \
{ \
if(!scm_is_eq(l,lnew)) \
s = scm_cons(fr,scm_cons(l,SCM_CDR(ll))); \
s = scm_cons(fr,scm_cons(lnew,SCM_CDR(ll))); \
}
inline SCM gp_make_s(SCM frci, SCM *l)
......@@ -855,7 +858,7 @@ static inline SCM * gp_lookup(SCM *id, SCM l)
retry:
if(!SCM_NULLP(l) && !scm_is_eq(l,SCM_EOL)) goto advanced;
if(!SCM_NULLP(l)) goto advanced;
if(SCM_VARIABLEP(GP_UNREF(id)))
{
......@@ -2590,6 +2593,8 @@ SCM_DEFINE(gp_gp_unify,"gp-unify!",3,0,0,(SCM v1, SCM v2, SCM s),
else
oldi = SCM_BOOL_F;
//format1("unify> ~a~%",l[0]);
ret = gp_unify(vv1,vv2,0,1,l,gp,fr);
gp_debus0("/gp-unify!>\n");
if(ret)
......@@ -2599,6 +2604,8 @@ SCM_DEFINE(gp_gp_unify,"gp-unify!",3,0,0,(SCM v1, SCM v2, SCM s),
l[0] = make_vlist(S(l[0],0),SCM_UNPACK(l[2]));
}
//format2("unify/end> ~a ~a~%",l[0],old);
PACK_ALL(fr,ll, old, l[0], ggp,s);
//printf("true\n");
......@@ -3604,7 +3611,7 @@ SCM_DEFINE(gp_fluid_force_bang, "gp-var-set!", 3, 0, 0,
SCM *id, l,ll;
struct gp_stack *gp;
UNPACK_S(ll,l,gp,s,"failed to unpack s in gp_fluid_set_bang");
UNPACK_S(ll,l,gp,s,"failed to unpack s in gp_fluid_force_bang ~a~%");
int old = gp->_logical_;
gp->_logical_ = 0;
......@@ -3635,7 +3642,7 @@ SCM_DEFINE(gp_fluid_set_bang, "gp-var-set", 3, 0, 0, (SCM f, SCM v, SCM s),
SCM *id, l, ll;
struct gp_stack *gp;
UNPACK_S(ll,l,gp,s,"failed to unpack s in gp_fluid_set_bang");
UNPACK_S(ll,l,gp,s,"failed to unpack s in gp_fluid_set_bang ~a");
int old = gp->_logical_;
gp->_logical_ = 0;
......
......@@ -110,6 +110,7 @@
gp-peek-engine
gp-pop-engine
gp-combine-engines
gp-combine-state
)
......
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