test-suite/tests/hash.test

   1 ;;;; hash.test --- test guile hashing     -*- scheme -*-
   2 ;;;;
   3 ;;;; Copyright (C) 2004, 2005, 2006, 2008, 2011, 2012 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 (define-module (test-suite test-numbers)
  20   #:use-module (test-suite lib)
  21   #:use-module (ice-9 documentation))
  22
  23 ;;;
  24 ;;; hash
  25 ;;;
  26
  27 (with-test-prefix "hash"
  28   (pass-if (->bool (object-documentation hash)))
  29   (pass-if-exception "hash #t -1" exception:out-of-range
  30     (hash #t -1))
  31   (pass-if-exception "hash #t 0" exception:out-of-range
  32     (hash #t 0))
  33   (pass-if (= 0 (hash #t 1)))
  34   (pass-if (= 0 (hash #f 1)))
  35   (pass-if (= 0 (hash noop 1)))
  36   (pass-if (= 0 (hash +inf.0 1)))
  37   (pass-if (= 0 (hash -inf.0 1)))
  38   (pass-if (= 0 (hash +nan.0 1))))
  39
  40 ;;;
  41 ;;; hashv
  42 ;;;
  43
  44 (with-test-prefix "hashv"
  45   (pass-if (->bool (object-documentation hashv)))
  46   (pass-if-exception "hashv #t -1" exception:out-of-range
  47     (hashv #t -1))
  48   (pass-if-exception "hashv #t 0" exception:out-of-range
  49     (hashv #t 0))
  50   (pass-if (= 0 (hashv #t 1)))
  51   (pass-if (= 0 (hashv #f 1)))
  52   (pass-if (= 0 (hashv noop 1))))
  53
  54 ;;;
  55 ;;; hashq
  56 ;;;
  57
  58 (with-test-prefix "hashq"
  59   (pass-if (->bool (object-documentation hashq)))
  60   (pass-if-exception "hashq #t -1" exception:out-of-range
  61     (hashq #t -1))
  62   (pass-if-exception "hashq #t 0" exception:out-of-range
  63     (hashq #t 0))
  64   (pass-if (= 0 (hashq #t 1)))
  65   (pass-if (= 0 (hashq #f 1)))
  66   (pass-if (= 0 (hashq noop 1))))
  67
  68 ;;;
  69 ;;; make-hash-table
  70 ;;;
  71
  72 (with-test-prefix
  73  "make-hash-table, hash-table?"
  74  (pass-if-exception "make-hash-table -1" exception:out-of-range
  75                     (make-hash-table -1))
  76  (pass-if (hash-table? (make-hash-table 0))) ;; default
  77  (pass-if (not (hash-table? 'not-a-hash-table)))
  78  (pass-if (string-suffix? " 0/113>"
  79                           (with-output-to-string
  80                             (lambda ()
  81                               (write (make-hash-table 100)))))))
  82
  83 ;;;
  84 ;;; usual set and reference
  85 ;;;
  86
  87 (with-test-prefix
  88  "hash-set and hash-ref"
  89
  90  ;; auto-resizing
  91  (pass-if (let ((table (make-hash-table 1))) ;;actually makes size 31
  92             (hash-set! table 'one 1)
  93             (hash-set! table 'two #t)
  94             (hash-set! table 'three #t)
  95             (hash-set! table 'four #t)
  96             (hash-set! table 'five #t)
  97             (hash-set! table 'six #t)
  98             (hash-set! table 'seven #t)
  99             (hash-set! table 'eight #t)
 100             (hash-set! table 'nine 9)
 101             (hash-set! table 'ten #t)
 102             (hash-set! table 'eleven #t)
 103             (hash-set! table 'twelve #t)
 104             (hash-set! table 'thirteen #t)
 105             (hash-set! table 'fourteen #t)
 106             (hash-set! table 'fifteen #t)
 107             (hash-set! table 'sixteen #t)
 108             (hash-set! table 'seventeen #t)
 109             (hash-set! table 18 #t)
 110             (hash-set! table 19 #t)
 111             (hash-set! table 20 #t)
 112             (hash-set! table 21 #t)
 113             (hash-set! table 22 #t)
 114             (hash-set! table 23 #t)
 115             (hash-set! table 24 #t)
 116             (hash-set! table 25 #t)
 117             (hash-set! table 26 #t)
 118             (hash-set! table 27 #t)
 119             (hash-set! table 28 #t)
 120             (hash-set! table 29 #t)
 121             (hash-set! table 30 'thirty)
 122             (hash-set! table 31 #t)
 123             (hash-set! table 32 #t)
 124             (hash-set! table 33 'thirty-three)
 125             (hash-set! table 34 #t)
 126             (hash-set! table 35 #t)
 127             (hash-set! table 'foo 'bar)
 128             (and (equal? 1 (hash-ref table 'one))
 129                  (equal? 9 (hash-ref table 'nine))
 130                  (equal? 'thirty (hash-ref table 30))
 131                  (equal? 'thirty-three (hash-ref table 33))
 132                  (equal? 'bar (hash-ref table 'foo))
 133                  (string-suffix? " 36/61>"
 134                                  (with-output-to-string
 135                                    (lambda () (write table)))))))
 136
 137  ;; 1 and 1 are equal? and eqv? (but not necessarily eq?)
 138  (pass-if (equal? 'foo
 139                   (let ((table (make-hash-table)))
 140                     (hash-set! table 1 'foo)
 141                     (hash-ref table 1))))
 142  (pass-if (equal? 'foo
 143                   (let ((table (make-hash-table)))
 144                     (hashv-set! table 1 'foo)
 145                     (hashv-ref table 1))))
 146
 147  ;; 1/2 and 2/4 are equal? and eqv? (but not necessarily eq?)
 148  (pass-if (equal? 'foo
 149                   (let ((table (make-hash-table)))
 150                     (hash-set! table 1/2 'foo)
 151                     (hash-ref table 2/4))))
 152  (pass-if (equal? 'foo
 153                   (let ((table (make-hash-table)))
 154                     (hashv-set! table 1/2 'foo)
 155                     (hashv-ref table 2/4))))
 156
 157  ;; (list 1 2) is equal? but not eqv? or eq? to another (list 1 2)
 158  (pass-if (equal? 'foo
 159                   (let ((table (make-hash-table)))
 160                     (hash-set! table (list 1 2) 'foo)
 161                     (hash-ref table (list 1 2)))))
 162  (pass-if (equal? #f
 163                   (let ((table (make-hash-table)))
 164                     (hashv-set! table (list 1 2) 'foo)
 165                     (hashv-ref table (list 1 2)))))
 166  (pass-if (equal? #f
 167                   (let ((table (make-hash-table)))
 168                     (hashq-set! table (list 1 2) 'foo)
 169                     (hashq-ref table (list 1 2)))))
 170
 171  ;; ref default argument
 172  (pass-if (equal? 'bar
 173                   (let ((table (make-hash-table)))
 174                     (hash-ref table 'foo 'bar))))
 175  (pass-if (equal? 'bar
 176                   (let ((table (make-hash-table)))
 177                     (hashv-ref table 'foo 'bar))))
 178  (pass-if (equal? 'bar
 179                   (let ((table (make-hash-table)))
 180                     (hashq-ref table 'foo 'bar))))
 181  (pass-if (equal? 'bar
 182                   (let ((table (make-hash-table)))
 183                     (hashx-ref hash equal? table 'foo 'bar))))
 184
 185  ;; wrong type argument
 186  (pass-if-exception "(hash-ref 'not-a-table 'key)" exception:wrong-type-arg
 187                     (hash-ref 'not-a-table 'key))
 188  )
 189
 190 ;;;
 191 ;;; hashx
 192 ;;;
 193
 194 (with-test-prefix
 195  "auto-resizing hashx"
 196  ;; auto-resizing
 197  (let ((table (make-hash-table 1))) ;;actually makes size 31
 198    (hashx-set! hash assoc table 1/2 'equal)
 199    (hashx-set! hash assoc table 1/3 'equal)
 200    (hashx-set! hash assoc table 4 'equal)
 201    (hashx-set! hash assoc table 1/5 'equal)
 202    (hashx-set! hash assoc table 1/6 'equal)
 203    (hashx-set! hash assoc table 7 'equal)
 204    (hashx-set! hash assoc table 1/8 'equal)
 205    (hashx-set! hash assoc table 1/9 'equal)
 206    (hashx-set! hash assoc table 10 'equal)
 207    (hashx-set! hash assoc table 1/11 'equal)
 208    (hashx-set! hash assoc table 1/12 'equal)
 209    (hashx-set! hash assoc table 13 'equal)
 210    (hashx-set! hash assoc table 1/14 'equal)
 211    (hashx-set! hash assoc table 1/15 'equal)
 212    (hashx-set! hash assoc table 16 'equal)
 213    (hashx-set! hash assoc table 1/17 'equal)
 214    (hashx-set! hash assoc table 1/18 'equal)
 215    (hashx-set! hash assoc table 19 'equal)
 216    (hashx-set! hash assoc table 1/20 'equal)
 217    (hashx-set! hash assoc table 1/21 'equal)
 218    (hashx-set! hash assoc table 22 'equal)
 219    (hashx-set! hash assoc table 1/23 'equal)
 220    (hashx-set! hash assoc table 1/24 'equal)
 221    (hashx-set! hash assoc table 25 'equal)
 222    (hashx-set! hash assoc table 1/26 'equal)
 223    (hashx-set! hash assoc table 1/27 'equal)
 224    (hashx-set! hash assoc table 28 'equal)
 225    (hashx-set! hash assoc table 1/29 'equal)
 226    (hashx-set! hash assoc table 1/30 'equal)
 227    (hashx-set! hash assoc table 31 'equal)
 228    (hashx-set! hash assoc table 1/32 'equal)
 229    (hashx-set! hash assoc table 1/33 'equal)
 230    (hashx-set! hash assoc table 34 'equal)
 231    (pass-if (equal? 'equal (hash-ref table 2/4)))
 232    (pass-if (equal? 'equal (hash-ref table 2/6)))
 233    (pass-if (equal? 'equal (hash-ref table 4)))
 234    (pass-if (equal? 'equal (hashx-ref hash assoc table 2/64)))
 235    (pass-if (equal? 'equal (hashx-ref hash assoc table 2/66)))
 236    (pass-if (equal? 'equal (hashx-ref hash assoc table 34)))
 237    (pass-if (string-suffix? " 33/61>"
 238                             (with-output-to-string
 239                               (lambda () (write table)))))))
 240
 241 (with-test-prefix
 242  "hashx"
 243  (pass-if (let ((table (make-hash-table)))
 244             (hashx-set! (lambda (k v) 1)
 245                         (lambda (k al) (assoc 'foo al))
 246                         table 'foo 'bar)
 247             (equal?
 248              'bar (hashx-ref (lambda (k v) 1)
 249                              (lambda (k al) (assoc 'foo al))
 250                              table 'baz))))
 251  (pass-if (let ((table (make-hash-table 31)))
 252             (hashx-set! (lambda (k v) 1) assoc table 'foo 'bar)
 253             (equal? #f
 254                     (hashx-ref (lambda (k v) 2) assoc table 'foo))))
 255  (pass-if (let ((table (make-hash-table)))
 256             (hashx-set! hash assoc table 'foo 'bar)
 257             (equal? #f
 258                     (hashx-ref hash (lambda (k al) #f) table 'foo))))
 259  (pass-if-exception
 260   "hashx-set! (lambda (k s) 1) equal? table 'foo 'bar"
 261   exception:wrong-type-arg ;; there must be a better exception than that...
 262   (hashx-set! (lambda (k s) 1) (lambda (k al) #t) (make-hash-table) 'foo 'bar))
 263  )
 264
 265
 266 ;;;
 267 ;;; hashx-remove!
 268 ;;;
 269 (with-test-prefix "hashx-remove!"
 270   (pass-if (->bool (object-documentation hashx-remove!)))
 271
 272   (pass-if (let ((table (make-hash-table)))
 273              (hashx-set! hashq assq table 'x 123)
 274              (hashx-remove! hashq assq table 'x)
 275              (null? (hash-map->list noop table)))))
 276
 277 ;;;
 278 ;;; hashx
 279 ;;;
 280
 281 (with-test-prefix "hashx"
 282   (pass-if-exception
 283    "hashx-set! (lambda (k s) 1) (lambda (k al) #t) table 'foo 'bar"
 284    exception:wrong-type-arg
 285    (hashx-set! (lambda (k s) 1) (lambda (k al) #t) (make-hash-table) 'foo 'bar))
 286   )
 287
 288
 289 ;;;
 290 ;;; hash-count
 291 ;;;
 292
 293 (with-test-prefix "hash-count"
 294   (let ((table (make-hash-table)))
 295     (hashq-set! table 'foo "bar")
 296     (hashq-set! table 'braz "zonk")
 297     (hashq-create-handle! table 'frob #f)
 298
 299     (pass-if (equal? 3 (hash-count (const #t) table)))
 300
 301     (pass-if (equal? 2 (hash-count (lambda (k v)
 302                                      (string? v)) table)))))