zip engines works but bugs remains

parent 0e4ec21c
......@@ -36,6 +36,7 @@ PSSOURCES = \
logic/guile-log/tools.scm \
logic/guile-log/prompts.scm \
logic/guile-log.scm \
logic/guile-log/paralell.scm \
logic/guile-log/vset.scm \
logic/guile-log/vlist-macros.scm \
logic/guile-log/collects.scm \
......
(define-module (logic guile-log parallel)
(define-module (logic guile-log paralell)
#:use-module (logic guile-log)
#:export (<pand>))
#:use-module (logic guile-log umatch)
#:export (<pand> <pzip> f test))
(<define-guile-log-rule> (<pit> cc code ...)
(<let> ((cc-internal
(lambda (s p)
(set! cc-internal cc)
(CC s p))))
(<with-cc> cc-internal code ...)))
(<define-guile-log-rule> (<pit> cc p s code ...)
(<letrec> ((cc-internal
(lambda (s0 p0)
(set! cc-internal cc)
(CC s p))))
(<with-cc> (lambda (s p) (cc-internal s p))
code ...)))
(<define-guile-log-rule> (<pand> (v engine code ...) ...)
(<var> (v ...)
......@@ -16,15 +18,50 @@
(frame (<newframe>))
(p P)
(cc CC))
(<code> (gp-combine-engines data)
(<pit> cc
(<with-p> p
(<code> (gp-combine-engines data))
(<let*> ((s frame)
(ccc (lambda (ss pp) (cc s p))))
(<with-s> s
(<pit> ccc p s
(<with-fail> p
(<with-s> (gp-push-engine frame engine)
code
(<=> v ,(gp-pop-engine)))))
...
(<with-fail> p <cc>)))))
(<set> v (gp-peek-engine))
code ...
(<code> (gp-pop-engine))))))
...
(<with-s> s
(<with-fail> p <cc>))))))
(<define-guile-log-rule> (<pzip> (v p code ...) ...)
(<var> (p ...)
(<let*> ((l '())
(pwork
(lambda (q)
(if (pair? l)
(let ((pp (car l)))
(set! l (cdr l))
(pp))
(q))))
(ccwork
(lambda (s pp cc)
(pwork (lambda () (cc s pp)))))
(pend
(lambda ()
(set! l (list (<lookup> p) ...))
(pwork #f))))
(<pand> (v (gp-make-engine 100) code ... (<set> p P)) ...)
(ccwork)
(<with-fail> pend <cc>))))
(<define> (f x n)
(<recur> lp ((i 0))
(if (< i n)
(<or> (<=> x i) (lp (+ i 1))))))
(<define> (test x y)
(<pzip> (v1 p1 (f x 3)) (v2 p2 (f y 3))))
......@@ -1545,12 +1545,15 @@ SCM_DEFINE(gp_pop_engine, "gp-pop-engine", 0, 0, 0, (),
}
SCM s_stack = SCM_CAR(gp_engine_path);
gp_engine_path = SCM_CDR(gp_engine_path);
scm_fluid_set_x(gp_current_stack, SCM_CDR(s_stack));
scm_fluid_set_x(gp_current_stack, SCM_CDR(SCM_CAR(gp_engine_path)));
gp_engine_path = SCM_CDR(gp_engine_path);
if(!SCM_CONSP(gp_engine_path))
scm_misc_error("gp-pop-engine","poped to an empty list",SCM_EOL);
return SCM_CAR(s_stack);
return s_stack;
}
#undef FUNC_NAME
......@@ -1574,23 +1577,27 @@ SCM_DEFINE(gp_push_engine, "gp-push-engine", 2, 0, 0, (SCM s, SCM e),
#define FUNC_NAME s_gp_push_engine
{
SCM x = scm_cons(SCM_BOOL_F,e);
SCM car;
SCM cdr;
gp_engine_path = scm_cons(x , gp_engine_path);
scm_fluid_set_x(gp_current_stack,e);
gp_clear(SCM_BOOL_F);
SCM ss = scm_fluid_ref(current_stack); //Sooo confusing TODO: FIXME
SCM carss = gp_car(ss,ss);
if(SCM_CONSP(s) || GP_CONSP(s))
{
car = gp_car(s,s);
cdr = gp_gp_cdr(s,s);
cdr = gp_gp_cdr(s,s);
}
else
{
car = SCM_BOOL_F;
cdr = scm_cons(SCM_EOL,SCM_EOL);
cdr = scm_cons(SCM_EOL,SCM_EOL);
}
SCM ss;
gp_engine_path = scm_cons(x , gp_engine_path);
ss = scm_cons(car, scm_cons(SCM_CAR(cdr), gp_engine_path));
SCM_SETCAR(x, ss);
ss = scm_cons(carss , scm_cons(SCM_CAR(cdr), gp_engine_path));
SCM_SETCAR(x, s);
return ss;
}
......
......@@ -548,6 +548,8 @@ 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)
{
gp_debug1("ci i> %d\n",(int)(i - ci));
if(i == gp->gp_cstack)
scm_misc_error("unwind",
"unwinding the first protected ci stack element",
......@@ -584,13 +586,14 @@ static void gp_unwind0(SCM *fr, SCM *ci, SCM *si, SCM *cs, struct gp_stack *gp,
if(SCM_I_IS_VECTOR(*i))
{
SCM l = SCM_SIMPLE_VECTOR_REF(*i,0);
SCM p = SCM_CAR(path);
if(scm_is_false(p))
if(!SCM_CONSP(path))
{
unwind_all_in_branch(l);
}
else
else
{
SCM p = SCM_CAR(path);
int found = 0;
for(;SCM_CONSP(l);l=SCM_CDR(l))
{
......@@ -603,8 +606,13 @@ static void gp_unwind0(SCM *fr, SCM *ci, SCM *si, SCM *cs, struct gp_stack *gp,
break;
}
}
if(!found) unwind_all_in_branch(l);
if(!found)
unwind_all_in_branch(l);
else
break;
}
continue;
}
if(!GP(*i))
......@@ -874,18 +882,11 @@ static inline void gp_unwind_(SCM s , int ncons, int nvar, int nci,
void unwind_in_new_branch(SCM p, SCM path, SCM lpath)
{
SCM engine = SCM_CDR(p);
SCM engine = SCM_CDR(p);
gp_engine_path = scm_cons(p, gp_engine_path);
scm_fluid_set_x(gp_current_stack, engine);
if(SCM_CONSP(path))
{
gp_unwind_(SCM_CAR(p), 0, 0, 0, path, lpath);
}
else
{
gp_unwind_(SCM_CAR(p), 0, 0, 0, path, lpath);
}
gp_unwind_(SCM_CAR(p), 0, 0, 0, path, lpath);
}
/*
......@@ -896,7 +897,6 @@ static inline void gp_unwind_(SCM s , int ncons, int nvar, int nci,
SCM path, SCM lpath)
{
SCM lt = SCM_EOL;
if(scm_is_false(lpath))
{
lt = gp_gp_cdr(s,s);
......@@ -904,7 +904,7 @@ static inline void gp_unwind_(SCM s , int ncons, int nvar, int nci,
path = SCM_CDR(lt);
else
path = gp_engine_path;
if(SCM_CONSP(path))
{
SCM l = gp_engine_path;
......@@ -933,14 +933,19 @@ static inline void gp_unwind_(SCM s , int ncons, int nvar, int nci,
path = b;
}
}
if(SCM_CONSP(path))
{
s = SCM_CAAR(path);
if(scm_is_false(lpath))
lpath = scm_list_4(s,SCM_PACK((scm_t_bits) ncons),
SCM_PACK((scm_t_bits) nvar),
SCM_PACK((scm_t_bits) nci));
{
lpath = scm_list_4(s,
scm_from_int(ncons),
scm_from_int(nvar),
scm_from_int(nci));
}
s = SCM_CAAR(path);
ncons = 0;
nvar = 0;
nci = 0;
......@@ -951,11 +956,11 @@ static inline void gp_unwind_(SCM s , int ncons, int nvar, int nci,
{
s = SCM_CAR(lpath);
lpath = SCM_CDR(lpath);
ncons = (int) SCM_UNPACK(SCM_CAR(lpath));
ncons = scm_to_int(SCM_CAR(lpath));
lpath = SCM_CDR(lpath);
nvar = (int) SCM_UNPACK(SCM_CAR(lpath));
nvar = scm_to_int(SCM_CAR(lpath));
lpath = SCM_CDR(lpath);
nci = (int) SCM_UNPACK(SCM_CAR(lpath));
nci = scm_to_int(SCM_CAR(lpath));
}
}
......
......@@ -33,7 +33,7 @@ SCM inline get_cs(SCM v);
SCM gp_engine_path = SCM_EOL;
SCM gp_current_stack = SCM_BOOL_F;
SCM current_stack = SCM_BOOL_F;
int do_gp_mark = 1;
#define gp_store 1
......@@ -128,7 +128,7 @@ SCM gp_procedure_name(SCM f)
}
#define DB(X)
#define DB(X)
#define DS(X)
#define gp_debug0(s) DB(printf(s) ; fflush(stdout))
#define gp_debug1(s,a) DB(printf(s,a) ; fflush(stdout))
......@@ -2777,7 +2777,6 @@ static void gp_unwind0(SCM *fr, SCM *ci, SCM *si, SCM *cs, struct gp_stack *gp,
void gp_unwind_dynstack(struct gp_stack *gp, scm_t_bits dyn_n);
SCM current_stack = SCM_BOOL_F;
SCM_DEFINE(gp_set_current_stack_x, "gp-set-current-stack", 1, 0, 0, (SCM x),
"resets the unifyier stacks")
......
......@@ -321,9 +321,8 @@
(define *current-stack* (make-fluid '()))
((@@(logic guile-log code-load) gp-set-current-stack) *current-stack*)
(gp-clear 1)
(fluid-set! *current-stack* (gp-push-engine (fluid-ref *current-stack*)
root-engine))
(gp-push-engine (fluid-ref *current-stack*)
root-engine)
(define (gp-var-set! v val)
......
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