new set inheretance comiles and runs without beeing active

parent 9f24d1ca
......@@ -48,6 +48,7 @@ PSSOURCES = \
logic/guile-log/grep.scm \
logic/guile-log/dynlist.scm \
logic/guile-log/inheritance.scm \
logic/guile-log/type.scm \
logic/guile-log/postpone.scm \
logic/guile-log/util.scm \
logic/guile-log/functional-database.scm \
......
This diff is collapsed.
......@@ -11,9 +11,13 @@
compile-sup-sub
compile-set-representation
mktree
find-matching-sets
find-matching-setsx
get-translation-data
order-the-set
inh-comb
mk-get-set
mk-get-set!
set<
))
;; Syntax helpers
......@@ -111,6 +115,22 @@ This is prepared to make it functional, but currently we mutate
(define *current-set-theory* (make-fluid (make-set-theory)))
(define (get-current-set-theory) (fluid-ref *current-set-theory*))
(define-syntax-rule (mk-get-set set)
(if set
(lambda (s)
(let* ((i (get-i (get-set->i (fluid-ref *current-set-theory*)) s)))
(set-car! set (logior set i))
i))
(lambda (s) 0)))
(define-syntax-rule (mk-get-set! set)
(if set
(lambda (s)
(let* ((i (get-i (get-set->i (fluid-ref *current-set-theory*)) s)))
(set-car! set (logior set i))
i))
(lambda (s) 0)))
#|
Basic construction and removal of set and set graph relationship,
|#
......@@ -415,6 +435,15 @@ a natural generational mapping to help in constructing a match tree.
|#
(define (inh-comb i->f)
(case-lambda
((x)
(values x
(vector x (get-i i->f x))))
((x y)
(logior x y))
(() 0)))
(define mktree
(case-lambda*
......@@ -462,14 +491,7 @@ a natural generational mapping to help in constructing a match tree.
(if (pair? l)
(let ((i (car l)))
(lp (cdr l)
(dynlist-add tree i
(case-lambda
((x)
(values x
(vector x (get-i i->f x))))
((x y)
(logior x y))
(() 0)))))
(dynlist-add tree i inh-comb)))
tree))))
tree)))
......@@ -531,3 +553,14 @@ from c-land in the indexer.
(order-the-set (fluid-ref *current-set-theory*))))
((theory)
(compile-set-representation theory))))
(define set<
(case-lambda
((x y)
(set< (fluid-ref *current-set-theory*) x y))
((theory x y)
(let ((set->i (get-set->i theory))
(i->subs (get-i->subs theory)))
(> (logand (get-i i->subs (get-i set->i y))
(get-i set->i x))
0)))))
......@@ -624,7 +624,7 @@ void get_index_set_0(SCM s, SCM e, SCM db_, int *n, ulong *data, int isPlus, SCM
db = dB(db_);
if(SCM_CONSP(db_))
{
SCM tree = SCM_CADR(db_);
SCM tree = SCM_CADDR(db_);
SCM bits = get_bits_from_set(set, trset);
SCM v = get_set(tree, bits);
......@@ -655,13 +655,13 @@ void get_index_set_0(SCM s, SCM e, SCM db_, int *n, ulong *data, int isPlus, SCM
}
}
db_ = SCM_CDDR(db_);
db_ = SCM_CDDDR(db_);
e = args;
goto redo;
}
}
}
db_ = SCM_CDDR(db_); goto redo;
db_ = SCM_CADR(db_); goto redo;
}
plus_tag:
......@@ -896,8 +896,8 @@ SCM_DEFINE(scm_get_index_tags, "get-index-tags", 0, 0, 0, (), "")
}
#undef FUNC_NAME
SCM_DEFINE(scm_set_type_attribute, "set-type-attribute!", 1, 0, 0, (SCM x), "")
#define FUNC_NAME s_scm_set_type_attribute
SCM_DEFINE(gp_set_type_attribute, "set-type-attribute!", 1, 0, 0, (SCM x), "")
#define FUNC_NAME s_gp_set_type_attribute
{
gp_type_attribute_tag = x;
return SCM_UNSPECIFIED;
......
......@@ -146,4 +146,4 @@ SCM_API SCM gp_lookup_1(SCM x, SCM s);
SCM_API SCM gp_get_taglist();
SCM_API SCM gp_match(SCM e, SCM run, SCM s);
SCM_API SCM gp_set_type_attribute(SCM x);
(define-module (logic guile-log type)
#: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-attvar?))
#:use-module (logic guile-log inheritance)
#:export (type? type Type))
(<define> (Type data var pred?)
(<let> ((var (<lookup> var)))
(if pred?
(if (gp-attvar? (<lookup> var) S)
(<var> (v)
(<if> (<get-attr> var Type v)
(<<match>> (#:mode -) (data v)
((f . l) (ff . ll)
(if (set< f ff)
(<=> l ll)
(if (set< ff f)
(<=> l ll)))))
(<put-attr> var Type data)))
(<<match>> (#:mode -) (data)
((f . data)
(<apply> f var data))))
(if (gp-attvar? var S)
(<var> (v)
(<if> (<get-attr> var Type v)
(<<match>> (#:mode -) (data v)
((f . l) (ff . ll)
(if (set< f ff)
(<==> l ll)
(if (set< ff f)
(<==> l ll)))))
<fail>))
<fail>))))
(<define> (pisType a tail x)
(<var> (r)
(<get-attr> x Type r)
(<=> a (,(vector (apply list type x (<lookup> r))) . tail))))
(set-attribute-cstor! Type pisType)
(<define> (type x . l)
(<put-attr> x Type l))
(define (type? s)
(lambda (x)
(and (gp-attvar-raw? x s)
(gp-get-attr x Type s))))
((@@ (logic guile-log code-load) set-type-attribute!) Type)
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