1 ;;;; guardians.test --- test suite for Guile Guardians -*- scheme -*-
2 ;;;; Jim Blandy <jimb@red-bean.com> --- July 1999
4 ;;;; Copyright (C) 1999, 2001, 2006 Free Software Foundation, Inc.
6 ;;;; This program is free software; you can redistribute it and/or modify
7 ;;;; it under the terms of the GNU General Public License as published by
8 ;;;; the Free Software Foundation; either version 2, or (at your option)
9 ;;;; any later version.
11 ;;;; This program is distributed in the hope that it will be useful,
12 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 ;;;; GNU General Public License for more details.
16 ;;;; You should have received a copy of the GNU General Public License
17 ;;;; along with this software; see the file COPYING. If not, write to
18 ;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
19 ;;;; Boston, MA 02110-1301 USA
21 ;;; These tests make some questionable assumptions.
22 ;;; - They assume that a GC will find all dead objects, so they
23 ;;; will become flaky if we have a generational GC.
24 ;;; - They assume that objects won't be saved by the guardian until
25 ;;; they explicitly invoke GC --- in other words, they assume that GC
26 ;;; won't happen too often.
28 (use-modules (test-suite lib)
37 (define (documented? object)
38 (not (not (object-documentation object))))
43 ;;; Who guards the guardian?
45 ;;; Note: We use strings rather than symbols because symbols are usually
46 ;;; ``interned'', i.e., kept in a weakly-keyed hash table, thus making them
47 ;;; inappropriate for the tests below. Furthermore, we use `string-copy' in
48 ;;; order to make sure that no string is kept around in the interpreter
49 ;;; unwillingly (e.g., in the source-property weak hash table).
52 (define g2 (make-guardian))
53 (g2 (list (string-copy "g2-garbage")))
54 (define g3 (make-guardian))
55 (g3 (list (string-copy "g3-garbage")))
57 (pass-if "g2-garbage not collected yet" (equal? (g2) #f))
58 (pass-if "g3-garbage not collected yet" (equal? (g3) #f))
61 (let ((seen-g3-garbage #f)
63 (seen-something-else #f))
69 ((equal? saved (list (string-copy "g3-garbage")))
70 (set! seen-g3-garbage #t))
71 ((procedure? saved) (set! seen-g2 saved))
72 (else (pk 'junk saved) (set! seen-something-else #t)))
74 (pass-if "g3-garbage saved" (or seen-g3-garbage (throw 'unresolved)))
75 (pass-if "g2-saved" (or (procedure? seen-g2) (throw 'unresolved)))
76 (pass-if "nothing else saved" (not seen-something-else))
77 (pass-if "g2-garbage saved" (or (and (procedure? seen-g2)
81 (throw 'unresolved))))
83 (with-test-prefix "standard guardian functionality"
85 (with-test-prefix "make-guardian"
87 (pass-if "documented?"
88 (documented? make-guardian))
90 (pass-if "returns procedure"
91 (procedure? (make-guardian)))
93 (pass-if "returns new procedure each time"
94 (not (equal? (make-guardian) (make-guardian)))))
96 (with-test-prefix "empty guardian"
99 (eq? ((make-guardian)) #f))
101 (pass-if "returns always #f"
102 (let ((g (make-guardian)))
104 (begin (gc) (eq? (g) #f))
105 (begin (gc) (eq? (g) #f))))))
107 (with-test-prefix "guarding independent objects"
109 (pass-if "guarding immediate"
110 (let ((g (make-guardian)))
113 (begin (gc) (eq? (g) #f))
114 (begin (gc) (eq? (g) #f)))))
116 (pass-if "guarding non-immediate"
117 (let ((g (make-guardian)))
120 (if (not (eq? (g) #f))
124 (if (not (equal? (g) (cons #f #f)))
128 (pass-if "guarding two non-immediates"
129 (let ((g (make-guardian)))
133 (if (not (eq? (g) #f))
137 (let ((l (list (g) (g))))
138 (if (not (or (equal? l (list (cons #f #f) (cons #t #t)))
139 (equal? l (list (cons #t #t) (cons #f #f)))))
143 (pass-if "re-guarding non-immediates"
144 (let ((g (make-guardian)))
147 (if (not (eq? (g) #f))
152 (if (not (equal? p (cons #f #f)))
158 (if (not (equal? (g) (cons #f #f)))
162 (pass-if "guarding living non-immediate"
163 (let ((g (make-guardian))
166 (if (not (eq? (g) #f))
170 (not (eq? (g) p)))))))
172 (with-test-prefix "guarding weakly referenced objects"
174 (pass-if "guarded weak vector element gets returned from guardian"
175 (let ((g (make-guardian))
176 (v (weak-vector #f)))
178 (let ((p (cons #f #f)))
181 (if (not (eq? (g) #f))
185 (if (not (equal? (g) (cons #f #f)))
189 (pass-if "guarded element of weak vector gets eventually removed from weak vector"
190 (let ((g (make-guardian))
191 (v (weak-vector #f)))
193 (let ((p (cons #f #f)))
198 (if (not (equal? (g) (cons #f #f)))
202 (or (not (vector-ref v 0))
203 (throw 'unresolved))))))))
205 (with-test-prefix "guarding weak containers"
207 (pass-if "element of guarded weak vector gets collected"
208 (let ((g (make-guardian))
209 (v (weak-vector (cons #f #f))))
212 (if (equal? (vector-ref v 0) (cons #f #f))
216 (with-test-prefix "guarding guardians"
219 (with-test-prefix "guarding dependent objects"
221 ;; We don't make any guarantees about the order objects are
222 ;; returned from guardians and therefore we skip the following
226 (pass-if "guarding vector and element"
227 (let ((g (make-guardian)))
229 (let ((p (cons #f #f)))
232 (if (not (eq? (g) #f))
236 (if (not (equal? (g) (vector (cons #f #f))))
238 (if (not (eq? (g) #f))
242 (if (not (equal? (g) (cons #f #f)))
244 (eq? (g) #f)))))))))))
246 (with-test-prefix "guarding objects more than once"
248 (pass-if "guarding twice in one guardian"
249 (let ((g (make-guardian)))
251 (let ((p (cons #f #f)))
254 (if (not (eq? (g) #f))
258 (or (and (and=> (g) (lambda (o) (equal? o (cons #f #f))))
259 (and=> (g) (lambda (o) (equal? o (cons #f #f)))))
260 (throw 'unresolved))))))
262 (pass-if "guarding twice in two guardians"
263 (let ((g (make-guardian))
266 (let ((p (cons #f #f)))
269 (if (not (eq? (g) #f))
273 (or (and (and=> (g) (lambda (o) (equal? o (cons #f #f))))
274 (and=> (h) (lambda (o) (equal? o (cons #f #f)))))
275 (throw 'unresolved)))))))
277 (with-test-prefix "guarding cyclic dependencies"