with-dynamic-var tested

parent da684614
......@@ -1205,7 +1205,6 @@ G.L. (postpone-frame limit fact maxsize)
@end verbatim
To be able to postpone we must have a baseline from which we will base our restarts e.g. @code{postpone-frame}. The @code{postpone} command will basically evaluate @code{val} and postpone if it's larger then a certain limit that is governed by an initial value @code{limit} and @code{fact} - a factor that adds to the limit each postpone turn. The @code{power} is the sorting index used to manage a list of possible restarts for and this list is sorted so that we at restarts will try to use @code{maxsize} first elements of the list. The list is never larger then @code{10 * maxsize}.
@node database
@chapter database
Anything prolog like means that we need some kind of database for matching. And one such tool is included in guile-log. This is not a dynamic databas but one that we only can add elements and then compile and use it for lookup. It has some optimizations in it to be effective at looking the elements up still maintaining the introduced orders.
......
......@@ -314,22 +314,23 @@ add/run * vlist *
(if (vlist? x)
(vlist-truncate! x)))
(define (xxx-hash vlist-truncate! x)
(define (xxx-hash vhash-truncate! x)
(when x
(truncate (get-car x))
(truncate (get-cdr x))
(xxx-hash vhash-truncate! (get-car x))
(xxx-hash vhash-truncate! (get-cdr x))
(let ((a (get-atoms x)))
(when a (vlist-truncate! a)))))
(when a (vhash-truncate! a)))))
(define (xxx vlist-truncate! vhash-truncate!)
(let ((el (car env))
(er (cdr env)))
(let* ((e (fluid-ref env))
(el (car e))
(er (cdr e)))
(xxx-hash vhash-truncate! (get-li el))
(xxx-hash vhash-truncate! (get-li er))
(xxx-vlist vlist-truncate! (get-ar el))
(xxx-vlist vlist-truncate! (get-ar er))))
(define (truncate!) (xxx vlist-truncate! vhash-truncate!))
(define (truncate!) (xxx vlist-truncate! vhash-truncate!))
(define (ref++) (xxx vlist-refcount++ vlist-refcount++))
(define (ref--) (xxx vlist-refcount-- vlist-refcount--))
......@@ -442,14 +443,16 @@ add/run * vlist *
(lambda (x) x))))))
(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
truncate! ref++ ref--))))
(define-syntax-rule (define-dynamic f)
(begin
(define f #f)
(call-with-values make-functional-dynamic-db
(lambda (walk-lr add-l add-r rm compile env-ref env-set! compi)
(lambda (walk-lr add-l add-r rm compile env-ref env-set! compi
truncate! ref++ ref--)
(set! f (lambda (s p cc . a)
(let ((fr (gp-newframe s)))
(walk-lr s p a
......@@ -495,8 +498,8 @@ add/run * vlist *
(define (dynamic-env-set! f state)
(let ((env (object-property f 'dynamic-data)))
(if env
((vector-ref env 5) state))
(error "not a dynamic variable")))
((vector-ref env 5) state)
(error "not a dynamic variable"))))
(define (dynamic-compile-index s f)
(let ((env (object-property f 'dynamic-data)))
......@@ -588,32 +591,33 @@ add/run * vlist *
;; Border saving
(<define> (<with-dynamic-functions> . fs)
(<code>
(for-each
(lambda (f)
(let ((F (case-lambda
(() (dynamic-env-ref f))
(<code>
(for-each
(lambda (f)
(let ((F (case-lambda
(() (dynamic-env-ref f))
((x)
(dynamic-env-set! f x)
(dynamic-truncate! f)))))
(gp-fluid-set F (dynamic-env-ref f))))
fs)))
;; Unclear how to introduce this function,
;; Right now in (<or-i> A B) the state of the dynamic variable
;; is the same for each restart in A.
(<define> (<guard-dynamic-functions> . fs)
(<code>
(for-each
(lambda (f)
(let* ((s (dynamic-env-ref f))
(F (case-lambda
(()
(let ((ret (dynamic-env-ref f)))
(if (not (eq? s ret))
(dynamic-refcount++ f)
ret)))
((x)
(dynamic-env-set! f x)
(dynamic-truncate! f)))))
(gp-fluid-set F (dynamic-env-ref f))))
fs)))
(<define> (<guard-dynamic-functions> . fs)
(<code>
(let ((windl (gp-lookup *windlevel* S)))
(gp-var-set *windlevel* (+ windl 1) S)
(for-each
(lambda (f)
(let* ((s (dynamic-env-ref f))
(F (case-lambda
(()
(let ((ret (dynamic-env-ref f)))
(if (not (eq? s ret))
(dynamic-refcount++ f)
ret)))
((x)
(dynamic-env-set! f x)
(dynamic-truncate! f)))))
(gp-undo-safe-variable-guard F windl S)))
fs))))
(gp-undo-safe-variable-guard F #t S)))
fs)))
......@@ -246,6 +246,7 @@ inline vlist_truncate_x(SCM vlist)
ulong st = block_size_thr(base);
ulong os = block_offset_seq(base);
//TODO: Stack nulling
if(!count && seq == SEQ(os) && thr == THR(st))
block_next_free_ref(base) = my_scm_from_int(offset);
}
......@@ -781,7 +782,7 @@ void vhash_truncate_x(SCM vhash)
int khsh = BACKREF_REF(os);
block_hash_table_set_s(content, size, khsh, off);
}
vlist_truncate(vhash);
vlist_truncate_x(vhash);
}
SCM vhash_cons_adv(SCM key, SCM value, SCM vhash, SCM (*hash)(SCM, SCM))
......
......@@ -55,7 +55,11 @@
(add-rules 7)
(f x y)))
(pk
(<run> 100 (x) (<or> (<and> (<with-dynamic-functions> f)
(add-rules 7)
(f 7 x))
(f 7 x))))
#|
......
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