test-suite/tests/r6rs-hashtables.test

   1 ;;; r6rs-hashtables.test --- Test suite for R6RS (rnrs hashtables)
   2
   3 ;;      Copyright (C) 2010 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 Lice6nse, 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 \f
  19
  20 (define-module (test-suite test-rnrs-hashtable)
  21   :use-module (ice-9 receive)
  22   :use-module ((rnrs hashtables) :version (6))
  23   :use-module (srfi srfi-1)
  24   :use-module (test-suite lib))
  25
  26 (with-test-prefix "make-eq-hashtable"
  27   (pass-if "eq hashtable compares keys with eq?"
  28     (let ((eq-hashtable (make-eq-hashtable)))
  29       (hashtable-set! eq-hashtable (list 'foo) #t)
  30       (hashtable-set! eq-hashtable 'sym #t)
  31       (and (not (hashtable-contains? eq-hashtable (list 'foo)))
  32            (hashtable-contains? eq-hashtable 'sym)))))
  33
  34 (with-test-prefix "make-eqv-hashtable"
  35   (pass-if "eqv hashtable compares keys with eqv?"
  36     (let ((eqv-hashtable (make-eqv-hashtable)))
  37       (hashtable-set! eqv-hashtable (list 'foo) #t)
  38       (hashtable-set! eqv-hashtable 4 #t)
  39       (and (not (hashtable-contains? eqv-hashtable (list 'foo)))
  40            (hashtable-contains? eqv-hashtable 4)))))
  41
  42 (with-test-prefix "make-hashtable"
  43   (pass-if "hashtable compares keys with custom equality function"
  44     (let* ((abs-eqv? (lambda (x y) (eqv? (abs x) (abs y))))
  45            (abs-hashtable (make-hashtable abs abs-eqv?)))
  46       (hashtable-set! abs-hashtable -4 #t)
  47       (and (not (hashtable-contains? abs-hashtable 6))
  48            (hashtable-contains? abs-hashtable 4))))
  49
  50   (pass-if "hash function value used modulo capacity"
  51     (let* ((constant-hash (lambda (x) most-positive-fixnum))
  52            (constant-hashtable (make-hashtable constant-hash eq?)))
  53       (hashtable-set! constant-hashtable 'foo 'bar)
  54       (hashtable-contains? constant-hashtable 'foo))))
  55
  56 (with-test-prefix "hashtable?"
  57   (pass-if "hashtable? is #t on hashtables"
  58     (let ((hashtable (make-eq-hashtable)))
  59       (hashtable? hashtable)))
  60
  61   (pass-if "hashtable? is #f on non-hashtables"
  62     (let ((not-hashtable (list)))
  63       (not (hashtable? not-hashtable)))))
  64
  65 (with-test-prefix "hashtable-size"
  66   (pass-if "hashtable-size returns current size"
  67     (let ((hashtable (make-eq-hashtable)))
  68       (and (eqv? (hashtable-size hashtable) 0)
  69            (hashtable-set! hashtable 'foo #t)
  70            (eqv? (hashtable-size hashtable) 1)))))
  71
  72 (with-test-prefix "hashtable-ref"
  73   (pass-if "hashtable-ref returns value for bound key"
  74     (let ((hashtable (make-eq-hashtable)))
  75       (hashtable-set! hashtable 'sym 'foo)
  76       (eq? (hashtable-ref hashtable 'sym 'bar) 'foo)))
  77
  78   (pass-if "hashtable-ref returns default for unbound key"
  79     (let ((hashtable (make-eq-hashtable)))
  80       (eq? (hashtable-ref hashtable 'sym 'bar) 'bar))))
  81
  82 (with-test-prefix "hashtable-set!"
  83   (pass-if "hashtable-set! returns unspecified"
  84     (let ((hashtable (make-eq-hashtable)))
  85       (unspecified? (hashtable-set! hashtable 'foo 'bar))))
  86
  87   (pass-if "hashtable-set! allows storing #f"
  88     (let ((hashtable (make-eq-hashtable)))
  89       (hashtable-set! hashtable 'foo #f)
  90       (not (hashtable-ref hashtable 'foo 'bar)))))
  91
  92 (with-test-prefix "hashtable-delete!"
  93   (pass-if "hashtable-delete! removes association"
  94     (let ((hashtable (make-eq-hashtable)))
  95       (hashtable-set! hashtable 'foo 'bar)
  96       (and (unspecified? (hashtable-delete! hashtable 'foo))
  97            (not (hashtable-ref hashtable 'foo #f))))))
  98
  99 (with-test-prefix "hashtable-contains?"
 100   (pass-if "hashtable-contains? returns #t when association present"
 101     (let ((hashtable (make-eq-hashtable)))
 102       (hashtable-set! hashtable 'foo 'bar)
 103       (let ((contains (hashtable-contains? hashtable 'foo)))
 104         (and (boolean? contains) contains))))
 105
 106   (pass-if "hashtable-contains? returns #f when association not present"
 107     (let ((hashtable (make-eq-hashtable)))
 108       (not (hashtable-contains? hashtable 'foo)))))
 109
 110 (with-test-prefix "hashtable-update!"
 111   (pass-if "hashtable-update! adds return value of proc on bound key"
 112     (let ((hashtable (make-eq-hashtable)))
 113       (hashtable-set! hashtable 'foo 0)
 114       (hashtable-update! hashtable 'foo (lambda (x) (+ x 1)) 100)
 115       (eqv? (hashtable-ref hashtable 'foo #f) 1)))
 116
 117   (pass-if "hashtable-update! adds default value on unbound key"
 118     (let ((hashtable (make-eq-hashtable)))
 119       (hashtable-update! hashtable 'foo (lambda (x) (+ x 1)) 100)
 120       (eqv? (hashtable-ref hashtable 'foo #f) 101))))
 121
 122 (with-test-prefix "hashtable-copy"
 123   (pass-if "hashtable-copy produces copy of hashtable"
 124     (let ((hashtable (make-eq-hashtable)))
 125       (hashtable-set! hashtable 'foo 1)
 126       (hashtable-set! hashtable 'bar 2)
 127       (let ((copied-table (hashtable-copy hashtable)))
 128         (and (eqv? (hashtable-ref hashtable 'foo #f) 1)
 129              (eqv? (hashtable-ref hashtable 'bar #f) 2)))))
 130
 131   (pass-if "hashtable-copy with mutability #f produces immutable copy"
 132     (let ((copied-table (hashtable-copy (make-eq-hashtable) #f)))
 133       (hashtable-set! copied-table 'foo 1)
 134       (not (hashtable-ref copied-table 'foo #f)))))
 135
 136 (with-test-prefix "hashtable-clear!"
 137   (pass-if "hashtable-clear! removes all values from hashtable"
 138     (let ((hashtable (make-eq-hashtable)))
 139       (hashtable-set! hashtable 'foo 1)
 140       (hashtable-set! hashtable 'bar 2)
 141       (and (unspecified? (hashtable-clear! hashtable))
 142            (eqv? (hashtable-size hashtable) 0)))))
 143
 144 (with-test-prefix "hashtable-keys"
 145   (pass-if "hashtable-keys returns all keys"
 146     (let ((hashtable (make-eq-hashtable)))
 147       (hashtable-set! hashtable 'foo #t)
 148       (hashtable-set! hashtable 'bar #t)
 149       (let ((keys (vector->list (hashtable-keys hashtable))))
 150         (and (memq 'foo keys) (memq 'bar keys) #t)))))
 151
 152 (with-test-prefix "hashtable-entries"
 153   (pass-if "hashtable-entries returns all entries"
 154     (let ((hashtable (make-eq-hashtable)))
 155       (hashtable-set! hashtable 'foo 1)
 156       (hashtable-set! hashtable 'bar 2)
 157       (receive
 158         (keys values)
 159         (hashtable-entries hashtable)
 160         (let f ((counter 0) (success #t))
 161           (if (or (not success) (= counter 2))
 162               success
 163               (case (vector-ref keys counter)
 164                 ((foo) (f (+ counter 1) (eqv? (vector-ref values counter) 1)))
 165                 ((bar) (f (+ counter 1) (eqv? (vector-ref values counter) 2)))
 166                 (else f 0 #f))))))))
 167
 168 (with-test-prefix "hashtable-equivalence-function"
 169   (pass-if "hashtable-equivalence-function returns eqv function"
 170     (let* ((abs-eqv? (lambda (x y) (eqv? (abs x) (abs y))))
 171            (abs-hashtable (make-hashtable abs abs-eqv?)))
 172       (eq? (hashtable-equivalence-function abs-hashtable) abs-eqv?))))
 173
 174 (with-test-prefix "hashtable-hash-function"
 175   (pass-if "hashtable-hash-function returns hash function"
 176     (let ((abs-hashtable (make-hashtable abs eqv?)))
 177       (eq? (hashtable-hash-function abs-hashtable) abs))))
 178
 179 (with-test-prefix "hashtable-mutable?"
 180   (pass-if "hashtable-mutable? is #t on mutable hashtables"
 181     (hashtable-mutable? (hashtable-copy (make-eq-hashtable) #t)))
 182
 183   (pass-if "hashtable-mutable? is #f on immutable hashtables"
 184     (not (hashtable-mutable? (hashtable-copy (make-eq-hashtable) #f)))))