1 ;;;; weaks.test --- tests guile's weaks -*- scheme -*-
2 ;;;; Copyright (C) 1999, 2001, 2003, 2006, 2009, 2010, 2011 Free Software Foundation, Inc.
4 ;;;; This library is free software; you can redistribute it and/or
5 ;;;; modify it under the terms of the GNU Lesser General Public
6 ;;;; License as published by the Free Software Foundation; either
7 ;;;; version 3 of the License, or (at your option) any later version.
9 ;;;; This library is distributed in the hope that it will be useful,
10 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 ;;;; Lesser General Public License for more details.
14 ;;;; You should have received a copy of the GNU Lesser General Public
15 ;;;; License along with this library; if not, write to the Free Software
16 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
20 ;;; This is a semi test suite for weaks; I say semi, because weaks
21 ;;; are pretty non-deterministic given the amount of information we
22 ;;; can infer from scheme.
24 ;;; In particular, we can't always reliably test the more important
25 ;;; aspects of weaks (i.e., that an object is removed when it's dead)
26 ;;; because we have no way of knowing for certain that the object is
27 ;;; really dead. It tests it anyway, but the failures of any `death'
28 ;;; tests really shouldn't be surprising.
30 ;;; Interpret failures in the dying functions here as a hint that you
31 ;;; should look at any changes you've made involving weaks
32 ;;; (everything else should always pass), but there are a host of
33 ;;; other reasons why they might not work as tested here, so if you
34 ;;; haven't done anything to weaks, don't sweat it :)
36 (define-module (test-weaks)
37 #:use-module (test-suite lib)
38 #:use-module (ice-9 weak-vector)
39 #:use-module (srfi srfi-1)
40 #:use-module (srfi srfi-26))
43 ;;; Creation functions
48 (with-test-prefix "make-weak-vector"
50 (make-weak-vector 10 #f)
52 (pass-if-exception "bad size"
53 exception:wrong-type-arg
54 (make-weak-vector 'foo)))
56 (with-test-prefix "list->weak-vector"
58 (let* ((lst '(a b c d e f g))
59 (wv (list->weak-vector lst)))
60 (and (eq? (vector-ref wv 0) 'a)
61 (eq? (vector-ref wv 1) 'b)
62 (eq? (vector-ref wv 2) 'c)
63 (eq? (vector-ref wv 3) 'd)
64 (eq? (vector-ref wv 4) 'e)
65 (eq? (vector-ref wv 5) 'f)
66 (eq? (vector-ref wv 6) 'g))))
67 (pass-if-exception "bad-args"
68 exception:wrong-type-arg
69 (list->weak-vector 32)))
71 (with-test-prefix "make-weak-key-alist-vector"
73 (make-weak-key-alist-vector 17)
75 (pass-if-exception "bad-args"
76 exception:wrong-type-arg
77 (make-weak-key-alist-vector '(bad arg))))
78 (with-test-prefix "make-weak-value-alist-vector"
80 (make-weak-value-alist-vector 17)
82 (pass-if-exception "bad-args"
83 exception:wrong-type-arg
84 (make-weak-value-alist-vector '(bad arg))))
86 (with-test-prefix "make-doubly-weak-alist-vector"
88 (make-doubly-weak-alist-vector 17)
90 (pass-if-exception "bad-args"
91 exception:wrong-type-arg
92 (make-doubly-weak-alist-vector '(bad arg)))))
97 ;; This should remove most of the non-dying problems associated with
98 ;; trying this inside a closure
100 (define global-weak (make-weak-vector 10 #f))
102 (vector-set! global-weak 0 (string-copy "string"))
103 (vector-set! global-weak 1 (string-copy "beans"))
104 (vector-set! global-weak 2 (string-copy "to"))
105 (vector-set! global-weak 3 (string-copy "utah"))
106 (vector-set! global-weak 4 (string-copy "yum yum"))
109 ;;; Normal weak vectors
110 (let ((x (make-weak-vector 10 #f))
116 (vector-set! x 0 bar)
118 (and (vector-ref x 0) (eq? bar (vector-ref x 0)))))
122 (or (and (not (vector-ref global-weak 0))
123 (not (vector-ref global-weak 1))
124 (not (vector-ref global-weak 2))
125 (not (vector-ref global-weak 3))
126 (not (vector-ref global-weak 4)))
127 (throw 'unresolved))))))
131 ;;; Weak hash tables & weak alist vectors.
134 (define (valid? value initial-value)
135 ;; Return true if VALUE is "valid", i.e., if it's either #f or
136 ;; INITIAL-VALUE. The idea is to make sure `hash-ref' doesn't return
139 (equal? value initial-value)))
141 (let ((x (make-weak-key-alist-vector 17))
142 (y (make-weak-value-alist-vector 17))
143 (z (make-doubly-weak-alist-vector 17))
150 (hash-set! x test-key test-value)
151 (hash-set! y test-key test-value)
152 (hash-set! z test-key test-value)
155 (and (hash-ref x test-key)
156 (hash-ref y test-key)
157 (hash-ref z test-key)
160 ;; In the tests below we use `string-copy' to avoid the risk of
161 ;; unintended retention of a string that we want to be GC'd.
163 (pass-if "weak-key dies"
165 (hash-set! x (string-copy "this") "is")
166 (hash-set! x (string-copy "a") "test")
167 (hash-set! x (string-copy "of") "the")
168 (hash-set! x (string-copy "emergency") "weak")
169 (hash-set! x (string-copy "key") "hash system")
171 (let ((values (map (cut hash-ref x <>)
172 '("this" "a" "of" "emergency" "key"))))
173 (and (every valid? values
174 '("is" "test" "the" "weak" "hash system"))
176 (hash-ref x test-key)
179 (pass-if "weak-value dies"
181 (hash-set! y "this" (string-copy "is"))
182 (hash-set! y "a" (string-copy "test"))
183 (hash-set! y "of" (string-copy "the"))
184 (hash-set! y "emergency" (string-copy "weak"))
185 (hash-set! y "value" (string-copy "hash system"))
187 (let ((values (map (cut hash-ref y <>)
188 '("this" "a" "of" "emergency" "key"))))
189 (and (every valid? values
190 '("is" "test" "the" "weak" "hash system"))
192 (hash-ref y test-key)
195 (pass-if "doubly-weak dies"
197 (hash-set! z (string-copy "this") (string-copy "is"))
198 (hash-set! z "a" (string-copy "test"))
199 (hash-set! z (string-copy "of") "the")
200 (hash-set! z "emergency" (string-copy "weak"))
201 (hash-set! z (string-copy "all") (string-copy "hash system"))
203 (let ((values (map (cut hash-ref z <>)
204 '("this" "a" "of" "emergency" "key"))))
205 (and (every valid? values
206 '("is" "test" "the" "weak" "hash system"))
208 (hash-ref z test-key)
211 (pass-if "hash-set!, weak val, im -> im"
212 (let ((t (make-weak-value-hash-table)))
213 (hash-set! t "foo" 1)
214 (hash-set! t "foo" 2)
215 (equal? (hash-ref t "foo") 2)))
217 (pass-if "hash-set!, weak val, im -> nim"
218 (let ((t (make-weak-value-hash-table)))
219 (hash-set! t "foo" 1)
220 (hash-set! t "foo" "baz")
221 (equal? (hash-ref t "foo") "baz")))
223 (pass-if "hash-set!, weak val, nim -> nim"
224 (let ((t (make-weak-value-hash-table)))
225 (hash-set! t "foo" "bar")
226 (hash-set! t "foo" "baz")
227 (equal? (hash-ref t "foo") "baz")))
229 (pass-if "hash-set!, weak val, nim -> im"
230 (let ((t (make-weak-value-hash-table)))
231 (hash-set! t "foo" "bar")
232 (hash-set! t "foo" 1)
233 (equal? (hash-ref t "foo") 1)))
235 (pass-if "assoc can do anything"
236 ;; Until 1.9.12, as hash table's custom ASSOC procedure was
237 ;; called with the GC lock alloc held, which imposed severe
238 ;; restrictions on what it could do (bug #29616). This test
239 ;; makes sure this is no longer the case.
240 (let ((h (make-doubly-weak-hash-table 2))
244 (define (assoc-ci key bucket)
245 (make-list 123) ;; this should be possible
248 (string-ci=? key (car p)))
251 (hashx-set! string-hash-ci assoc-ci h
252 (string-copy "hello") (string-copy "world"))
253 (hashx-set! string-hash-ci assoc-ci h
256 (and (every (cut valid? <> "Guile")
257 (unfold (cut >= <> c)
259 (hashx-ref string-hash-ci assoc-ci
263 (every (cut valid? <> "world")
264 (unfold (cut >= <> c)
266 (hashx-ref string-hash-ci assoc-ci