dmbcs/guile
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Adapted to new (original) semantics. test guardingobjects multiple

Browse source 
times.
This commit is contained in:
Marius Vollmer 2005-07-31 23:16:45 +00:00
commit 2924541ba0
1 changed files with 70 additions and 54 deletions
Download patch file Download diff file Expand all files Collapse all files

124
test-suite/tests/guardians.test
View file

@ -25,7 +25,8 @@
;;; they explicitly invoke GC --- in other words, they assume that GC
;;; won't happen too often.
(use-modules (ice-9 documentation)
(use-modules (test-suite lib)
(ice-9 documentation)
(ice-9 weak-vector))
@ -60,13 +61,14 @@
(cond
((equal? saved '(g3-garbage)) (set! seen-g3-garbage #t))
((procedure? saved) (set! seen-g2 saved))
(else (set! seen-something-else #t)))
(else (pk saved) (set! seen-something-else #t)))
(loop)))))
(pass-if "g3-garbage saved" seen-g3-garbage)
(pass-if "g2-saved" (procedure? seen-g2))
(pass-if "g3-garbage saved" (or seen-g3-garbage (throw 'unresolved)))
(pass-if "g2-saved" (or (procedure? seen-g2) (throw 'unresolved)))
(pass-if "nothing else saved" (not seen-something-else))
(pass-if "g2-garbage saved" (and (procedure? seen-g2)
(equal? (seen-g2) '(g2-garbage)))))
(pass-if "g2-garbage saved" (or (and (procedure? seen-g2)
(equal? (seen-g2) '(g2-garbage)))
(throw 'unresolved))))
(with-test-prefix "standard guardian functionality"
@ -174,36 +176,21 @@
(throw 'unresolved)
(eq? (g) #f))))))
(pass-if "guarded element of weak vector gets removed from weak vector"
;; How should this be handled? Should weak objects be removed from
;; their containers before they become zombies? Let's take a look at
;; the possible scenarios: a) Weak objects that are also guarded are
;; not removed from their containers as long as they are guarded.
;; However, they still can become zombies. The consequence is, that the
;; object can be retrieved from its container, thus being alive, while
;; on the other hand it can at the same time be retrieved from a
;; guardian. This is unfortunate, since when retrieving an object from
;; a guardian one would not expect any other reference to the object.
;; b) Weak objects are removed from their containers if they are not
;; referenced any more or if the only references are from guardians.
;; That means that it is guaranteed that there are no other references
;; to an object that is retrieved from a guardian. However, this means
;; that there is no chance to update containers like weak hash tables
;; using the information that one of their contained objects will be
;; removed. It may be however, that this is not necessary anyway.
(pass-if "guarded element of weak vector gets eventually removed from weak vector"
(let ((g (make-guardian))
(v (weak-vector #f)))
(gc)
(let ((p (cons #f #f)))
(g p)
(vector-set! v 0 p))
(if (not (equal? (vector-ref v 0) (cons #f #f)))
(throw 'unresolved)
(begin
(gc)
(if (equal? (vector-ref v 0) (cons #f #f))
(throw 'unresolved)
#t))))))
(begin
(gc)
(if (not (equal? (g) (cons #f #f)))
(throw 'unresolved)
(begin
(gc)
(or (not (vector-ref v 0))
(throw 'unresolved))))))))
(with-test-prefix "guarding weak containers"
@ -217,36 +204,65 @@
#t))))
(with-test-prefix "guarding guardians"
#t))
(with-test-prefix "guile guardian functionality"
#t)
(with-test-prefix "guarding dependent objects"
(pass-if "guarding vector and element"
(let ((g (make-guardian)))
(gc)
(let ((p (cons #f #f)))
(g p)
(g (vector p)))
(if (not (eq? (g) #f))
(throw 'unresolved)
(begin
(gc)
(if (not (equal? (g) (vector (cons #f #f))))
(throw 'unresolved)
(if (not (eq? (g) #f))
(throw 'unresolved)
(begin
(gc)
(if (not (equal? (g) (cons #f #f)))
(throw 'unresolved)
(eq? (g) #f)))))))))
;; We don't make any guarantees about the order objects are
;; returned from guardians and therefore we skip the following
;; test.
)
(if #f
(pass-if "guarding vector and element"
(let ((g (make-guardian)))
(gc)
(let ((p (cons #f #f)))
(g p)
(g (vector p)))
(if (not (eq? (g) #f))
(throw 'unresolved)
(begin
(gc)
(if (not (equal? (g) (vector (cons #f #f))))
(throw 'unresolved)
(if (not (eq? (g) #f))
(throw 'unresolved)
(begin
(gc)
(if (not (equal? (g) (cons #f #f)))
(throw 'unresolved)
(eq? (g) #f)))))))))))
(with-test-prefix "guarding objects more than once"
#t)
(pass-if "guarding twice in one guardian"
(let ((g (make-guardian)))
(gc)
(let ((p (cons #f #f)))
(g p)
(g p))
(if (not (eq? (g) #f))
(throw 'unresolved)
(begin
(gc)
(or (and (and=> (g) (lambda (o) (equal? o (cons #f #f))))
(and=> (g) (lambda (o) (equal? o (cons #f #f)))))
(throw 'unresolved))))))
(pass-if "guarding twice in two guardians"
(let ((g (make-guardian))
(h (make-guardian)))
(gc)
(let ((p (cons #f #f)))
(g p)
(h p))
(if (not (eq? (g) #f))
(throw 'unresolved)
(begin
(gc)
(or (and (and=> (g) (lambda (o) (equal? o (cons #f #f))))
(and=> (h) (lambda (o) (equal? o (cons #f #f)))))
(throw 'unresolved)))))))
(with-test-prefix "guarding cyclic dependencies"
#t)