Commit | Line | Data |
---|---|---|
2e109b65 JB |
1 | ;;;; guardians.test --- test suite for Guile Guardians -*- scheme -*- |
2 | ;;;; Jim Blandy <jimb@red-bean.com> --- July 1999 | |
3 | ;;;; | |
96e30d2a | 4 | ;;;; Copyright (C) 1999, 2001 Free Software Foundation, Inc. |
2e109b65 JB |
5 | ;;;; |
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. | |
10 | ;;;; | |
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. | |
15 | ;;;; | |
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., 59 Temple Place, Suite 330, | |
19 | ;;;; Boston, MA 02111-1307 USA | |
20 | ||
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. | |
27 | ||
6d63297b DH |
28 | (use-modules (ice-9 documentation) |
29 | (ice-9 weak-vector)) | |
9247b5bc DH |
30 | |
31 | ||
32 | ;;; | |
33 | ;;; miscellaneous | |
34 | ;;; | |
35 | ||
36 | (define (documented? object) | |
37 | (not (not (object-documentation object)))) | |
38 | ||
2e109b65 | 39 | |
2e109b65 | 40 | (gc) |
2e109b65 JB |
41 | |
42 | ;;; Who guards the guardian? | |
43 | (gc) | |
44 | (define g2 (make-guardian)) | |
45 | (g2 (list 'g2-garbage)) | |
46 | (define g3 (make-guardian)) | |
47 | (g3 (list 'g3-garbage)) | |
48 | (g3 g2) | |
49 | (pass-if "g2-garbage not collected yet" (equal? (g2) #f)) | |
50 | (pass-if "g3-garbage not collected yet" (equal? (g3) #f)) | |
51 | (set! g2 #f) | |
52 | (gc) | |
53 | (let ((seen-g3-garbage #f) | |
54 | (seen-g2 #f) | |
55 | (seen-something-else #f)) | |
56 | (let loop () | |
57 | (let ((saved (g3))) | |
58 | (if saved | |
59 | (begin | |
60 | (cond | |
61 | ((equal? saved '(g3-garbage)) (set! seen-g3-garbage #t)) | |
62 | ((procedure? saved) (set! seen-g2 saved)) | |
63 | (else (set! seen-something-else #t))) | |
64 | (loop))))) | |
65 | (pass-if "g3-garbage saved" seen-g3-garbage) | |
5c96bc39 | 66 | (pass-if "g2-saved" (procedure? seen-g2)) |
2e109b65 JB |
67 | (pass-if "nothing else saved" (not seen-something-else)) |
68 | (pass-if "g2-garbage saved" (and (procedure? seen-g2) | |
69 | (equal? (seen-g2) '(g2-garbage))))) | |
9247b5bc DH |
70 | |
71 | (with-test-prefix "standard guardian functionality" | |
72 | ||
73 | (with-test-prefix "make-guardian" | |
74 | ||
75 | (pass-if "documented?" | |
76 | (documented? make-guardian)) | |
77 | ||
78 | (pass-if "returns procedure" | |
79 | (procedure? (make-guardian))) | |
80 | ||
81 | (pass-if "returns new procedure each time" | |
82 | (not (equal? (make-guardian) (make-guardian))))) | |
83 | ||
84 | (with-test-prefix "empty guardian" | |
85 | ||
86 | (pass-if "returns #f" | |
87 | (eq? ((make-guardian)) #f)) | |
88 | ||
89 | (pass-if "returns always #f" | |
90 | (let ((g (make-guardian))) | |
91 | (and (eq? (g) #f) | |
92 | (begin (gc) (eq? (g) #f)) | |
93 | (begin (gc) (eq? (g) #f)))))) | |
94 | ||
95 | (with-test-prefix "guarding independent objects" | |
96 | ||
97 | (pass-if "guarding immediate" | |
98 | (let ((g (make-guardian))) | |
99 | (g #f) | |
100 | (and (eq? (g) #f) | |
101 | (begin (gc) (eq? (g) #f)) | |
102 | (begin (gc) (eq? (g) #f))))) | |
103 | ||
104 | (pass-if "guarding non-immediate" | |
105 | (let ((g (make-guardian))) | |
106 | (gc) | |
107 | (g (cons #f #f)) | |
108 | (if (not (eq? (g) #f)) | |
109 | (throw 'unresolved) | |
110 | (begin | |
111 | (gc) | |
112 | (if (not (equal? (g) (cons #f #f))) | |
113 | (throw 'unresolved) | |
114 | (eq? (g) #f)))))) | |
115 | ||
116 | (pass-if "guarding two non-immediates" | |
117 | (let ((g (make-guardian))) | |
118 | (gc) | |
119 | (g (cons #f #f)) | |
120 | (g (cons #t #t)) | |
121 | (if (not (eq? (g) #f)) | |
122 | (throw 'unresolved) | |
123 | (begin | |
124 | (gc) | |
125 | (let ((l (list (g) (g)))) | |
126 | (if (not (or (equal? l (list (cons #f #f) (cons #t #t))) | |
127 | (equal? l (list (cons #t #t) (cons #f #f))))) | |
128 | (throw 'unresolved) | |
129 | (eq? (g) #f))))))) | |
130 | ||
131 | (pass-if "re-guarding non-immediates" | |
132 | (let ((g (make-guardian))) | |
133 | (gc) | |
134 | (g (cons #f #f)) | |
135 | (if (not (eq? (g) #f)) | |
136 | (throw 'unresolved) | |
137 | (begin | |
138 | (gc) | |
139 | (let ((p (g))) | |
140 | (if (not (equal? p (cons #f #f))) | |
141 | (throw 'unresolved) | |
142 | (begin | |
143 | (g p) | |
144 | (set! p #f) | |
145 | (gc) | |
146 | (if (not (equal? (g) (cons #f #f))) | |
147 | (throw 'unresolved) | |
148 | (eq? (g) #f))))))))) | |
149 | ||
150 | (pass-if "guarding living non-immediate" | |
151 | (let ((g (make-guardian)) | |
152 | (p (cons #f #f))) | |
153 | (g p) | |
154 | (if (not (eq? (g) #f)) | |
155 | (throw 'fail) | |
156 | (begin | |
157 | (gc) | |
158 | (not (eq? (g) p))))))) | |
159 | ||
160 | (with-test-prefix "guarding weakly referenced objects" | |
161 | ||
162 | (pass-if "guarded weak vector element gets returned from guardian" | |
163 | (let ((g (make-guardian)) | |
164 | (v (weak-vector #f))) | |
165 | (gc) | |
166 | (let ((p (cons #f #f))) | |
167 | (g p) | |
168 | (vector-set! v 0 p)) | |
169 | (if (not (eq? (g) #f)) | |
170 | (throw 'unresolved) | |
171 | (begin | |
172 | (gc) | |
173 | (if (not (equal? (g) (cons #f #f))) | |
174 | (throw 'unresolved) | |
175 | (eq? (g) #f)))))) | |
176 | ||
177 | (pass-if "guarded element of weak vector gets removed from weak vector" | |
178 | ;; How should this be handled? Should weak objects be removed from | |
179 | ;; their containers before they become zombies? Let's take a look at | |
180 | ;; the possible scenarios: a) Weak objects that are also guarded are | |
181 | ;; not removed from their containers as long as they are guarded. | |
182 | ;; However, they still can become zombies. The consequence is, that the | |
183 | ;; object can be retrieved from its container, thus being alive, while | |
184 | ;; on the other hand it can at the same time be retrieved from a | |
185 | ;; guardian. This is unfortunate, since when retrieving an object from | |
186 | ;; a guardian one would not expect any other reference to the object. | |
187 | ;; b) Weak objects are removed from their containers if they are not | |
188 | ;; referenced any more or if the only references are from guardians. | |
189 | ;; That means that it is guaranteed that there are no other references | |
190 | ;; to an object that is retrieved from a guardian. However, this means | |
191 | ;; that there is no chance to update containers like weak hash tables | |
192 | ;; using the information that one of their contained objects will be | |
193 | ;; removed. It may be however, that this is not necessary anyway. | |
194 | (let ((g (make-guardian)) | |
195 | (v (weak-vector #f))) | |
196 | (gc) | |
197 | (let ((p (cons #f #f))) | |
198 | (g p) | |
199 | (vector-set! v 0 p)) | |
200 | (if (not (equal? (vector-ref v 0) (cons #f #f))) | |
201 | (throw 'unresolved) | |
202 | (begin | |
203 | (gc) | |
204 | (if (equal? (vector-ref v 0) (cons #f #f)) | |
205 | (throw 'unresolved) | |
206 | #t)))))) | |
207 | ||
208 | (with-test-prefix "guarding weak containers" | |
209 | ||
210 | (pass-if "element of guarded weak vector gets collected" | |
211 | (let ((g (make-guardian)) | |
212 | (v (weak-vector (cons #f #f)))) | |
213 | (g v) | |
214 | (gc) | |
215 | (if (equal? (vector-ref v 0) (cons #f #f)) | |
216 | (throw 'unresolved) | |
217 | #t)))) | |
218 | ||
219 | (with-test-prefix "guarding guardians" | |
220 | #t)) | |
221 | ||
222 | (with-test-prefix "guile guardian functionality" | |
223 | ||
224 | (with-test-prefix "guarding dependent objects" | |
225 | ||
226 | (pass-if "guarding vector and element" | |
227 | (let ((g (make-guardian))) | |
228 | (gc) | |
229 | (let ((p (cons #f #f))) | |
230 | (g p) | |
231 | (g (vector p))) | |
232 | (if (not (eq? (g) #f)) | |
233 | (throw 'unresolved) | |
234 | (begin | |
235 | (gc) | |
236 | (if (not (equal? (g) (vector (cons #f #f)))) | |
237 | (throw 'unresolved) | |
238 | (if (not (eq? (g) #f)) | |
239 | (throw 'unresolved) | |
240 | (begin | |
241 | (gc) | |
242 | (if (not (equal? (g) (cons #f #f))) | |
243 | (throw 'unresolved) | |
244 | (eq? (g) #f))))))))) | |
245 | ||
246 | ) | |
247 | ||
248 | (with-test-prefix "guarding objects more than once" | |
249 | #t) | |
250 | ||
251 | (with-test-prefix "guarding cyclic dependencies" | |
252 | #t) | |
253 | ||
254 | ) |