test-suite/tests/weaks.test

   1 ;;;; weaks.test --- tests guile's weaks     -*- scheme -*-
   2 ;;;; Copyright (C) 1999, 2001, 2003, 2006, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
   3 ;;;;
   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.
   8 ;;;;
   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.
  13 ;;;;
  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
  17
  18 ;;; {Description}
  19
  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.
  23 ;;;
  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.
  29 ;;;
  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 :)
  35
  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))
  41
  42
  43 ;;; Creation functions
  44
  45
  46 (with-test-prefix
  47  "weak-creation"
  48  (with-test-prefix "make-weak-vector"
  49   (pass-if "normal"
  50     (make-weak-vector 10 #f)
  51     #t)
  52   (pass-if-exception "bad size"
  53     exception:wrong-type-arg
  54     (make-weak-vector 'foo)))
  55
  56  (with-test-prefix "list->weak-vector"
  57                    (pass-if "create"
  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)))
  70
  71  (with-test-prefix "make-weak-key-hash-table"
  72                    (pass-if "create"
  73                      (make-weak-key-hash-table 17)
  74                      #t)
  75                    (pass-if-exception "bad-args"
  76                      exception:wrong-type-arg
  77                      (make-weak-key-hash-table '(bad arg))))
  78  (with-test-prefix "make-weak-value-hash-table"
  79                    (pass-if "create"
  80                      (make-weak-value-hash-table 17)
  81                      #t)
  82                    (pass-if-exception "bad-args"
  83                      exception:wrong-type-arg
  84                      (make-weak-value-hash-table '(bad arg))))
  85
  86  (with-test-prefix "make-doubly-weak-hash-table"
  87                    (pass-if "create"
  88                      (make-doubly-weak-hash-table 17)
  89                      #t)
  90                    (pass-if-exception "bad-args"
  91                      exception:wrong-type-arg
  92                      (make-doubly-weak-hash-table '(bad arg)))))
  93
  94
  95
  96
  97 ;; This should remove most of the non-dying problems associated with
  98 ;; trying this inside a closure
  99
 100 (define global-weak (make-weak-vector 10 #f))
 101 (begin
 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"))
 107   (gc))
 108
 109 ;;; Normal weak vectors
 110 (let ((x (make-weak-vector 10 #f))
 111       (bar "bar"))
 112   (with-test-prefix
 113    "weak-vector"
 114    (pass-if "lives"
 115             (begin
 116               (vector-set! x 0 bar)
 117               (gc)
 118               (and (vector-ref x 0) (eq? bar (vector-ref x 0)))))
 119    (pass-if "dies"
 120             (begin
 121               (gc)
 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))))))
 128
 129 \f
 130 ;;;
 131 ;;; Weak hash tables & weak alist vectors.
 132 ;;;
 133
 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
 137   ;; garbage.
 138   (or (not value)
 139       (equal? value initial-value)))
 140
 141  (let ((x (make-weak-key-hash-table 17))
 142       (y (make-weak-value-hash-table 17))
 143       (z (make-doubly-weak-hash-table 17))
 144       (test-key "foo")
 145       (test-value "bar"))
 146   (with-test-prefix
 147    "weak-hash"
 148    (pass-if "lives"
 149             (begin
 150               (hash-set! x test-key test-value)
 151               (hash-set! y test-key test-value)
 152               (hash-set! z test-key test-value)
 153               (gc)
 154               (gc)
 155               (and (hash-ref x test-key)
 156                    (hash-ref y test-key)
 157                    (hash-ref z test-key)
 158                    #t)))
 159
 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.
 162
 163    (pass-if "weak-key dies"
 164             (begin
 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")
 170               (gc)
 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"))
 175                      (any not values)
 176                      (hash-ref x test-key)
 177                      #t))))
 178
 179    (pass-if "weak-value dies"
 180             (begin
 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"))
 186               (gc)
 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"))
 191                      (any not values)
 192                      (hash-ref y test-key)
 193                      #t))))
 194
 195    (pass-if "doubly-weak dies"
 196             (begin
 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"))
 202               (gc)
 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"))
 207                      (any not values)
 208                      (hash-ref z test-key)
 209                      #t))))
 210
 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)))
 216
 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")))
 222
 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")))
 228
 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)))
 234
 235    (pass-if "hash-set!, weak key, returns value"
 236      (let ((t (make-weak-value-hash-table))
 237            (val (string #\f #\o #\o)))
 238        (eq? (hashq-set! t "bar" val)
 239             (hashv-set! t "bar" val)
 240             (hash-set! t "bar" val)
 241             val)))
 242
 243    (pass-if "assoc can do anything"
 244             ;; Until 1.9.12, as hash table's custom ASSOC procedure was
 245             ;; called with the GC lock alloc held, which imposed severe
 246             ;; restrictions on what it could do (bug #29616).  This test
 247             ;; makes sure this is no longer the case.
 248             (let ((h (make-doubly-weak-hash-table 2))
 249                   (c 123)
 250                   (k "GNU"))
 251
 252               (define (assoc-ci key bucket)
 253                 (make-list 123) ;; this should be possible
 254                 (gc)            ;; this too
 255                 (find (lambda (p)
 256                         (string-ci=? key (car p)))
 257                       bucket))
 258
 259               (hashx-set! string-hash-ci assoc-ci h
 260                           (string-copy "hello") (string-copy "world"))
 261               (hashx-set! string-hash-ci assoc-ci h
 262                           k "Guile")
 263
 264               (and (every (cut valid? <> "Guile")
 265                           (unfold (cut >= <> c)
 266                                   (lambda (_)
 267                                     (hashx-ref string-hash-ci assoc-ci
 268                                                h "gnu"))
 269                                   1+
 270                                   0))
 271                    (every (cut valid? <> "world")
 272                           (unfold (cut >= <> c)
 273                                   (lambda (_)
 274                                     (hashx-ref string-hash-ci assoc-ci
 275                                                h "HELLO"))
 276                                   1+
 277                                   0))
 278                    #t)))))