most of the kanren variables is working

parent 8f7fb9a7
......@@ -9,7 +9,7 @@
gp-c-system
gp-make-var
gp-budy gp-m-unify!-
gp-lookup ;gp-lookup-clean
gp-lookup
gp-var? gp-cons! gp-set!
gp-var-number gp-print-stack
gp-car gp-cdr gp-pair? gp-pair* gp-pair- gp-pair+
......
This diff is collapsed.
......@@ -58,7 +58,7 @@ inline SCM logical_lookup(SCM x, SCM l)
goto retry_tree;
}
*/
gp_debug0("logiacal cons lookup\n");
if(!GP(x))
return x;
......@@ -160,6 +160,7 @@ inline SCM logical_lookup3(SCM x, SCM l)
SCM v;
retry:
gp_debug0("logical3\n");
v = vhash_assq_unify(x,l);
if(!scm_is_eq(v, SCM_UNSPECIFIED))
......@@ -175,6 +176,7 @@ inline SCM logical_lookup3(SCM x, SCM l)
inline SCM logical_lookup_l(SCM x, SCM *l)
{
gp_debug0("logiacl l lookup\n");
if(!GP(x))
return x;
......@@ -187,16 +189,21 @@ inline SCM logical_lookup_l(SCM x, SCM *l)
SCM v;
retry:
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;
return v;
if(GP_ATTR(GP_GETREF(v)))
return v;
x = v;
if(GP_UNBOUND(GP_GETREF(x)))
goto retry;
}
gp_debug0("leave lookup\n");
return x;
}
......@@ -240,8 +247,6 @@ SCM inline logical_add(SCM x, SCM v, SCM l)
}
*/
if(GP(v)) CPLX_TOUCH(GP_GETREF(v));
return scm_cons(scm_cons(x,v),l);
}
......@@ -249,8 +254,6 @@ SCM inline logical_add2(SCM x, SCM v, SCM l)
{
if(scm_is_eq(x,v))
return l;
if(GP(v)) CPLX_TOUCH(GP_GETREF(v));
if(SCM_CONSP(l) || SCM_NULLP(l))
{
......@@ -285,8 +288,6 @@ SCM inline logical_add2_l(SCM x, SCM v, SCM *l)
if(scm_is_eq(x,v))
return SCM_BOOL_T;
if(GP(v)) CPLX_TOUCH(GP_GETREF(v));
if(SCM_CONSP(*l) || SCM_NULLP(*l))
{
int n;SCM pt;
......
......@@ -78,12 +78,18 @@ SCM closure_tag;
DB(scm_simple_format(SCM_BOOL_T, \
scm_from_locale_string(str), \
scm_list_3(x,y,z)))
#define gp_format4(str,x,y,z,w) \
DB(scm_simple_format(SCM_BOOL_T, \
scm_from_locale_string(str), \
scm_list_4(x,y,z,w)))
#define format0(str) \
(scm_simple_format(SCM_BOOL_T, \
scm_from_locale_string(str), \
SCM_EOL))
#define format1(str,x) \
#define format1(str,x) \
(scm_simple_format(SCM_BOOL_T, \
scm_from_locale_string(str), \
scm_list_1(x)))
......@@ -100,7 +106,7 @@ SCM closure_tag;
#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))
......@@ -258,18 +264,6 @@ static SCM* UN_GP(SCM scm)
return GP_GETREF(scm);
}
inline static void CPLX_TOUCH(SCM *id)
{
scm_t_bits val = SCM_UNPACK(id[0]);
id[0] = SCM_PACK(val | GPI_TOUCH);
}
inline static int IS_CPLX(SCM *id)
{
scm_t_bits val = SCM_UNPACK(id[0]);
return val & GPI_TOUCH;
}
SCM gp_unbound_sym;
SCM gp_unbound_str;
SCM gp_unwind_fluid;
......@@ -417,7 +411,6 @@ static inline void gp_store_var_2(SCM *id, int simple, struct gp_stack *gp)
}
else
{
CPLX_TOUCH(id);
*(gp->gp_ci) = scm_cons(GP_UNREF(id), scm_cons(SCM_I_MAKINUM(id[0]),
id[1]));
}
......@@ -609,8 +602,6 @@ static inline SCM gp_set_ref(SCM *id, SCM ref, SCM l, struct gp_stack *gp)
SCM flags;
if(!GP(ref)) return gp_set_val(id,ref,l,gp);
CPLX_TOUCH(GP_GETREF(id));
flags = SCM_PACK(GP_MK_FRAME_PTR(gp_type));
return handle(id, flags, ref, l, gp, 0, 0);
......@@ -621,8 +612,6 @@ static inline SCM gp_set_ref_l(SCM *id, SCM ref, SCM *l, struct gp_stack *gp)
SCM flags;
if(!GP(ref)) return gp_set_val_l(id,ref,l,gp);
CPLX_TOUCH(GP_GETREF(id));
flags = SCM_PACK(GP_MK_FRAME_PTR(gp_type));
return handle_l(id, flags, ref, l, gp, 0, 0);
......@@ -690,15 +679,20 @@ static inline SCM gp_set_unbound_bang(SCM *id, SCM l, struct gp_stack *gp)
do { \
if(SCM_UNLIKELY(!scm_is_eq(*l,SCM_EOL))) \
{ \
gp_debug0("l 1\n"); \
i1 = gp_lookup_ll(i2,l); \
} \
else if(GP_STAR(i2)) \
{ \
while(GP_STAR(i2) && GP_POINTER(i2)) \
i2 = GP_GETREF(GP_SCM(i2)); \
{ \
gp_debug0("l 2\n"); \
i2 = GP_GETREF(GP_SCM(i2)); \
} \
} \
else if (SCM_VARIABLEP(GP_UNREF(i2))) \
{ \
gp_debug0("l 3\n"); \
i1 = GP_GETREF(SCM_VARIABLE_REF(GP_UNREF(i2))); \
} \
} while(0)
......@@ -730,6 +724,7 @@ static inline SCM * gp_lookup(SCM *id, SCM l)
advanced:
gp_debug0("lookup> advanced\n");
id = GP_GETREF(logical_lookup3(GP_UNREF(id),l));
gp_debug0("lookup> /2\n");
......@@ -822,6 +817,7 @@ static inline SCM * gp_lookup_ll(SCM *id, SCM *l)
retry:
if(SCM_VARIABLEP(GP_UNREF(id)))
{
gp_debug0("variable\n");
id = GP_GETREF(SCM_VARIABLE_REF(GP_UNREF(id)));
goto retry;
}
......@@ -831,6 +827,7 @@ static inline SCM * gp_lookup_ll(SCM *id, SCM *l)
if(GP_STAR(id) && GP_POINTER(id))
{
gp_debug0("pointer\n");
id = GP_GETREF(GP_SCM(id));
goto retry;
}
......@@ -842,6 +839,7 @@ static inline SCM * gp_lookup_ll(SCM *id, SCM *l)
advanced:
gp_debug0("lookup> /1\n");
id = GP_GETREF(logical_lookup_l(GP_UNREF(id),l));
gp_debug0("lookup> /2\n");
......@@ -1376,8 +1374,10 @@ static SCM gp_unify(SCM *id1, SCM *id2, int raw, int gp_plus_unify, SCM *l, stru
gp_lookup_l(id2,id2,l);
gp_lookup_l(id1,id1,l);
if(GP_ATTR(id1) && !GP_UNBOUND(id1)) goto retry_attr;
if(GP_ATTR(id2) && !GP_UNBOUND(id2)) goto retry_attr_rev;
if(GP_STAR(id1) && GP_ATTR(id1) && !GP_UNBOUND(id1))
goto retry_attr;
if(GP_STAR(id2) && GP_ATTR(id2) && !GP_UNBOUND(id2))
goto retry_attr_rev;
if(! (GP_STAR(id1) && GP_STAR(id2))) goto retry;
......@@ -2138,6 +2138,7 @@ int _gp_unify(SCM **spp, int nargs, SCM *cl, SCM *max)
SCM ci, *sp, s,v1,v2,*vv1, *vv2, ret, l[3], ggp, old, oldi;
struct gp_stack *gp;
gp_debug0("unify\n");
sp = *spp;
s = sp[0];
v2 = sp[-1];
......@@ -2187,9 +2188,11 @@ SCM_DEFINE(gp_gp_unify,"gp-unify!",3,0,0,(SCM v1, SCM v2, SCM s),
{
SCM ci, *vv1, *vv2, ret, l[3], ggp, old, oldi;
struct gp_stack *gp;
UNPACK_ALL(ci, (l[0]),ggp,gp,s,"failed to unpack in gp_gp_unify");
gp_debus0("gp-unify!>\n");
UNPACK_ALL(ci, (l[0]),ggp,gp,s,"failed to unpack in gp_gp_unify");
vv1 = UN_GP(v1);
vv2 = UN_GP(v2);
old = l[0];
......@@ -2229,6 +2232,7 @@ int _gp_unify_raw(SCM **spp, int nargs, SCM *cl, SCM *max)
v2 = sp[-1];
v1 = sp[-2];
gp_debus0("gp-unify _raw!>\n");
if(SCM_UNLIKELY(nargs != 3))
scm_misc_error("gp-unify-raw!","wrong number of arguments", SCM_EOL);
......@@ -2273,9 +2277,10 @@ SCM_DEFINE(gp_gp_unify_raw,"gp-unify-raw!",3,0,0,(SCM v1, SCM v2, SCM s),
{
SCM ci,*vv1, *vv2, ret, l[3], ggp, old, oldi;
struct gp_stack *gp;
UNPACK_ALL(ci,l[0],ggp, gp,s,"failed to unpack in gp_gp_unify_raw");
gp_debus0("gp-unify-raw!>\n");
UNPACK_ALL(ci,l[0],ggp, gp,s,"failed to unpack in gp_gp_unify_raw");
old = l[0];
vv1 = UN_GP(v1);
......@@ -2775,9 +2780,11 @@ SCM_DEFINE(gp_null_bang, "gp-null!?", 2, 0, 0, (SCM x, SCM s),
SCM * y,l,ggp,ret,ci;
struct gp_stack *gp;
UNPACK_ALL(ci,l,ggp,gp,s,"failed to unpack s in gp_null_bang");
gp_debus0("gp-null!?>\n");
UNPACK_ALL(ci,l,ggp,gp,s,"failed to unpack s in gp_null_bang");
retry:
if(GP(x) || SCM_VARIABLEP(x))
x = gp_gp_lookup(x,s);
......@@ -2844,70 +2851,6 @@ SCM_DEFINE(gp_gp_lookup, "gp-lookup", 2, 0, 0, (SCM x, SCM s),
return x;
}
SCM_DEFINE(gp_gp_lookup_clean, "gp-lookup-clean", 2, 0, 0, (SCM x, SCM s),
"lookup a chain from a prolog variable")
#define FUNC_NAME s_gp_gp_null_bang
{
SCM *id,*pt,l,out,ggp;
scm_t_bits ix;
struct gp_stack *gp;
int i;
UNPACK_ALL0(l,ggp,gp,s,"failed to unpack in gp_gp_lookup_clean");
if(GP(x))
{
//printf("lookup> gp\n");
gp_debug0("gp-lookup\n");
id = gp_lookup(GP_GETREF(x),l);
if(!GP_STAR(id))
{
out = GP_UNREF(id);
}
else if(GP_UNBOUND(id) || GP_CONS(id))
{
out = GP_UNREF(id);
}
else
{
out = GP_SCM(id);
}
//printf("test cplx\n");
ix = (scm_t_bits) GP_GETREF(x);
if(!IS_CPLX(id))
{
//printf("not cplx\n");
for(pt = gp->gp_ci - 1, i = 0 ;
i < 10 &&
pt >= gp->gp_cstack &&
(GP(*pt) || (2 | SCM_UNPACK(*pt))) ;
pt--,i++)
{
scm_t_bits ipt = SCM_UNPACK(*pt);
//printf("%d\n",i);
if (ipt == ix)
{
for(;pt<gp->gp_ci - 1;pt++)
{
pt[0] = pt[1];
}
gp->gp_ci--;
return scm_values(scm_list_2(out,s));
}
}
{
if(SCM_CONSP(l))
if(SCM_CAAR(l) == x)
return
scm_values(
scm_list_2(out,
scm_cons(ggp, SCM_CDR(l))));
}
}
}
//printf("lookup> scm\n");
return scm_values(scm_list_2(x,s));
}
#undef FUNC_NAME
int _gp_m_unify(SCM **spp, int nargs, SCM *cl, SCM *max)
......@@ -2954,6 +2897,7 @@ SCM_DEFINE(gp_m_unify, "gp-m-unify!", 3, 0, 0, (SCM x, SCM y, SCM s),
{
SCM ret, l[3], ggp, ci;
struct gp_stack *gp;
gp_debus0("gp-unify-m!>\n");
UNPACK_ALL(ci,l[0],ggp,gp,s,"failed to unpack in gp_m_unify");
if(vlist_p(l[0]))
{
......
......@@ -52,7 +52,6 @@ SCM_API SCM gp_heap_var();
SCM_API SCM smob2scm(SCM scm, SCM s);
SCM_API SCM gp_gp_unify(SCM scm1, SCM scm2, SCM s);
SCM_API SCM gp_gp_lookup(SCM scm, SCM s);
//SCM_API SCM gp_gp_lookup_clean(SCM x, SCM s);
SCM_API SCM gp_var_number(SCM x, SCM s);
SCM_API SCM gp_soft_init();
......
......@@ -5,7 +5,7 @@
// This code only works on 64 bit systems
void vhash_truncate_x(SCM vhash);
void vhash_block_clear(SCM *base, int offset);
void vhash_block_clear(SCM *base);
#define S(x,n) SCM_STRUCT_SLOT_REF(x,n)
......@@ -19,7 +19,6 @@ do { \
#define ACONS2(ret,k,v,y) \
do { \
printf("%p,%p\n",SCM_UNPACK(k),SCM_UNPACK(v)); \
SCM *pt = (SCM*) alloca(2*sizeof(SCM)); \
pt[0] = scm_cons(k,v); \
pt[1] = y; \
......@@ -38,7 +37,7 @@ do { \
SCM vhash_cache = SCM_BOOL_F;
//TODO fix this on 32bit platforms
#define my_scm_to_int(x) (SCM_UNPACK(x)>>2)
#define my_scm_to_int(x) ((SCM_UNPACK(x)>>2))
#define my_scm_from_int(x) (SCM_PACK((scm_t_bits) (((x) << 2) + 2)))
#define my_scm_to_ulong(x) (SCM_UNPACK(x)>>2)
#define my_scm_from_ulong(x) (SCM_PACK((scm_t_bits) (((x) << 2) + 2)))
......@@ -129,21 +128,17 @@ inline int block_append_s(SCM* block, SCM value, int offset, int hashp)
ulong seq = my_scm_to_ulong(scm_fluid_ref(thread_seq_number));
ulong thr = my_scm_to_ulong(scm_fluid_ref(thread_id));
/*
printf("offset %d block_size %d nextfree %d\n"
, offset , (int) block_size(block), NEXTFREE(nextfree));
*/
if ((offset < block_size(block))
&& (!hashp || (THR(st) == thr && SEQ(os) == seq)) &&
(offset == NEXTFREE(nextfree)))
{
set_block_next_free_s(block, nextfree);
scm_vector_set_x(block_content(block), my_scm_from_int(offset), value);
return 1;
return 1;
}
return 0;
return 0;
}
// Return the item at slot OFFSET.
inline SCM block_ref(SCM *content, int offset)
......@@ -173,7 +168,8 @@ inline void block_hash_table_set_next_offset_s
{
// Mask on a backref in order to be able to truncate the hash
ulong x = COMB_REFS(next_offset, khash);
SCM next_offset_s = my_scm_from_ulong(x);
SCM next_offset_s = my_scm_from_ulong(x);
content[(size*3) + offset] = next_offset_s;
}
......@@ -204,7 +200,7 @@ inline void block_hash_table_add_s
val = -1;
else
val = my_scm_to_int(oldval);
block_hash_table_set_next_offset_s(content, size, offset, khash, val);
block_hash_table_set_s(content, size, khash, offset);
}
......@@ -214,21 +210,21 @@ SCM block_null;
SCM search_cached_block(SCM * cblock);
SCM make_block_l(SCM base, int offset, int size, int hash_tab_p, int *truncable)
{
SCM ret = search_cached_block(dB(base));
if(scm_is_false(ret))
{
*truncable = 0;
SCM ret = make_block(base, offset, size, hash_tab_p);
set_block_next_free_s(dB(base),0UL);
return ret;
}
{
SCM ret = SCM_BOOL_F; //search_cached_block(dB(base));
if(1 || scm_is_false(ret))
{
*truncable = 0;
SCM ret = make_block(base, offset, size, hash_tab_p);
set_block_next_free_s(dB(ret),0UL);
return ret;
}
*truncable = 1;
SCM *elts = SCM_I_VECTOR_WELTS(ret);
vhash_block_clear(elts,0);
vhash_block_clear(elts);
size = block_size(elts);
......@@ -412,7 +408,6 @@ SCM block_cons(SCM item, SCM vlist, int hash_tab_p, int truncp)
ret = make_vlist(Base, 0);
}
return ret;
}
}
......@@ -1003,7 +998,7 @@ void vhash_truncate_x(SCM vhash)
}
}
void vhash_block_clear(SCM *base, int offset)
void vhash_block_clear(SCM *base)
{
SCM *content = dB(block_content(base));
......@@ -1012,17 +1007,13 @@ void vhash_block_clear(SCM *base, int offset)
ulong st = block_size_thr(base);
int size = SIZE(st);
for(--freeref; freeref > offset; freeref--)
for(--freeref; freeref >= 0; freeref--)
{
ulong os = my_scm_to_ulong
(block_hash_table_next_offset(content, size, freeref));
int off = NEXT_REF(os);
int khsh = BACKREF_REF(os);
content[size + freeref] = SCM_BOOL_F;
content[ freeref] = SCM_BOOL_F;
block_hash_table_set_s(content, size, khsh, off);
content[2*size + freeref] = SCM_BOOL_F;
content[size + freeref] = SCM_BOOL_F;
content[ freeref] = SCM_BOOL_F;
}
block_next_free_ref(base) = my_scm_from_int(offset + 1);
block_next_free_ref(base) = my_scm_from_int(0);
}
SCM vhash_cons_adv(SCM key, SCM value, SCM vhash, SCM (*hash)(SCM, SCM),
......@@ -1226,7 +1217,7 @@ void touch_cache_work(SCM vh, SCM cvh, SCM *vh_base, SCM *cvh_base)
{
SCM new_vh = make_vlist(*cvh_base, 0);
vhash_block_clear(cvh_base, 0);
vhash_block_clear(cvh_base);
scm_fluid_set_x(vhash_cache, new_vh);
return;
}
......@@ -1262,6 +1253,9 @@ inline void touch_cache(SCM vh)
SCM cvh = scm_fluid_ref(vhash_cache);
SCM *cvh_base = vlist_base(cvh);
SCM *vh_base = vlist_base(vh);
return;
if(cvh_base == vh_base) return;
touch_cache_work(vh, cvh, vh_base, cvh_base);
......@@ -1537,7 +1531,7 @@ SCM vhash_set_exp_x(SCM key, SCM val, SCM vhash,
offset = NEXT_REF(my_scm_to_ulong(offset_s)); \
\
loop: \
if(offset >= 0) \
if(offset >= 0) \
{ \
SCM key2 = block_ref(content, offset); \
\
......@@ -1589,7 +1583,7 @@ loop: \
offset = NEXT_REF(my_scm_to_ulong(offset_s)); \
\
loop: \
if(offset >= 0) \
if(offset >= 0) \
{ \
SCM key2 = block_ref(content, offset); \
\
......
......@@ -34,7 +34,7 @@
gp-car gp-cdr
gp-print gp?
gp-budy
gp-lookup ;gp-lookup-clean
gp-lookup
gp-var? gp-cons! gp-set!
gp-var-number gp-print-stack
gp-pair? gp-pair!? gp-null? gp-null!?
......
......@@ -10,6 +10,7 @@
(queens3 Ns '() Qs))))
(<define> (queens3 UnplacedQs SafeQs Qs)
;(<pp> 'queens)
(<match> () (UnplacedQs)
( _ (<var> (Q UnplacedQs1)
(<and> (selectq Q UnplacedQs UnplacedQs1)
......@@ -21,6 +22,7 @@
(<define> (attack X Xs) (attack3 X 1 Xs))
(<define> (attack3 X N V)
;(<pp> `(attack3))
(<match> () (V)
((Y . _) (<or> (<when> (eq? (<scm> X) (+ (<scm> Y) N)))
(<when> (eq? (<scm> X) (- (<scm> Y) N)))))
......@@ -28,16 +30,18 @@
(_ <fail>)))
(<define> (range-list M N U)
; (<pp> 'range-list)
(<match> () (U)
((,M) (<when> (>= M N) <cut>))
((,M . L) (range-list (+ M 1) N L))
(_ <fail>)))
(<define> (selectq X U Xs)
; (<pp-dyn> `(sellectq ,S) 'sellectq)
(<match> () (U Xs)
((,X . ,Xs) _ <cc>)
(( Y . Ys) ( Y . Zs) (selectq X Ys Zs))
(_ _ <fail>)))
((,X . ,Xs) _ (<and> <cc>))
(( Y . Ys) ( Y . Zs) (<and> (selectq X Ys Zs)))
(_ _ (<and> <fail>))))
(define (f)
(<run> 3 (Q)
......@@ -128,11 +132,16 @@
(with-test-prefix "guile-log, simple tests"
(pass-if "(<or> (<=> 1 q) (<=> 2 q))"
(equal? '(1 2) (f-or)))
(pass-if "second or example"
(equal? '((a 1 d) (b 2 e)) (f-or-2)))
(pass-if "f-any-1 test of recur"
(equal? '(1 2 3 1 2 3 1 2 3 1) (f-any-1)))
(pass-if "f-alw-1"
(equal? '(#f #f #f #f #f) (f-alw-1)))
(pass-if "map and append test"
(equal? '(((1 2 3 4 5 6 7 8 9)) f-app))))
......@@ -19,7 +19,7 @@
(define (check? x y)
(let ((ret (translate x)))
(format #t "check> ~a == ~a~%" ret y)
(<clear> *current-stack*)
(<clear>)
(equal? ret y)))
......
......@@ -23,12 +23,10 @@
(equal? ret y)))
(define-syntax check?
(syntax-rules ()
((_ x y)
(begin
(pk 'x)
(<clear>)
(pass-if (format #f "~a" 'x)
(equal? x y))))))
......@@ -1436,7 +1434,6 @@
((<=> '(1) n) (poso m) (<=> m p))
((>1o n) (<=> '(1) m) (<=> n p))
((<var> (x z)
(<if> (<==> ((_ . _) . _) m) (<code> (error "bail out *o10")) <cc>)
(<=> (0 . x) n) (poso x)
(<=> (0 . z) p) (poso z)
(>1o m)
......
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