make sure that conflicting bindings fails

parent 426300d9
......@@ -11,16 +11,16 @@
(() <fail>)
((x) (goal-eval x))
((x y)
(<pand>
(<pand> fail
(p1 s1 (gp-make-engine 100) (goal-eval x))
(p2 s2 (gp-make-engine 100) (goal-eval y))))
((x y u)
(<pand>
(<pand> fail
(p1 s1 (gp-make-engine 100) (goal-eval x))
(p2 s2 (gp-make-engine 100) (goal-eval y))
(p3 s3 (gp-make-engine 100) (goal-eval u))))
((x y u v)
(<pand>
(<pand> fail
(p1 s1 (gp-make-engine 100) (goal-eval x))
(p2 s2 (gp-make-engine 100) (goal-eval y))
(p3 s3 (gp-make-engine 100) (goal-eval u))
......@@ -30,7 +30,7 @@
(if (= n 0)
(cons l u)
(lp (cdr l) (cons (car l) u) (- n 1))))))
(<pand>
(<pand> fail
(p1 s1 (gp-make-engine 100) (<apply> paralell (car l-u)))
(p3 s3 (gp-make-engine 100) (<apply> paralell (cdr l-u))))))))
......
......@@ -16,7 +16,17 @@
(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 ...)
(<let> ((data (list v ...))
(frame (<newframe>))
......@@ -34,7 +44,6 @@
(<with-fail> p
(<with-s> (gp-push-engine frame engine)
(<code> (gp-combine-push data))
(state-guard-dynamic-object *cc*)
(<code> (gp-var-set v (gp-peek-engine) S))
code ...
(<code> (set! se S))
......@@ -42,11 +51,13 @@
...
(<code> (gp-combine-engines data))
(<with-s> (gp-combine-state s (list se ...))
(let ((s.bindings (gp-combine-state s (list se ...))))
(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 ...)
(<let*> ((l '())
(pwork
......@@ -59,7 +70,8 @@
(ccwork
(lambda (s pp cc)
(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)
(let ((pend
(lambda ()
......
......@@ -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->_thread_safe_ = 1;
gp->id = id;
gp->thread_id = nthread;
gp->nrem = 0;
gp->n = 0;
......@@ -1598,7 +1597,12 @@ SCM_DEFINE(gp_push_engine, "gp-push-engine", 2, 0, 0, (SCM s, SCM e),
gp_debug0("Push Engine>\n");
struct gp_stack *gp = get_gp();
int logical = gp->_logical_;
int level = gp->id;
SCM rguards = gp->rguards;
gp_engine_path = scm_cons(x , gp_engine_path);
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),
gp = get_gp();
gp_clear(SCM_BOOL_F);
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 carss = gp_car(ss,ss);
......@@ -1643,8 +1655,6 @@ SCM_DEFINE(gp_new_engine, "gp-new-engine", 1, 0, 0, (SCM e),
gp_debug0("Push Engine>\n");
gp_engine_path = scm_cons(x , SCM_EOL);
gp_paths = scm_cons(gp_engine_path, SCM_EOL);
......@@ -1737,6 +1747,57 @@ SCM_DEFINE(gp_combine_push, "gp-combine-push", 1, 0, 0, (SCM r),
}
#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),
"")
#define FUNC_NAME s_gp_combine_engine
......@@ -1756,6 +1817,8 @@ SCM_DEFINE(gp_combine_state, "gp-combine-state", 2, 0, 0, (SCM s, SCM l),
l = SCM_CDR(l);
}
SCM ret = get_all_conflicting_bindings(ll);
SCM sout;
if(SCM_CONSP(ll))
......@@ -1769,7 +1832,7 @@ SCM_DEFINE(gp_combine_state, "gp-combine-state", 2, 0, 0, (SCM s, SCM l),
else
sout = s;
return sout;
return scm_cons(sout,ret);
}
#undef FUNC_NAME
......
......@@ -221,7 +221,7 @@ scm_t_bits gp_smob_t;
//#define GP_HASH(x) ((SCM_UNPACK(x) & GPHA) >> H_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_SETCOUNT(X,i) (((SCM_UNPACK(X) & (~GPHA)) \
| ((i) << H_BITS)))
......
......@@ -85,9 +85,12 @@ gp_mark_variable (GC_word *addr, struct GC_ms_entry *mark_stack_ptr,
SCM gp_make_variable()
{
struct gp_stack *gp = get_gp();
SCM ret = PTR2SCM (GC_generic_malloc (2 * sizeof (scm_t_cell),
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_0 (ret, tc);
......
......@@ -5,6 +5,7 @@
#:use-module (logic guile-log iso-prolog)
#:use-module (logic guile-log prolog swi)
#: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 ops)
#: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