1;;;; weaks.test --- tests guile's weaks     -*- scheme -*-
2;;;; Copyright (C) 1999, 2001, 2003, 2006, 2009, 2010, 2011, 2012, 2014
3;;;; Free Software Foundation, Inc.
4;;;;
5;;;; This library is free software; you can redistribute it and/or
6;;;; modify it under the terms of the GNU Lesser General Public
7;;;; License as published by the Free Software Foundation; either
8;;;; version 3 of the License, or (at your option) any later version.
9;;;;
10;;;; This library is distributed in the hope that it will be useful,
11;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
13;;;; Lesser General Public License for more details.
14;;;;
15;;;; You should have received a copy of the GNU Lesser General Public
16;;;; License along with this library; if not, write to the Free Software
17;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
18
19;;; {Description}
20
21;;; This is a semi test suite for weaks; I say semi, because weaks
22;;; are pretty non-deterministic given the amount of information we
23;;; can infer from scheme.
24;;;
25;;; In particular, we can't always reliably test the more important
26;;; aspects of weaks (i.e., that an object is removed when it's dead)
27;;; because we have no way of knowing for certain that the object is
28;;; really dead. It tests it anyway, but the failures of any `death'
29;;; tests really shouldn't be surprising.
30;;;
31;;; Interpret failures in the dying functions here as a hint that you
32;;; should look at any changes you've made involving weaks
33;;; (everything else should always pass), but there are a host of
34;;; other reasons why they might not work as tested here, so if you
35;;; haven't done anything to weaks, don't sweat it :)
36
37(define-module (test-weaks)
38  #:use-module (test-suite lib)
39  #:use-module (ice-9 weak-vector)
40  #:use-module (srfi srfi-1)
41  #:use-module (srfi srfi-26))
42
43
44;;; Creation functions
45
46
47(with-test-prefix
48 "weak-creation"
49 (with-test-prefix "make-weak-vector"
50  (pass-if "normal"
51    (make-weak-vector 10 #f)
52    #t)
53  (pass-if-exception "bad size"
54    exception:wrong-type-arg
55    (make-weak-vector 'foo)))
56
57 (with-test-prefix "list->weak-vector"
58		   (pass-if "create"
59			    (let* ((lst '(a b c d e f g))
60				   (wv (list->weak-vector lst)))
61			      (and (eq? (weak-vector-ref wv 0) 'a)
62				   (eq? (weak-vector-ref wv 1) 'b)
63				   (eq? (weak-vector-ref wv 2) 'c)
64				   (eq? (weak-vector-ref wv 3) 'd)
65				   (eq? (weak-vector-ref wv 4) 'e)
66				   (eq? (weak-vector-ref wv 5) 'f)
67				   (eq? (weak-vector-ref wv 6) 'g))))
68		   (pass-if-exception "bad-args"
69		     exception:wrong-type-arg
70		     (list->weak-vector 32)))
71
72 (with-test-prefix "make-weak-key-hash-table"
73		   (pass-if "create"
74		     (make-weak-key-hash-table 17)
75		     #t)
76		   (pass-if-exception "bad-args"
77		     exception:wrong-type-arg
78		     (make-weak-key-hash-table '(bad arg))))
79 (with-test-prefix "make-weak-value-hash-table"
80		   (pass-if "create"
81		     (make-weak-value-hash-table 17)
82		     #t)
83		   (pass-if-exception "bad-args"
84		     exception:wrong-type-arg
85		     (make-weak-value-hash-table '(bad arg))))
86
87 (with-test-prefix "make-doubly-weak-hash-table"
88		   (pass-if "create"
89		     (make-doubly-weak-hash-table 17)
90		     #t)
91		   (pass-if-exception "bad-args"
92		     exception:wrong-type-arg
93		     (make-doubly-weak-hash-table '(bad arg)))))
94
95
96
97
98;; This should remove most of the non-dying problems associated with
99;; trying this inside a closure
100
101(define global-weak (make-weak-vector 10 #f))
102(begin
103  (weak-vector-set! global-weak 0 (string-copy "string"))
104  (weak-vector-set! global-weak 1 (string-copy "beans"))
105  (weak-vector-set! global-weak 2 (string-copy "to"))
106  (weak-vector-set! global-weak 3 (string-copy "utah"))
107  (weak-vector-set! global-weak 4 (string-copy "yum yum"))
108  (gc))
109
110;;; Normal weak vectors
111(let ((x (make-weak-vector 10 #f))
112      (bar "bar"))
113  (with-test-prefix
114   "weak-vector"
115   (pass-if "lives"
116	    (begin
117	      (weak-vector-set! x 0 bar)
118	      (gc)
119	      (and (weak-vector-ref x 0) (eq? bar (weak-vector-ref x 0)))))
120   (pass-if "dies"
121	    (begin
122	      (gc)
123	      (or (and (not (weak-vector-ref global-weak 0))
124		       (not (weak-vector-ref global-weak 1))
125		       (not (weak-vector-ref global-weak 2))
126		       (not (weak-vector-ref global-weak 3))
127		       (not (weak-vector-ref global-weak 4)))
128		  (throw 'unresolved))))))
129
130
131;;;
132;;; Weak hash tables & weak alist vectors.
133;;;
134
135(define (valid? value initial-value)
136  ;; Return true if VALUE is "valid", i.e., if it's either #f or
137  ;; INITIAL-VALUE.  The idea is to make sure `hash-ref' doesn't return
138  ;; garbage.
139  (or (not value)
140      (equal? value initial-value)))
141
142 (let ((x (make-weak-key-hash-table 17))
143      (y (make-weak-value-hash-table 17))
144      (z (make-doubly-weak-hash-table 17))
145      (test-key "foo")
146      (test-value "bar"))
147  (with-test-prefix
148   "weak-hash"
149   (pass-if "lives"
150	    (begin
151	      (hash-set! x test-key test-value)
152	      (hash-set! y test-key test-value)
153	      (hash-set! z test-key test-value)
154	      (gc)
155	      (gc)
156	      (and (hash-ref x test-key)
157		   (hash-ref y test-key)
158		   (hash-ref z test-key)
159		   #t)))
160
161   ;; In the tests below we use `string-copy' to avoid the risk of
162   ;; unintended retention of a string that we want to be GC'd.
163
164   (pass-if "weak-key dies"
165            (begin
166              (hash-set! x (string-copy "this") "is")
167              (hash-set! x (string-copy "a") "test")
168              (hash-set! x (string-copy "of") "the")
169              (hash-set! x (string-copy "emergency") "weak")
170              (hash-set! x (string-copy "key") "hash system")
171              (gc)
172              (let ((values (map (cut hash-ref x <>)
173                                 '("this" "a" "of" "emergency" "key"))))
174                (and (every valid? values
175                            '("is" "test" "the" "weak" "hash system"))
176                     (any not values)
177                     (hash-ref x test-key)
178                     #t))))
179
180   (pass-if "weak-value dies"
181            (begin
182              (hash-set! y "this" (string-copy "is"))
183              (hash-set! y "a" (string-copy "test"))
184              (hash-set! y "of" (string-copy "the"))
185              (hash-set! y "emergency" (string-copy "weak"))
186              (hash-set! y "value" (string-copy "hash system"))
187              (gc)
188              (let ((values (map (cut hash-ref y <>)
189                                 '("this" "a" "of" "emergency" "key"))))
190                (and (every valid? values
191                            '("is" "test" "the" "weak" "hash system"))
192                     (any not values)
193                     (hash-ref y test-key)
194                     #t))))
195
196   (pass-if "doubly-weak dies"
197            (begin
198              (hash-set! z (string-copy "this") (string-copy "is"))
199              (hash-set! z "a" (string-copy "test"))
200              (hash-set! z (string-copy "of") "the")
201              (hash-set! z "emergency" (string-copy "weak"))
202              (hash-set! z (string-copy "all") (string-copy "hash system"))
203              (gc)
204              (let ((values (map (cut hash-ref z <>)
205                                 '("this" "a" "of" "emergency" "key"))))
206                (and (every valid? values
207                            '("is" "test" "the" "weak" "hash system"))
208                     (any not values)
209                     (hash-ref z test-key)
210                     #t))))
211
212   (pass-if "hash-set!, weak val, im -> im"
213     (let ((t (make-weak-value-hash-table)))
214       (hash-set! t "foo" 1)
215       (hash-set! t "foo" 2)
216       (equal? (hash-ref t "foo") 2)))
217
218   (pass-if "hash-set!, weak val, im -> nim"
219     (let ((t (make-weak-value-hash-table)))
220       (hash-set! t "foo" 1)
221       (hash-set! t "foo" "baz")
222       (equal? (hash-ref t "foo") "baz")))
223
224   (pass-if "hash-set!, weak val, nim -> nim"
225     (let ((t (make-weak-value-hash-table)))
226       (hash-set! t "foo" "bar")
227       (hash-set! t "foo" "baz")
228       (equal? (hash-ref t "foo") "baz")))
229
230   (pass-if "hash-set!, weak val, nim -> im"
231     (let ((t (make-weak-value-hash-table)))
232       (hash-set! t "foo" "bar")
233       (hash-set! t "foo" 1)
234       (equal? (hash-ref t "foo") 1)))
235
236   (pass-if "hash-set!, weak key, returns value"
237     (let ((t (make-weak-value-hash-table))
238           (val (string #\f #\o #\o)))
239       (eq? (hashq-set! t "bar" val)
240            (hashv-set! t "bar" val)
241            (hash-set! t "bar" val)
242            val)))
243
244   (pass-if "assoc can do anything"
245            ;; Until 1.9.12, as hash table's custom ASSOC procedure was
246            ;; called with the GC lock alloc held, which imposed severe
247            ;; restrictions on what it could do (bug #29616).  This test
248            ;; makes sure this is no longer the case.
249            (let ((h (make-doubly-weak-hash-table 2))
250                  (c 123)
251                  (k "GNU"))
252
253              (define (assoc-ci key bucket)
254                (make-list 123) ;; this should be possible
255                (gc)            ;; this too
256                (find (lambda (p)
257                        (string-ci=? key (car p)))
258                      bucket))
259
260              (hashx-set! string-hash-ci assoc-ci h
261                          (string-copy "hello") (string-copy "world"))
262              (hashx-set! string-hash-ci assoc-ci h
263                          k "Guile")
264
265              (and (every (cut valid? <> "Guile")
266                          (unfold (cut >= <> c)
267                                  (lambda (_)
268                                    (hashx-ref string-hash-ci assoc-ci
269                                               h "gnu"))
270                                  1+
271                                  0))
272                   (every (cut valid? <> "world")
273                          (unfold (cut >= <> c)
274                                  (lambda (_)
275                                    (hashx-ref string-hash-ci assoc-ci
276                                               h "HELLO"))
277                                  1+
278                                  0))
279                   #t)))))
280