dynamic var code debugged a bit

parent 2c8cb70a
......@@ -70,7 +70,7 @@ Also to remove elements one can use,
@findex <with-dynamic-functions>
@findex <guard-dynamic-functions>
The previous set of API is typically what you get to use in prolog. The
downside is that they posses problem w.r.t. leaking data and therefor the next ideom is preferable to use in order to make sure both that one undo any changes to the dynamic variable, but also at reinstation of a state inside the form, it will resore to the same state as when control left the inner of the ideom e.g.
downside is that they posses problem w.r.t. leaking data and therefor the next ideom is preferable to use in order to make sure both that one undo any changes to the dynamic variable, but also at reinstation of a state inside the form, it will resore to the same state as when control left the inner of the ideom e.g. The design is to favor fast lookup and adding and removing information is a bit expensive.
@code{G.L. (<with-dynamic-functions> (f ...) code ...)}, for this form @code{f ...}, will be weakly guarded throughout the form e.g. if control leaves the form then the state is stored if needed and at reinstation of state inside @code{code ...}, the old state of the dynamic variable will be reinstated. But inside the form state of the dynamic functions is not saved or restored.
......
(define-module (logic guile-log ck)
#:export (ck))
#:use-module (ice-9 pretty-print)
#:export (ck ck-pk))
(define-syntax ck-pk
(lambda (x)
(syntax-case x (quote)
((_ s 'x)
(begin
(pretty-print (syntax->datum #'x))
#'(ck s 'x))))))
;; This is the classic ck macro copied from guile master
(define-syntax ck
(syntax-rules (quote)
......
(define-module (logic guile-log functional-database)
#:use-module (logic guile-log)
#:use-module (logic guile-log ck)
#:use-module (logic guile-log umatch)
#:use-module (logic guile-log dynlist)
#:use-module (logic guile-log indexer)
......@@ -12,9 +13,10 @@
dynamic-remove dynamic-env-ref dynamic-env-set!
;get-index-set
dynamic-compile-index
<with-dynamic>
<with-dynamic-functions>
<push-dynamic>
<append-dynamic>
<remove-dynamic>
<lambda-dyn>))
#|
......@@ -237,35 +239,6 @@ add/run * vlist *
(make-empty)))
(make-empty))))
#;
(define (get-index-set s e f db)
(if db
(match e
((x . l)
(union
(get-index-set s l
(get-index-set s x f
(dlink-car db #f)) (dlink-cdr db #f))
(intersection f (get-vars db))))
(a
(if (gp-var? a s)
(intersection f (get-all db))
(union
(intersection f (get-fs-from-atoms a db))
(intersection f (get-vars db))))))
f))
(define (bitmap-indexer-run-lr s tag a db walk-lr F)
(let ((f (realize-set (get-index-set s a (make-all tag) db))))
(walk-lr f
(lambda (s p cc x)
(if (member? (car x) f)
(F s p cc (cdr x))
(p)))))))
(define (bits->list bits)
(let lp ((bits bits) (n 0) (res '()))
(let ((d (first-set-bit bits)))
......@@ -395,40 +368,33 @@ add/run * vlist *
(fluid-set! env (cons (compile-index-raw s (car e))
(compile-index-raw s (cdr e))))))
(define (walk-raw s p a F walk-dynlist e)
(let* ((e (fluid-ref env))
(ar (get-ar e))
(define (walk-raw s p a F walk-dynlist e rev)
(let* ((ar (get-ar e))
(db (get-li e)))
(define walk
(if ar
(lambda (f F)
(let lp ((l (bits->list (car f))))
(if (null? l)
(let lp ((l (reverse (bits->list (cdr f)))))
(if (null? l)
(p)
(F (lambda () (lp (cdr l)))
(vector-ref ar (car l)))))
(F (lambda () (lp (cdr l)))
(vector-ref ar (car l))))))
(lambda (f F)
(walk-dynlist p F (get-dyn e)))))
(bitmap-indexer-run-lr s (get-tag e) a db walk F)))
(let lp ((l (rev (get-index-set s a db))))
(if (null? l)
(p)
(F (lambda () (lp (cdr l)))
a
(vector-ref ar (car l)))))))
(define (walk-lr s p a F)
(let ((e (fluid-ref env)))
(if (not (get-li (car e)))
(begin
(compile-index s)
(compile)
(walk-lr s p a F))
(let ((el (car e))
(er (cdr e)))
(walk-raw s (lambda () (walk-raw s p a F walk-dynlist-rl er))
a F walk-dynlist-lr el)))))
(er (cdr e))
(a (gp->scm a s)))
(walk-raw s (lambda () (walk-raw s p a F walk-dynlist-rl er
(lambda (x) x)))
a F walk-dynlist-lr el
reverse!)))))
(values walk-lr add-l add-r rm compile env-ref env-set! compile-index)))
(values walk-lr add-l add-r rm compile env-ref env-set! compile-index))))
(define-syntax-rule (define-dynamic f)
......@@ -439,11 +405,13 @@ add/run * vlist *
(set! f (lambda (s p cc . a)
(let ((fr (gp-newframe s)))
(walk-lr s p a
(lambda (p x)
(lambda (p a vec)
(let ((p (lambda () (gp-unwind fr) (p))))
((get-f f) s p cc a)))))))
(set-object-property! f 'dynamic-data (vector add-l add-r rm compile
env-ref env-set! compi))))))
((get-f vec) s p cc a)))))))
(set-object-property! f 'dynamic-data
(vector add-l add-r rm compile
env-ref env-set! compi))))))
(define (dynamic-push s g a f c)
(let ((env (object-property g 'dynamic-data)))
......@@ -451,10 +419,10 @@ add/run * vlist *
((vector-ref env 0) s a f c)
(error "not a dynamic variable"))))
(define (dynamic-append s g a v f c)
(define (dynamic-append s g a f c)
(let ((env (object-property g 'dynamic-data)))
(if env
((vector-ref env 1) s a v f c)
((vector-ref env 1) s a f c)
(error "not a dynamic variable"))))
(define (dynamic-remove s f F)
......@@ -487,68 +455,86 @@ add/run * vlist *
((vector-ref env 6) s)
(error "not a dynamic variable"))))
(define-syntax ck-cons
(syntax-rules (quote)
((_ s 'x 'l)
(ck s '(x . l)))))
(define-syntax parse-list
(lambda (x)
(syntax-case x (quote unquote)
((_ s '(unquote x))
#'(ck s '(unquote x)))
((_ s ''x)
#'(ck s 'x))
((_ s 'x)
(identifier? #'x)
#'(ck s '(unquote (gp-make-var))))
((_ s '(x . l))
#'(ck s (ck-cons (parse-list 'x) (parse-list 'l))))
((_ s 'x)
#'(ck s 'x)))))
(define-syntax add-quote
(syntax-rules (quote)
((_ s 'x)
`x)))
(define-syntax-rule (mk-varpat x)
(ck () (add-quote (parse-list 'x))))
(define-syntax <lambda-dyn>
(syntax-rules ()
(syntax-rules ()
((_ (pat ...) code)
(list (mk-varpat pat)
(list (mk-varpat (pat ...))
(lambda (a b c x)
(apply (<<lambda>> (pat ... code))
a b c x))
#f))
((_ (pat ...) code y)
(list (mk-varpat pat)
(list (mk-varpat (pat ...))
(lambda (a b c x)
(apply (<<lambda>> (pat ... code))
a b c x))
(lambda (a b c x)
(apply (<<lambda>> (pat ... y))
a b c x))))))
a b c x))))
((_ (pat ...))
(<lambda-dyn> (pat ...) <cc>))))
(<define-guile-log-rule> (<push-dynamic> f dyn-lambda)
(<code> (apply dynamic-push S f dyn-lambda)))
(<define-guile-log-rule> (<append-dynamic> f dyn-lambda)
(<code> (apply dynamic-append S f dyn-lambda)))
(<define-guile-log-rule> (<remove-dynamic> (f x ...))
(<code> (dynamic-remove S f (list x ...))))
(<define-guile-log-rule> (<weak-with-dynamic> f code ...)
(<let> ((state (dynamic-env-ref f)))
(<with-lr-guards> lguard rguard w ((s state))
(lguard
(<dynwind-dyn>
;; In
(lambda ()
(dynamic-env-set! f s))
;; Out
(lambda ()
(let ((-state- (dynamic-env-ref f)))
(dynamic-env-set! f state)
(set! s -state-))))
(rguard code ...)))))
(<define-guile-log-rule> (<strong-with-dynamic> f code ...)
(<let> ((state (dynamic-env-ref f)))
(<with-lr-guards> lguard rguard w ((s state))
(lguard
(<dynwind-dyn>
;; In
(lambda ()
(dynamic-env-set! f s))
;; Out
(lambda ()
(let ((-state- (dynamic-env-ref f)))
(dynamic-env-set! f state)
(set! s -state-))))
code ...))))
(<define> (<postpone-dynamic> ((v f) ...) postpone)
(<code> (variable-set! v (dynamic-env-ref f))
...)
postpone
(<code> (dynamic-env-set! f (variable-ref v))
...))
|#
;; Used to reference interanls states of dynamic functions
;; at e.g. state storage and thread creation
(define *dynfuncs* (make-fluid '()))
;; Border saving
#;
(<define-guile-log-rule> (<with-dynamic-functions> (f ...) code ...)
(<let> ((state (make-fluid (list (dynamic-env-ref f))))
(fs (list f ...)))
(<dynwind-dyn>
(lambda () #f)
(lambda ()
(for-each (lambda (f st)
(truncate st)
(dynamic-env-set! f st))
fs (fluid-ref state))))
(<code> (gp-fluid-set state (fluid-ref state))
(gp-fluid-set *dynfuncs* (union (fluid-ref *dynfuncs*)
fs)))
(<dynwind-dyn>
(lambda ()
(for-each (lambda (f st) (dynamic-env-set! f st))
fs (fluid-ref state)))
(lambda ()
(fluid-set! state (list (dynamic-env-ref f) ...))))
code ...))
\ No newline at end of file
......@@ -15,7 +15,7 @@
<recur> <letrec>
<lambda> <case-lambda> <with-fail> <with-cut> <with-s>
<with-cc>
<<lambda> <<case-lambda>>
<<lambda>> <<case-lambda>>
<match> <=> <r=> <==> *r* <funcall> <apply>
<and!> <and!!> <succeds>
<format> <code> <ret>
......
......@@ -118,15 +118,21 @@ void get_index_set_0(SCM s, SCM e, SCM db_, int *n, ulong *data)
{
ulong data2[200];
int n2;
SCM *db = dB(db_);
SCM *db;
//gp_format1("index for ~a~%",e);
//printf("n=%d, data[0] = %p datat[1]=%p\n", *n, data[0], data[1]);
if(scm_is_false(db)) return;
//gp_format2("index for ~a db ~a~%", e, db_);fflush(stdout);
db = dB(db_);
if(scm_is_false(db))
{
data[0] = 0UL;
*n = 1;
return;
}
if(SCM_CONSP(e))
{
{
SCM x = SCM_CAR(e);
SCM l = SCM_CDR(e);
SCM v = get_vars(db);
......@@ -159,10 +165,14 @@ void get_index_set_0(SCM s, SCM e, SCM db_, int *n, ulong *data)
data2[i] = data3[i];
}
}
SCM dcar = dlink_car(db,0);
SCM dcdr = dlink_cdr(db,0);
//printf("sub v\n");fflush(stdout);
get_index_set_0(s,x,dlink_car(db,0), n, data);
get_index_set_0(s,l,dlink_cdr(db,0), n, data);
if(scm_is_true(dcar))
get_index_set_0(s,x,dcar, n, data);
if(scm_is_true(dcdr))
get_index_set_0(s,l,dcdr, n, data);
//printf("finish v\n");fflush(stdout);
{
......@@ -179,6 +189,7 @@ void get_index_set_0(SCM s, SCM e, SCM db_, int *n, ulong *data)
if(scm_is_true(gp_varp(e,s)))
{
//printf("VAR\n");fflush(stdout);
SCM v = get_all(db);
//printf("VAR\n");fflush(stdout);
if(SCM_I_INUMP (v))
......@@ -295,6 +306,7 @@ SCM get_index_set(SCM s, SCM e, SCM db)
ulong data[200];
int d,i,j,b,n = 0;
SCM ret;
get_index_set_0(s, e, db, &n, data);
//printf("Got %p %p\n",data[0],data[1]);
......
(use-modules (logic guile-log functional-database))
(use-modules (logic guile-log indexer))
(use-modules (logic guile-log umatch))
(use-modules (logic guile-log))
(define-dynamic f)
(<define> (add-rules a)
(<append-dynamic> f (<lambda-dyn> (,a 'b)))
(<append-dynamic> f (<lambda-dyn> (,a 'c)))
(<append-dynamic> f (<lambda-dyn> (,a 'd)))
(<append-dynamic> f (<lambda-dyn> (,a 'e))))
(pk (<run> 10 (x y)
(add-rules 1)
(add-rules 2)
(add-rules 3)
#;(f x y)))
(define (add x)
(dynamic-push *current-stack* f x #f #f))
(define (get)
......@@ -9,7 +24,7 @@
(define (comp)
(dynamic-compile-index *current-stack* f))
#|
(define n 33)
(for-each
......@@ -38,4 +53,5 @@
(finde v e)
(begin
(finde v e)
(loop (- n 1)))))))
\ No newline at end of file
(loop (- n 1)))))))
|#
\ No newline at end of file
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