zip engines works but bugs remains

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