make sure that conflicting bindings fails

parent 426300d9
...@@ -11,16 +11,16 @@ ...@@ -11,16 +11,16 @@
(() <fail>) (() <fail>)
((x) (goal-eval x)) ((x) (goal-eval x))
((x y) ((x y)
(<pand> (<pand> fail
(p1 s1 (gp-make-engine 100) (goal-eval x)) (p1 s1 (gp-make-engine 100) (goal-eval x))
(p2 s2 (gp-make-engine 100) (goal-eval y)))) (p2 s2 (gp-make-engine 100) (goal-eval y))))
((x y u) ((x y u)
(<pand> (<pand> fail
(p1 s1 (gp-make-engine 100) (goal-eval x)) (p1 s1 (gp-make-engine 100) (goal-eval x))
(p2 s2 (gp-make-engine 100) (goal-eval y)) (p2 s2 (gp-make-engine 100) (goal-eval y))
(p3 s3 (gp-make-engine 100) (goal-eval u)))) (p3 s3 (gp-make-engine 100) (goal-eval u))))
((x y u v) ((x y u v)
(<pand> (<pand> fail
(p1 s1 (gp-make-engine 100) (goal-eval x)) (p1 s1 (gp-make-engine 100) (goal-eval x))
(p2 s2 (gp-make-engine 100) (goal-eval y)) (p2 s2 (gp-make-engine 100) (goal-eval y))
(p3 s3 (gp-make-engine 100) (goal-eval u)) (p3 s3 (gp-make-engine 100) (goal-eval u))
...@@ -30,7 +30,7 @@ ...@@ -30,7 +30,7 @@
(if (= n 0) (if (= n 0)
(cons l u) (cons l u)
(lp (cdr l) (cons (car l) u) (- n 1)))))) (lp (cdr l) (cons (car l) u) (- n 1))))))
(<pand> (<pand> fail
(p1 s1 (gp-make-engine 100) (<apply> paralell (car l-u))) (p1 s1 (gp-make-engine 100) (<apply> paralell (car l-u)))
(p3 s3 (gp-make-engine 100) (<apply> paralell (cdr l-u)))))))) (p3 s3 (gp-make-engine 100) (<apply> paralell (cdr l-u))))))))
......
...@@ -16,7 +16,17 @@ ...@@ -16,7 +16,17 @@
(define *cc* (@@ (logic guile-log run) *cc*)) (define *cc* (@@ (logic guile-log run) *cc*))
(<define-guile-log-rule> (<pand> (v se engine code ...) ...) (<define> (check-bindings check key.vals)
(<recur> lp ((l key.vals))
(if (pair? l)
(let ((x (car l))
(k (car x))
(v (cdr x)))
(<if> (<=> k v)
(lp (cdr l))
(check))))))
(<define-guile-log-rule> (<pand> check (v se engine code ...) ...)
(<var> (v ...) (<var> (v ...)
(<let> ((data (list v ...)) (<let> ((data (list v ...))
(frame (<newframe>)) (frame (<newframe>))
...@@ -34,7 +44,6 @@ ...@@ -34,7 +44,6 @@
(<with-fail> p (<with-fail> p
(<with-s> (gp-push-engine frame engine) (<with-s> (gp-push-engine frame engine)
(<code> (gp-combine-push data)) (<code> (gp-combine-push data))
(state-guard-dynamic-object *cc*)
(<code> (gp-var-set v (gp-peek-engine) S)) (<code> (gp-var-set v (gp-peek-engine) S))
code ... code ...
(<code> (set! se S)) (<code> (set! se S))
...@@ -42,11 +51,13 @@ ...@@ -42,11 +51,13 @@
... ...
(<code> (gp-combine-engines data)) (<code> (gp-combine-engines data))
(<with-s> (gp-combine-state s (list se ...)) (let ((s.bindings (gp-combine-state s (list se ...))))
(<with-fail> p <cc>)))))) (check-bindings check (cdr s.bindings))
(<with-s> (car s.bindings)
(<with-fail> p <cc>))))))
(<define-guile-log-rule> (<pzip> (v se p code ...) ...) (<define-guile-log-rule> (<pzip> check (v se p code ...) ...)
(<var> (p ...) (<var> (p ...)
(<let*> ((l '()) (<let*> ((l '())
(pwork (pwork
...@@ -59,7 +70,8 @@ ...@@ -59,7 +70,8 @@
(ccwork (ccwork
(lambda (s pp cc) (lambda (s pp cc)
(pwork (lambda () (cc s pp)))))) (pwork (lambda () (cc s pp))))))
(<pand> (v se (gp-make-engine 100) code ... (<set> p P)) ...) (<pand> (</.> <fail>)
(v se (gp-make-engine 100) code ... (<set> p P)) ...)
(ccwork) (ccwork)
(let ((pend (let ((pend
(lambda () (lambda ()
......
...@@ -355,7 +355,6 @@ static inline SCM *make_gp_stack(int id, int nthread, int nc, int ns, int ncs, i ...@@ -355,7 +355,6 @@ static inline SCM *make_gp_stack(int id, int nthread, int nc, int ns, int ncs, i
gp->_logical_ = 0; gp->_logical_ = 0;
gp->_thread_safe_ = 1; gp->_thread_safe_ = 1;
gp->id = id;
gp->thread_id = nthread; gp->thread_id = nthread;
gp->nrem = 0; gp->nrem = 0;
gp->n = 0; gp->n = 0;
...@@ -1543,7 +1542,7 @@ SCM_DEFINE(gp_pop_engine, "gp-pop-engine", 0, 0, 0, (), ...@@ -1543,7 +1542,7 @@ SCM_DEFINE(gp_pop_engine, "gp-pop-engine", 0, 0, 0, (),
{ {
return SCM_BOOL_F; return SCM_BOOL_F;
} }
gp_debug0("Pop Engine>\n"); gp_debug0("Pop Engine>\n");
SCM s_stack = SCM_CAR(gp_engine_path); SCM s_stack = SCM_CAR(gp_engine_path);
...@@ -1594,11 +1593,16 @@ SCM_DEFINE(gp_push_engine, "gp-push-engine", 2, 0, 0, (SCM s, SCM e), ...@@ -1594,11 +1593,16 @@ SCM_DEFINE(gp_push_engine, "gp-push-engine", 2, 0, 0, (SCM s, SCM e),
{ {
SCM x = scm_cons(SCM_BOOL_F,e); SCM x = scm_cons(SCM_BOOL_F,e);
SCM cdr; SCM cdr;
gp_debug0("Push Engine>\n"); gp_debug0("Push Engine>\n");
struct gp_stack *gp = get_gp(); struct gp_stack *gp = get_gp();
int logical = gp->_logical_; int logical = gp->_logical_;
int level = gp->id;
SCM rguards = gp->rguards;
gp_engine_path = scm_cons(x , gp_engine_path); gp_engine_path = scm_cons(x , gp_engine_path);
gp_paths = scm_cons(gp_engine_path, SCM_EOL); gp_paths = scm_cons(gp_engine_path, SCM_EOL);
...@@ -1608,6 +1612,14 @@ SCM_DEFINE(gp_push_engine, "gp-push-engine", 2, 0, 0, (SCM s, SCM e), ...@@ -1608,6 +1612,14 @@ SCM_DEFINE(gp_push_engine, "gp-push-engine", 2, 0, 0, (SCM s, SCM e),
gp = get_gp(); gp = get_gp();
gp_clear(SCM_BOOL_F); gp_clear(SCM_BOOL_F);
gp->_logical_ = logical; gp->_logical_ = logical;
gp->id = level + 1;
gp->rguards = rguards;
if(gp->id > 0)
{
gp->_thread_safe_ = 1;
}
SCM ss = scm_fluid_ref(current_stack); //Sooo confusing TODO: FIXME SCM ss = scm_fluid_ref(current_stack); //Sooo confusing TODO: FIXME
SCM carss = gp_car(ss,ss); SCM carss = gp_car(ss,ss);
...@@ -1643,8 +1655,6 @@ SCM_DEFINE(gp_new_engine, "gp-new-engine", 1, 0, 0, (SCM e), ...@@ -1643,8 +1655,6 @@ SCM_DEFINE(gp_new_engine, "gp-new-engine", 1, 0, 0, (SCM e),
gp_debug0("Push Engine>\n"); gp_debug0("Push Engine>\n");
gp_engine_path = scm_cons(x , SCM_EOL); gp_engine_path = scm_cons(x , SCM_EOL);
gp_paths = scm_cons(gp_engine_path, SCM_EOL); gp_paths = scm_cons(gp_engine_path, SCM_EOL);
...@@ -1701,7 +1711,7 @@ SCM_DEFINE(gp_combine_engines, "gp-combine-engines", 1, 0, 0, (SCM l), ...@@ -1701,7 +1711,7 @@ SCM_DEFINE(gp_combine_engines, "gp-combine-engines", 1, 0, 0, (SCM l),
struct gp_stack * gp = get_gp(); struct gp_stack * gp = get_gp();
GP_TEST_CSTACK; GP_TEST_CSTACK;
gp->gp_ci[0] = vec; gp->gp_ci[0] = vec;
gp->gp_ci++; gp->gp_ci++;
...@@ -1737,6 +1747,57 @@ SCM_DEFINE(gp_combine_push, "gp-combine-push", 1, 0, 0, (SCM r), ...@@ -1737,6 +1747,57 @@ SCM_DEFINE(gp_combine_push, "gp-combine-push", 1, 0, 0, (SCM r),
} }
#undef FUNC_NAME #undef FUNC_NAME
SCM variable_bindings = SCM_BOOL_F;
SCM variable_bindings_found = SCM_BOOL_F;
SCM all_variable_bindings = SCM_BOOL_F;
SCM folder(SCM key, SCM val, SCM seed, SCM data)
{
SCM val2 = scm_hash_ref(key, variable_bindings, SCM_BOOL_F);
if(scm_is_true(val))
{
return seed
}
else
{
SCM val3 = scm_hash_ref(key, all_variable_bindinges, SCM_BOOL_F);
if(scm_is_true(val3))
{
SCM val4 = scm_hash_ref(key, variable_bindings_found, SCM_BOOL_F);
if(scm_is_true(val4))
{
return scm_cons(scm_cons(key,val),seed);
}
else
{
scm_hash_set_x(key, SCM_BOOL_T, variables_bindings_found);
return scm_cons(scm_cons(key,val),
scm_cons(scm_cons(key, val3), seed));
}
}
else
{
scm_hash_set_X(key, val, all_variable_bindings);
}
}
}
SCM get_all_conflicting_bindings(SCM l)
{
variable_bindings_found = scm_make_hash_table();
all_variable_bindings = scm_make_hash_table();
ret = SCM_EOL;
for(;SCM_CONSP(l);l=SCM_CDR(l))
{
variable_bindings = scm_make_hash_table();
ret = vhash_fold_all_exp(SCM_BOOL_F, folder, ret, SCM_CAR(l));
}
return ret;
}
SCM_DEFINE(gp_combine_state, "gp-combine-state", 2, 0, 0, (SCM s, SCM l), SCM_DEFINE(gp_combine_state, "gp-combine-state", 2, 0, 0, (SCM s, SCM l),
"") "")
#define FUNC_NAME s_gp_combine_engine #define FUNC_NAME s_gp_combine_engine
...@@ -1756,20 +1817,22 @@ SCM_DEFINE(gp_combine_state, "gp-combine-state", 2, 0, 0, (SCM s, SCM l), ...@@ -1756,20 +1817,22 @@ SCM_DEFINE(gp_combine_state, "gp-combine-state", 2, 0, 0, (SCM s, SCM l),
l = SCM_CDR(l); l = SCM_CDR(l);
} }
SCM ret = get_all_conflicting_bindings(ll);
SCM sout; SCM sout;
if(SCM_CONSP(ll)) if(SCM_CONSP(ll))
{ {
ll = scm_reverse(ll); ll = scm_reverse(ll);
SCM vec = scm_c_make_vector (1,ll); SCM vec = scm_c_make_vector (1,ll);
sout = scm_cons(gp_car(s,s),scm_cons(scm_cons(vec,l0), SCM_CDR(data))); sout = scm_cons(gp_car(s,s),scm_cons(scm_cons(vec,l0), SCM_CDR(data)));
} }
else else
sout = s; sout = s;
return sout; return scm_cons(sout,ret);
} }
#undef FUNC_NAME #undef FUNC_NAME
......
...@@ -221,7 +221,7 @@ scm_t_bits gp_smob_t; ...@@ -221,7 +221,7 @@ scm_t_bits gp_smob_t;
//#define GP_HASH(x) ((SCM_UNPACK(x) & GPHA) >> H_BITS) //#define GP_HASH(x) ((SCM_UNPACK(x) & GPHA) >> H_BITS)
#define GP_ID(x) ((SCM_UNPACK(x) & GPID) >> N_BITS) #define GP_ID(x) ((SCM_UNPACK(x) & GPID) >> N_BITS)
#define GP_SETID(x,id) (id << N_BITS | x)
#define GP_COUNT(X) ((scm_t_bits) ((SCM_UNPACK(X) & GPHA) >> H_BITS)) #define GP_COUNT(X) ((scm_t_bits) ((SCM_UNPACK(X) & GPHA) >> H_BITS))
#define GP_SETCOUNT(X,i) (((SCM_UNPACK(X) & (~GPHA)) \ #define GP_SETCOUNT(X,i) (((SCM_UNPACK(X) & (~GPHA)) \
| ((i) << H_BITS))) | ((i) << H_BITS)))
......
...@@ -85,9 +85,12 @@ gp_mark_variable (GC_word *addr, struct GC_ms_entry *mark_stack_ptr, ...@@ -85,9 +85,12 @@ gp_mark_variable (GC_word *addr, struct GC_ms_entry *mark_stack_ptr,
SCM gp_make_variable() SCM gp_make_variable()
{ {
struct gp_stack *gp = get_gp();
SCM ret = PTR2SCM (GC_generic_malloc (2 * sizeof (scm_t_cell), SCM ret = PTR2SCM (GC_generic_malloc (2 * sizeof (scm_t_cell),
gp_variable_gc_kind)); gp_variable_gc_kind));
SCM tc = SCM_PACK(GP_MK_FRAME_UNBD(gp_type));
SCM tc = SCM_PACK(GP_SETID(GP_MK_FRAME_UNBD(gp_type), gp->id));
SCM_SET_CELL_WORD_1 (ret, SCM_UNBOUND); SCM_SET_CELL_WORD_1 (ret, SCM_UNBOUND);
SCM_SET_CELL_WORD_0 (ret, tc); SCM_SET_CELL_WORD_0 (ret, tc);
......
...@@ -5,6 +5,7 @@ ...@@ -5,6 +5,7 @@
#:use-module (logic guile-log iso-prolog) #:use-module (logic guile-log iso-prolog)
#:use-module (logic guile-log prolog swi) #:use-module (logic guile-log prolog swi)
#:use-module (logic guile-log guile-prolog engine) #:use-module (logic guile-log guile-prolog engine)
#:use-module (logic guile-log guile-prolog paralell)
#:use-module (logic guile-log guile-prolog fiber) #:use-module (logic guile-log guile-prolog fiber)
#:use-module (logic guile-log guile-prolog ops) #:use-module (logic guile-log guile-prolog ops)
#:use-module (logic guile-log guile-prolog set) #:use-module (logic guile-log guile-prolog set)
......
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