test-suite/tests/weaks.test

   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 \f
 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)))))