type inheritance indexing and matching works

parent 0ae10de4
......@@ -315,8 +315,12 @@ add/run * vlist *
(((? set-tag? x) a b c)
(let ((a (compile-inh s a theory))
(c (compile-inh s c theory))
(tree (assoc=>tree theory (car b))))
(list x a (cons (car b) tree) c)))
(tree (assoc=>tree theory (car b)))
(all (let lp ((l (car b)) (ff 0))
(if (pair? l)
(lp (cdr l) (logior ff (cdar l)))
ff))))
(list x a (cons (car b) tree) c all)))
((x . l)
(let ((xx (compile-inh s x theory))
(ll (compile-inh s l theory)))
......@@ -1009,13 +1013,13 @@ add/run * vlist *
indexer (mk-get-set! set)))
d
(make-indexer))))
(set! set (pk 'set (compile-set-representation (pk 'set0 set))))
(set! set (compile-set-representation set))
(vector
(get-tag e)
d
(dynlist->vlist (get-ar e) d)
(pk 'dyn (compile-inh s (pk 'dyn0 dyn) set))
(pk 'the set))))
(compile-inh s dyn set)
set)))
(define (compile-index s)
(let ((e (fluid-ref env)))
......@@ -1368,7 +1372,7 @@ add/run * vlist *
((_ s 'x 'l)
(ck s '(x . l)))))
(define (pkk x) (pk 'pkk (syntax->datum x)) x)
(define (pkk x) #;(pk 'pkk (syntax->datum x)) x)
(define parse-list
(lambda (x)
(pkk
......
......@@ -96,6 +96,7 @@ This is prepared to make it functional, but currently we mutate
(hash-set! (get-i->sups x) k v))
(define-inlinable (get-i ->i i) (hash-ref ->i i #f))
(define-inlinable (get-0 ->i i) (hash-ref ->i i 0))
(define-inlinable (get-list ->i i) (hash-ref ->i i '()))
(define-inlinable (update ->i i v) (begin (hash-set! ->i i v) ->i))
......@@ -297,8 +298,13 @@ a natural generational mapping to help in constructing a match tree.
new)))
(let ((leafs (find-leafs)))
(define (init ->)
(let lp ((l (bits-to-is leafs)) (-> ->))
(if (pair? l)
(lp (cdr l) (update -> (car l) (car l)))
->)))
(let lp ((new leafs) (subs leafs)
(i->subs i->subs) (i->sups i->sups))
(i->subs (init i->subs)) (i->sups (init i->sups)))
(if (not (= new 0))
(let lp2 ((l (bits-to-is new))
(i->subs i->subs) (i->sups i->sups))
......@@ -399,9 +405,9 @@ a natural generational mapping to help in constructing a match tree.
(begin
(set! new-theory (register-new new-downbits))
(let ((newcoms (find-all-newcombers downbits new-downbits)))
(lp (logior newcoms leafs) newcoms))))))
(lp (logior newcoms downbits) newcoms))))))
(let ((s (get-set new-theory))
(let ((s (get-set new-theory))
(i->j (get-i->j new-theory))
(j->subs (get-i->subs new-theory))
(j->sups (get-i->sups new-theory))
......@@ -453,9 +459,9 @@ a natural generational mapping to help in constructing a match tree.
(i->j (get-i->j theory)))
(let lp ((a a) (i->f (make-hash-table)))
(if (pair? a)
(lp (cdr a) (update i->f
(get-i i->j (get-i set->i (caar a)))
(cdar a)))
(let ((key (get-i i->j (caar a))))
(lp (cdr a) (update i->f key
(logior (cdar a) (get-0 i->f key)))))
(mktree theory i->f)))))
(define mktree
......@@ -493,10 +499,10 @@ a natural generational mapping to help in constructing a match tree.
(x (list x)))))
(define (p x)
(pk (map (lambda (x) (reverse-lookup theory x)) x))
(pk 'revlockup (map (lambda (x) (reverse-lookup theory x)) x))
x)
(define setlist (p (linearize (mktree1 setbits))))
(define setlist (linearize (mktree1 setbits)))
(define comb (inh-comb i->f))
(define tree
......
......@@ -37,11 +37,10 @@
(<define> (analyze in goal)
(<values> (in) (analyze-type in))
(<pp> in)
(<values> (in.goal extra) (duplicate-term-3 (cons in goal)))
(<let> ((in (car in.goal))
(goal (cdr in.goal)))
(<cc> in (let lp ((l extra))
(if (pair? l)
(vector (list #{,}# (pk (car l)) (lp (cdr l))))
(vector (list #{,}# (car l) (lp (cdr l))))
goal)))))
......@@ -610,37 +610,38 @@ void get_index_set_0(SCM s, SCM e, SCM db_, int *n, ulong *data, int isPlus, SCM
}
set_tag:
{
printf("set-tag\n");
{
{
int i;
n2 = *n;
for(i = 0; i < *n; i++)
{
data2[i] = data[i];
}
}
if(scm_is_true(gp_att_rawvar(e,s)))
{
SCM adata = gp_get_attr(e, gp_type_attribute_tag, s);
adata = gp_gp_lookup(adata, s);
//data = (set . args)
printf("a\n");
if(scm_is_true(adata))
{
SCM set = SCM_CAR(adata);
SCM args = SCM_CDR(adata);
printf("b\n");
db = dB(db_);
if(SCM_CONSP(db_))
{
SCM tree = SCM_CDR(SCM_CADDR(db_));
format1("trset ~a~%", trset);
format1("tree ~a~%", tree);
format1("adata ~a~%", adata);
SCM bits = get_bits_from_set(set, trset);
format1("bits ~a~%", bits);
SCM v = get_set(tree, bits);
if(SCM_I_INUMP (v))
{
ulong nv = my_scm_to_ulong(v);
data[0] = *n ? data[0] & nv : nv;
*n = MAX(1, *n);
data2[0] = (n2 == 0 ? nv : nv & data2[0]);
n2 = MAX(1, n2);
}
else
{
......@@ -649,27 +650,78 @@ void get_index_set_0(SCM s, SCM e, SCM db_, int *n, ulong *data, int isPlus, SCM
int n3 = (*mpv)->_mp_size;
ulong *data3 = (*mpv)->_mp_d;
if(*n)
if(n2)
{
*n = MIN(n3,*n);
for(i = 0; i < *n; i++)
data[i] = data[i] & data3[i];
n2 = MIN(n3,n2);
for(i = 0; i < n2; i++)
data2[i] = data2[i] & data3[i];
}
else
{
*n = n3;
for(i = 0; i < *n; i++)
data[i] = data3[i];
n2 = n3;
for(i = 0; i < n2; i++)
data2[i] = data3[i];
}
}
db_ = SCM_CADDDR(db_);
e = args;
goto redo;
SCM db2 = SCM_CADDDR(db_);
get_index_set_0(s, args, db2, &n2, data2, isPlus, trset);
}
}
}
else
{
SCM v = SCM_CADR(SCM_CDDDR(db_));
if(SCM_I_INUMP (v))
{
ulong nv = my_scm_to_ulong(v);
data2[0] = (n2 == 0 ? nv : nv & data2[0]);
n2 = MAX(1, n2);
}
else
{
int i;
mpz_t *mpv = &(SCM_I_BIG_MPZ(v));
int n3 = (*mpv)->_mp_size;
ulong *data3 = (*mpv)->_mp_d;
if(*n)
{
n2 = MIN(n3,n2);
for(i = 0; i < n2; i++)
data2[i] = data2[i] & data3[i];
}
else
{
n2 = n3;
for(i = 0; i < n2; i++)
data2[i] = data3[i];
}
}
}
db_ = SCM_CADR(db_); goto redo;
db_ = SCM_CADR(db_);
get_index_set_0(s, e, db_, n, data, isPlus, trset);
{
int i;
if(n2 < *n)
{
for(i = 0; i < n2; i++)
data[i] = data[i] | data2[i];
}
else
{
for(i = 0; i < *n; i++)
data[i] = data[i] | data2[i];
for(; i < n2; i++)
data[i] = data2[i];
*n = n2;
}
}
return;
}
plus_tag:
......@@ -851,7 +903,6 @@ SCM_DEFINE(scm_get_index_set, "get-index-set", 4, 0, 0,
(SCM s, SCM e, SCM db, SCM trset), "")
#define FUNC_NAME s_scm_get_index_set
{
format1("in trset ~a~%",trset);
if(!scm_is_false(trset))
{
SCM parent = scm_c_vector_ref(trset , 7);
......
......@@ -17,34 +17,26 @@ SCM get_bits_from_set(SCM set, SCM v)
j_to_inh = scm_c_vector_ref(v, 3);
i_to_inh = scm_c_vector_ref(v, 4);
printf("1\n");
if(scm_is_false(set_to_i)) return scm_from_int(0);
i = scm_hash_ref(set_to_i, set, SCM_BOOL_F);
printf("2\n");
if(scm_is_false(i)) return scm_from_int(0);
if(scm_is_false(scm_eqv_p(scm_logand(i, mask), scm_from_int(0))))
{ //We have a direct mask
SCM j = scm_hash_ref(i_to_j, i, SCM_BOOL_F);
printf("3\n");
if(scm_is_false(j)) return scm_from_int(0);
format1("j = ~a~%",j);
printf("4\n");
return scm_hash_ref(j_to_inh, j, scm_from_int(0));
}
printf("5\n");
bits = scm_hash_ref(i_to_inh, i, SCM_BOOL_F);
if(scm_is_false(bits)) return scm_from_int(0);
printf("6\n");
outbits = scm_from_int(0);
bits = scm_logand(mask, bits);
retry:
printf("7\n");
if(scm_is_true(scm_equal_p(scm_from_int(0), bits)))
return outbits;
......
......@@ -2,11 +2,12 @@
#:use-module (logic guile-log)
#:use-module ((logic guile-log umatch)
#:select (gp-attvar-raw? set-attribute-cstor! gp-lookup
gp-make-var gp-get-attr
gp-make-var gp-get-attr gp-var?
gp-attvar?))
#:use-module (logic guile-log inheritance)
#:export (type? type Type))
#:replace (type)
#:export (type? Type))
(<define> (Type data var pred?)
(<let> ((var (<lookup> var)))
......
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