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