assoc state enabled for engines

parent 81376539
......@@ -146,6 +146,7 @@
gp-push-engine
gp-peek-engine
gp-combine-engines
gp-combine-state
gp-current-engine-path
))
......
......@@ -12,10 +12,11 @@
(<with-cc> (lambda (s p) (cc-internal s p))
code ...)))
(<define-guile-log-rule> (<pand> (v engine code ...) ...)
(<define-guile-log-rule> (<pand> (v se engine code ...) ...)
(<var> (v ...)
(<let> ((data (list v ...))
(frame (<newframe>))
(se #f) ...
(p P)
(cc CC))
(<code> (gp-combine-engines data))
......@@ -27,13 +28,14 @@
(<with-s> (gp-push-engine frame engine)
(<set> v (gp-peek-engine))
code ...
(<code> (set! se S))
(<code> (gp-pop-engine))))))
...
(<with-s> s
(<with-s> (gp-combine-state s (list se ...))
(<with-fail> p <cc>))))))
(<define-guile-log-rule> (<pzip> (v p code ...) ...)
(<define-guile-log-rule> (<pzip> (v p se code ...) ...)
(<var> (p ...)
(<let*> ((l '())
(pwork
......@@ -50,7 +52,7 @@
(lambda ()
(set! l (list (<lookup> p) ...))
(pwork #f))))
(<pand> (v (gp-make-engine 100) code ... (<set> p P)) ...)
(<pand> (v se (gp-make-engine 100) code ... (<set> p P)) ...)
(ccwork)
(<with-fail> pend <cc>))))
......@@ -61,10 +63,10 @@
(<or> (<=> x i) (lp (+ i 1))))))
(<define> (test1 x y)
(<pzip> (v1 p1 (f x 3)) (v2 p2 (f y 3))))
(<pzip> (v1 p1 s1 (f x 3)) (v2 p2 s2 (f y 3))))
(<define> (test2 x y)
(<pzip> (v1 p1 (<member> 1 x)) (v2 p2 (<member> 2 y))))
(<pzip> (v1 p1 s1 (<member> 1 x)) (v2 p2 s2 (<member> 2 y))))
......@@ -125,7 +125,7 @@ inline void gp_gc_inc(struct gp_stack *gp)
(Ns > Nf ? Ns : Nf)) :
((Nc > N) ? (Ns > Nc ? Ns : Nc) : (Ns > N ? Ns : N));
if(N < 10000) return;
if(N < 20000) return;
gp_gc_counter++;
if (n > 1000)
......
......@@ -48,9 +48,9 @@ inline SCM get_l(SCM l)
return SCM_CAR(l);
}
inline SCM logical_lookup(SCM x, SCM 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)
{
SCM s = get_l(l);
/*
{
//new tree code here
......@@ -63,11 +63,19 @@ inline SCM logical_lookup(SCM x, SCM l)
goto retry_tree;
}
*/
gp_debug0("logiacal cons lookup\n");
gp_debug0("logical cons lookup\n");
if(!GP(x))
return x;
{
return x;
}
retry:
if(scm_is_eq(l, rest))
{
return x;
}
if(SCM_CONSP(l))
{
SCM car = SCM_CAR(l);
......@@ -75,14 +83,19 @@ inline SCM logical_lookup(SCM x, SCM l)
{
if(scm_is_eq(SCM_CAR(car),x))
{
x = SCM_CDR(car);
SCM y = SCM_CDR(car);
if(!GP(x))
return x;
{
if(refp)
return x;
else
return y;
}
if(!GP_UNBOUND(GP_GETREF(x)))
return x;
l = s;
goto retry;
return x;
}
else
{
......@@ -90,229 +103,203 @@ inline SCM logical_lookup(SCM x, SCM l)
goto retry;
}
}
else
scm_misc_error("logical_lookup","malformed assoc",SCM_EOL);
}
return x;
}
inline SCM logical_lookup2(SCM x, SCM l)
{
/*
{
//new tree code here
retry_tree:
if(!GP_STAR(x))
scm_misc_error("logical_lookup2","expected a logical variable",SCM_EOL);
SCM hash = get_gp_key(GP_GETREF(x));
SCM y = gp_tree_lookup(s,hash,x);
if(scm_is_eq(x,y)) return y;
if(!GP_STAR(y)) return x;
x = y;
goto retry_tree;
}
*/
SCM s = get_l(l);
retry:
if(!GP(x))
return x;
if(SCM_CONSP(l))
{
SCM car = SCM_CAR(l);
if(SCM_CONSP(car))
else if (vlist_p(car))
{
if(scm_is_eq(SCM_CAR(car),x))
SCM y = logical_lookup3_(x, car, rest, refp);
if(scm_is_eq(x,y))
{
SCM y = SCM_CDR(car);
if(!GP(y))
return x;
x = y;
l = s;
l = SCM_CDR(l);
goto retry;
}
else
return y;
}
else if (SCM_I_IS_VECTOR(car))
{
SCM list_of_engines = SCM_SIMPLE_VECTOR_REF(car,0);
SCM rest = SCM_CDR(l);
recur:
if(!SCM_CONSP(list_of_engines))
{
l = SCM_CDR(l);
goto retry;
return x;
}
SCM engine = SCM_CAR(list_of_engines);
if(scm_is_eq(engine, rest))
return x;
SCM y = logical_lookup3_(x, engine, rest, refp);
if(scm_is_eq(x,y))
{
list_of_engines = SCM_CDR(list_of_engines);
goto recur;
}
return y;
}
else
scm_misc_error("logical_lookup","malformed assoc",SCM_EOL);
}
return x;
}
inline SCM logical_lookup3(SCM x, SCM l)
{
l = get_l(l);
inline SCM logical_lookup3_(SCM x, SCM l, SCM rest, int refp)
{
if(!GP(x))
return x;
if(SCM_NULLP(l))
return x;
if(SCM_CONSP(l))
return logical_lookup(x,l);
SCM v;
retry:
{
return x;
}
gp_debug0("logical3\n");
if(!vlist_p(l))
scm_misc_error("lookup",
"nota vlist: ~a",
scm_list_1(l));
if(scm_is_eq(l,rest))
{
return x;
}
v = vhash_assq_unify(x,l);
if(!scm_is_eq(v, SCM_UNSPECIFIED))
if(SCM_NULLP(l))
{
if(!GP(v))
return v;
x = v;
if(GP_UNBOUND(GP_GETREF(x)))
goto retry;
return x;
}
return x;
}
inline SCM logical_lookup_l(SCM x, SCM *l)
{
l = GP_GETREF(get_l(*l));
if(SCM_CONSP(l))
{
return logical_lookup(x,l,rest,refp);
}
gp_debug0("logiacl l lookup\n");
if(!GP(x))
return x;
{
SCM v;
gp_debug0("logical3\n");
if(!vlist_p(l))
scm_misc_error("lookup",
"nota vlist: ~a",
scm_list_1(l));
v = vhash_assq_unify(x,l);
if(!scm_is_eq(v, SCM_UNSPECIFIED))
{
if(!GP(v))
{
if(refp)
{
return x;
}
}
return v;
}
if(SCM_NULLP(*l))
return x;
if(SCM_CONSP(*l))
return logical_lookup(x,*l);
SCM v;
retry:
if(GP_ATTR(GP_GETREF(x)))
return x;
}
}
gp_format2("lookup ~a in ~a~%",x,l[0]);
v = vhash_assq_l(x, l, GP_GETREF(l[1]), SCM_UNPACK(l[2]));
if(!scm_is_eq(v, SCM_UNSPECIFIED))
{
gp_format1("looked l up ~a~%",v);
if(!GP(v))
return v;
x = v;
if(GP_UNBOUND(GP_GETREF(x)))
goto retry;
}
inline SCM logical_lookup_all(SCM x, SCM l, int refp)
{
recur:
{
SCM y = logical_lookup3_(x,l, SCM_EOL, refp);
if(GP(y) && GP_UNBOUND(GP_GETREF(y)) && !scm_is_eq(x,y))
{
x = y;
goto recur;
}
else
return y;
}
gp_debug0("leave lookup\n");
return x;
}
inline SCM logical_lookup4(SCM x, SCM l)
inline SCM logical_lookup_l(SCM x, SCM *l)
{
l = get_l(l);
SCM ll = GP_UNREF(l);
return logical_lookup_all(x,ll,0);
}
if(!GP(x))
return x;
if(SCM_NULLP(l))
return x;
inline SCM logical_lookup3(SCM x, SCM l)
{
return logical_lookup_all(x,l,0);
}
if(SCM_CONSP(l))
return logical_lookup2(x,l);
inline SCM logical_lookup4(SCM x, SCM l)
{
return logical_lookup_all(x,l,1);
}
SCM v;
retry:
SCM wrap(SCM l, SCM x)
{
return x;
}
v = vhash_assq_unify(x,l);
if(!scm_is_eq(v, SCM_UNSPECIFIED))
SCM logical_add2__(SCM x, SCM v, SCM l)
{
int n;SCM pt;
for(n = 0,pt = l;SCM_CONSP(pt);pt = SCM_CDR(pt),n++);
if(n >= 10)
{
if(!GP(v))
return x;
x = v;
if(GP_UNBOUND(GP_GETREF(x)))
goto retry;
SCM val = scm_fluid_ref(init_block_size);
scm_fluid_set_x(init_block_size, scm_from_int(128));
for(pt = scm_reverse(l),l = vlist_null;SCM_CONSP(pt);pt = SCM_CDR(pt))
{
SCM ptx = SCM_CAR(pt);
l = vhash_consq_unify(SCM_CAR(ptx), SCM_CDR(ptx), l);
}
l = vhash_consq_unify(x, v, l);
scm_fluid_set_x(init_block_size, val);
return l;
}
return x;
else
return scm_cons(scm_cons(x,v),l);
}
SCM inline logical_add(SCM x, SCM v, SCM ll)
SCM logical_add2_(SCM x, SCM v, SCM l)
{
SCM l = get_l(ll);
/*
{
//new tree code comes in here
if(!SCM_CONSP(s))
scm_misc_error("logical_add","malformed s",SCM_EOL);
SCM ss = SCM_CDR(s);
SCM hash = get_gp_key(GP_GETREF(x));
return scm_cons(SCM_CAR(s),gp_tree_add(ss,hash,x,v));
}
*/
return scm_cons(scm_cons(scm_cons(x,v),l),SCM_CDR(ll));
return vhash_consq_unify(x, v, l);
}
SCM inline logical_add2(SCM x, SCM v, SCM ll)
SCM logical_add2(SCM x, SCM v, SCM ll)
{
if(scm_is_eq(x,v))
return ll;
SCM l = SCM_CAR(ll);
if(SCM_CONSP(l) || SCM_NULLP(l))
if(SCM_CONSP(ll))
{
int n;SCM pt;
for(n = 0,pt = l;SCM_CONSP(pt);pt = SCM_CDR(pt),n++)
;
if(n >= 10)
{
SCM val = scm_fluid_ref(init_block_size);
scm_fluid_set_x(init_block_size, scm_from_int(128));
for(pt = scm_reverse(l),l = vlist_null;SCM_CONSP(pt);pt = SCM_CDR(pt))
{
SCM ptx = SCM_CAR(pt);
l = vhash_consq_unify(SCM_CAR(ptx), SCM_CDR(ptx), l);
}
l = vhash_consq_unify(x, v, l);
scm_fluid_set_x(init_block_size, val);
return scm_cons(l, SCM_CDR(ll));
}
SCM e = SCM_CAR(ll);
if(vlist_p(e))
{
SCM new_vlist = logical_add2_(x, v, e);
return wrap(ll, scm_cons(new_vlist, SCM_CDR(ll)));
}
else if (SCM_I_IS_VECTOR(e))
{
SCM new_vlist = logical_add2_(x, v, vlist_null);
return wrap(ll, scm_cons(new_vlist, ll));
}
else
return scm_cons(scm_cons(scm_cons(x,v),l),SCM_CDR(ll));
return wrap(ll, logical_add2__(x, v, ll));
}
return scm_cons(vhash_consq_unify(x, v, l), SCM_CDR(ll));
if(SCM_NULLP(ll))
return wrap(ll, logical_add2__(x, v, ll));
else
return wrap(ll, logical_add2_(x, v, ll));
}
SCM inline logical_add2_l(SCM x, SCM v, SCM *ll)
SCM inline wrap_l(SCM *l, SCM val)
{
if(scm_is_eq(x,v))
return SCM_BOOL_T;
SCM *l = &(SCM_CAR(*ll));
l[0] = val;
return SCM_BOOL_T;
}
SCM inline logical_add2_l__(SCM x, SCM v, SCM *l)
{
if(SCM_CONSP(*l) || SCM_NULLP(*l))
{
int n;SCM pt;
SCM ll = *l;
SCM ll = l[0];
for(n = 0,pt = ll;SCM_CONSP(pt);pt = SCM_CDR(pt),n++)
;
......@@ -342,11 +329,46 @@ SCM inline logical_add2_l(SCM x, SCM v, SCM *ll)
}
return SCM_BOOL_T;
}
return SCM_BOOL_T;
}
SCM inline logical_add2_l_(SCM x, SCM v, SCM *l)
{
vhash_consq_l(x, v, l);
return SCM_BOOL_T;
}
SCM inline logical_add2_l(SCM x, SCM v, SCM *l)
{
if(scm_is_eq(x,v))
return SCM_BOOL_T;
SCM ll = l[0];
if(SCM_CONSP(ll))
{
SCM e = SCM_CAR(ll);
if(vlist_p(e))
{
SCM new_vlist = logical_add2_(x, v, e);
return wrap_l(l, scm_cons(new_vlist, SCM_CDR(ll)));
}
else if (SCM_I_IS_VECTOR(e))
{
SCM new_vlist = logical_add2_(x, v, vlist_null);
return wrap_l(l, scm_cons(new_vlist, ll));
}
else
return wrap_l(l, logical_add2_l__(x, v, l));
}
if(SCM_NULLP(ll))
return logical_add2_l__(x, v, l);
else
return logical_add2_l_(x, v, l);
}
SCM_DEFINE(gp_guard_vars, "gp-guard-vars",1,0,0, (SCM s), "")
#define FUNC_NAME s_gp_guards_vars
{
......
......@@ -1619,6 +1619,42 @@ SCM_DEFINE(gp_combine_engines, "gp-combine-engines", 1, 0, 0, (SCM l),
}
#undef FUNC_NAME
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 ll = SCM_EOL;
while(SCM_CONSP(l))
{
SCM sx = SCM_CAR(l);
SCM e = SCM_CAR(gp_gp_cdr(sx,sx));
if(!scm_is_eq(e,l0))
{
ll = scm_cons(e, ll);
l = SCM_CDR(l);
}
}
SCM sout;
if(SCM_CONSP(ll))
{
ll = scm_reverse(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)));
}
else
sout = s;
return sout;
}
#undef FUNC_NAME
SCM_DEFINE(gp_get_current_engine_path, "gp-current-engine-path", 0, 0, 0, (),
"marks a variable as permanent and hence will be removed from stacks")
#define FUNC_NAME s_gp_get_current_engine_path
......
......@@ -165,6 +165,7 @@ SCM_API SCM gp_push_engine(SCM s, SCM engine);
SCM_API SCM gp_pop_engine();
SCM_API SCM gp_peek_engine();
SCM_API SCM gp_combine_engines(SCM l);
SCM_API SCM gp_combine_state(SCM s, SCM l);
SCM_API SCM gp_get_current_engine_path();
SCM_API SCM gp_set_struct(SCM a, SCM b);
SCM_API SCM gp_make_struct(SCM a, SCM b);
......
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