test-suite/tests/hash.test

   1 ;;;; hash.test --- test guile hashing     -*- scheme -*-
   2 ;;;;
   3 ;;;; Copyright (C) 2004, 2005, 2006, 2008, 2011, 2012,
   4 ;;;;   2014 Free Software Foundation, Inc.
   5 ;;;;
   6 ;;;; This library is free software; you can redistribute it and/or
   7 ;;;; modify it under the terms of the GNU Lesser General Public
   8 ;;;; License as published by the Free Software Foundation; either
   9 ;;;; version 3 of the License, or (at your option) any later version.
  10 ;;;;
  11 ;;;; This library is distributed in the hope that it will be useful,
  12 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  14 ;;;; Lesser General Public License for more details.
  15 ;;;;
  16 ;;;; You should have received a copy of the GNU Lesser General Public
  17 ;;;; License along with this library; if not, write to the Free Software
  18 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  19
  20 (define-module (test-suite test-numbers)
  21   #:use-module (test-suite lib)
  22   #:use-module (ice-9 documentation)
  23   #:use-module (ice-9 hash-table))
  24
  25 ;;;
  26 ;;; hash
  27 ;;;
  28
  29 (with-test-prefix "hash"
  30   (pass-if (->bool (object-documentation hash)))
  31   (pass-if-exception "hash #t -1" exception:out-of-range
  32     (hash #t -1))
  33   (pass-if-exception "hash #t 0" exception:out-of-range
  34     (hash #t 0))
  35   (pass-if (= 0 (hash #t 1)))
  36   (pass-if (= 0 (hash #f 1)))
  37   (pass-if (= 0 (hash noop 1)))
  38   (pass-if (= 0 (hash +inf.0 1)))
  39   (pass-if (= 0 (hash -inf.0 1)))
  40   (pass-if (= 0 (hash +nan.0 1)))
  41   (pass-if (= 0 (hash '#() 1)))
  42
  43   (pass-if "cyclic vectors"
  44     (let ()
  45       (define (cyclic-vector n)
  46         (let ((v (make-vector n)))
  47           (vector-fill! v v)
  48           v))
  49       (and (= 0 (hash (cyclic-vector 3) 1))
  50            (= 0 (hash (cyclic-vector 10) 1))))))
  51
  52 ;;;
  53 ;;; hashv
  54 ;;;
  55
  56 (with-test-prefix "hashv"
  57   (pass-if (->bool (object-documentation hashv)))
  58   (pass-if-exception "hashv #t -1" exception:out-of-range
  59     (hashv #t -1))
  60   (pass-if-exception "hashv #t 0" exception:out-of-range
  61     (hashv #t 0))
  62   (pass-if (= 0 (hashv #t 1)))
  63   (pass-if (= 0 (hashv #f 1)))
  64   (pass-if (= 0 (hashv noop 1))))
  65
  66 ;;;
  67 ;;; hashq
  68 ;;;
  69
  70 (with-test-prefix "hashq"
  71   (pass-if (->bool (object-documentation hashq)))
  72   (pass-if-exception "hashq #t -1" exception:out-of-range
  73     (hashq #t -1))
  74   (pass-if-exception "hashq #t 0" exception:out-of-range
  75     (hashq #t 0))
  76   (pass-if (= 0 (hashq #t 1)))
  77   (pass-if (= 0 (hashq #f 1)))
  78   (pass-if (= 0 (hashq noop 1))))
  79
  80 ;;;
  81 ;;; make-hash-table
  82 ;;;
  83
  84 (with-test-prefix
  85  "make-hash-table, hash-table?"
  86  (pass-if-exception "make-hash-table -1" exception:out-of-range
  87                     (make-hash-table -1))
  88  (pass-if (hash-table? (make-hash-table 0))) ;; default
  89  (pass-if (not (hash-table? 'not-a-hash-table)))
  90  (pass-if (string-suffix? " 0/113>"
  91                           (with-output-to-string
  92                             (lambda ()
  93                               (write (make-hash-table 100)))))))
  94
  95 ;;;
  96 ;;; alist->hash-table
  97 ;;;
  98
  99 (with-test-prefix
 100   "alist conversion"
 101
 102   (pass-if "alist->hash-table"
 103     (let ((table (alist->hash-table '(("foo" . 1)
 104                                       ("bar" . 2)
 105                                       ("foo" . 3)))))
 106       (and (= (hash-ref table "foo") 1)
 107            (= (hash-ref table "bar") 2))))
 108
 109   (pass-if "alist->hashq-table"
 110     (let ((table (alist->hashq-table '((foo . 1)
 111                                        (bar . 2)
 112                                        (foo . 3)))))
 113       (and (= (hashq-ref table 'foo) 1)
 114            (= (hashq-ref table 'bar) 2))))
 115
 116   (pass-if "alist->hashv-table"
 117     (let ((table (alist->hashv-table '((1 . 1)
 118                                        (2 . 2)
 119                                        (1 . 3)))))
 120       (and (= (hashv-ref table 1) 1)
 121            (= (hashv-ref table 2) 2))))
 122
 123   (pass-if "alist->hashx-table"
 124     (let ((table (alist->hashx-table hash assoc '((foo . 1)
 125                                                   (bar . 2)
 126                                                   (foo . 3)))))
 127       (and (= (hashx-ref hash assoc table 'foo) 1)
 128            (= (hashx-ref hash assoc table 'bar) 2)))))
 129
 130 ;;;
 131 ;;; usual set and reference
 132 ;;;
 133
 134 (with-test-prefix
 135  "hash-set and hash-ref"
 136
 137  ;; auto-resizing
 138  (pass-if (let ((table (make-hash-table 1))) ;;actually makes size 31
 139             (hash-set! table 'one 1)
 140             (hash-set! table 'two #t)
 141             (hash-set! table 'three #t)
 142             (hash-set! table 'four #t)
 143             (hash-set! table 'five #t)
 144             (hash-set! table 'six #t)
 145             (hash-set! table 'seven #t)
 146             (hash-set! table 'eight #t)
 147             (hash-set! table 'nine 9)
 148             (hash-set! table 'ten #t)
 149             (hash-set! table 'eleven #t)
 150             (hash-set! table 'twelve #t)
 151             (hash-set! table 'thirteen #t)
 152             (hash-set! table 'fourteen #t)
 153             (hash-set! table 'fifteen #t)
 154             (hash-set! table 'sixteen #t)
 155             (hash-set! table 'seventeen #t)
 156             (hash-set! table 18 #t)
 157             (hash-set! table 19 #t)
 158             (hash-set! table 20 #t)
 159             (hash-set! table 21 #t)
 160             (hash-set! table 22 #t)
 161             (hash-set! table 23 #t)
 162             (hash-set! table 24 #t)
 163             (hash-set! table 25 #t)
 164             (hash-set! table 26 #t)
 165             (hash-set! table 27 #t)
 166             (hash-set! table 28 #t)
 167             (hash-set! table 29 #t)
 168             (hash-set! table 30 'thirty)
 169             (hash-set! table 31 #t)
 170             (hash-set! table 32 #t)
 171             (hash-set! table 33 'thirty-three)
 172             (hash-set! table 34 #t)
 173             (hash-set! table 35 #t)
 174             (hash-set! table 'foo 'bar)
 175             (and (equal? 1 (hash-ref table 'one))
 176                  (equal? 9 (hash-ref table 'nine))
 177                  (equal? 'thirty (hash-ref table 30))
 178                  (equal? 'thirty-three (hash-ref table 33))
 179                  (equal? 'bar (hash-ref table 'foo))
 180                  (string-suffix? " 36/61>"
 181                                  (with-output-to-string
 182                                    (lambda () (write table)))))))
 183
 184  ;; 1 and 1 are equal? and eqv? (but not necessarily eq?)
 185  (pass-if (equal? 'foo
 186                   (let ((table (make-hash-table)))
 187                     (hash-set! table 1 'foo)
 188                     (hash-ref table 1))))
 189  (pass-if (equal? 'foo
 190                   (let ((table (make-hash-table)))
 191                     (hashv-set! table 1 'foo)
 192                     (hashv-ref table 1))))
 193
 194  ;; 1/2 and 2/4 are equal? and eqv? (but not necessarily eq?)
 195  (pass-if (equal? 'foo
 196                   (let ((table (make-hash-table)))
 197                     (hash-set! table 1/2 'foo)
 198                     (hash-ref table 2/4))))
 199  (pass-if (equal? 'foo
 200                   (let ((table (make-hash-table)))
 201                     (hashv-set! table 1/2 'foo)
 202                     (hashv-ref table 2/4))))
 203
 204  ;; (list 1 2) is equal? but not eqv? or eq? to another (list 1 2)
 205  (pass-if (equal? 'foo
 206                   (let ((table (make-hash-table)))
 207                     (hash-set! table (list 1 2) 'foo)
 208                     (hash-ref table (list 1 2)))))
 209  (pass-if (equal? #f
 210                   (let ((table (make-hash-table)))
 211                     (hashv-set! table (list 1 2) 'foo)
 212                     (hashv-ref table (list 1 2)))))
 213  (pass-if (equal? #f
 214                   (let ((table (make-hash-table)))
 215                     (hashq-set! table (list 1 2) 'foo)
 216                     (hashq-ref table (list 1 2)))))
 217
 218  ;; ref default argument
 219  (pass-if (equal? 'bar
 220                   (let ((table (make-hash-table)))
 221                     (hash-ref table 'foo 'bar))))
 222  (pass-if (equal? 'bar
 223                   (let ((table (make-hash-table)))
 224                     (hashv-ref table 'foo 'bar))))
 225  (pass-if (equal? 'bar
 226                   (let ((table (make-hash-table)))
 227                     (hashq-ref table 'foo 'bar))))
 228  (pass-if (equal? 'bar
 229                   (let ((table (make-hash-table)))
 230                     (hashx-ref hash equal? table 'foo 'bar))))
 231
 232  ;; wrong type argument
 233  (pass-if-exception "(hash-ref 'not-a-table 'key)" exception:wrong-type-arg
 234                     (hash-ref 'not-a-table 'key))
 235  )
 236
 237 ;;;
 238 ;;; hashx
 239 ;;;
 240
 241 (with-test-prefix
 242  "auto-resizing hashx"
 243  ;; auto-resizing
 244  (let ((table (make-hash-table 1))) ;;actually makes size 31
 245    (hashx-set! hash assoc table 1/2 'equal)
 246    (hashx-set! hash assoc table 1/3 'equal)
 247    (hashx-set! hash assoc table 4 'equal)
 248    (hashx-set! hash assoc table 1/5 'equal)
 249    (hashx-set! hash assoc table 1/6 'equal)
 250    (hashx-set! hash assoc table 7 'equal)
 251    (hashx-set! hash assoc table 1/8 'equal)
 252    (hashx-set! hash assoc table 1/9 'equal)
 253    (hashx-set! hash assoc table 10 'equal)
 254    (hashx-set! hash assoc table 1/11 'equal)
 255    (hashx-set! hash assoc table 1/12 'equal)
 256    (hashx-set! hash assoc table 13 'equal)
 257    (hashx-set! hash assoc table 1/14 'equal)
 258    (hashx-set! hash assoc table 1/15 'equal)
 259    (hashx-set! hash assoc table 16 'equal)
 260    (hashx-set! hash assoc table 1/17 'equal)
 261    (hashx-set! hash assoc table 1/18 'equal)
 262    (hashx-set! hash assoc table 19 'equal)
 263    (hashx-set! hash assoc table 1/20 'equal)
 264    (hashx-set! hash assoc table 1/21 'equal)
 265    (hashx-set! hash assoc table 22 'equal)
 266    (hashx-set! hash assoc table 1/23 'equal)
 267    (hashx-set! hash assoc table 1/24 'equal)
 268    (hashx-set! hash assoc table 25 'equal)
 269    (hashx-set! hash assoc table 1/26 'equal)
 270    (hashx-set! hash assoc table 1/27 'equal)
 271    (hashx-set! hash assoc table 28 'equal)
 272    (hashx-set! hash assoc table 1/29 'equal)
 273    (hashx-set! hash assoc table 1/30 'equal)
 274    (hashx-set! hash assoc table 31 'equal)
 275    (hashx-set! hash assoc table 1/32 'equal)
 276    (hashx-set! hash assoc table 1/33 'equal)
 277    (hashx-set! hash assoc table 34 'equal)
 278    (pass-if (equal? 'equal (hash-ref table 2/4)))
 279    (pass-if (equal? 'equal (hash-ref table 2/6)))
 280    (pass-if (equal? 'equal (hash-ref table 4)))
 281    (pass-if (equal? 'equal (hashx-ref hash assoc table 2/64)))
 282    (pass-if (equal? 'equal (hashx-ref hash assoc table 2/66)))
 283    (pass-if (equal? 'equal (hashx-ref hash assoc table 34)))
 284    (pass-if (string-suffix? " 33/61>"
 285                             (with-output-to-string
 286                               (lambda () (write table)))))))
 287
 288 (with-test-prefix
 289  "hashx"
 290  (pass-if (let ((table (make-hash-table)))
 291             (hashx-set! (lambda (k v) 1)
 292                         (lambda (k al) (assoc 'foo al))
 293                         table 'foo 'bar)
 294             (equal?
 295              'bar (hashx-ref (lambda (k v) 1)
 296                              (lambda (k al) (assoc 'foo al))
 297                              table 'baz))))
 298  (pass-if (let ((table (make-hash-table 31)))
 299             (hashx-set! (lambda (k v) 1) assoc table 'foo 'bar)
 300             (equal? #f
 301                     (hashx-ref (lambda (k v) 2) assoc table 'foo))))
 302  (pass-if (let ((table (make-hash-table)))
 303             (hashx-set! hash assoc table 'foo 'bar)
 304             (equal? #f
 305                     (hashx-ref hash (lambda (k al) #f) table 'foo))))
 306  (pass-if-exception
 307   "hashx-set! (lambda (k s) 1) equal? table 'foo 'bar"
 308   exception:wrong-type-arg ;; there must be a better exception than that...
 309   (hashx-set! (lambda (k s) 1) (lambda (k al) #t) (make-hash-table) 'foo 'bar))
 310  )
 311
 312
 313 ;;;
 314 ;;; hashx-remove!
 315 ;;;
 316 (with-test-prefix "hashx-remove!"
 317   (pass-if (->bool (object-documentation hashx-remove!)))
 318
 319   (pass-if (let ((table (make-hash-table)))
 320              (hashx-set! hashq assq table 'x 123)
 321              (hashx-remove! hashq assq table 'x)
 322              (null? (hash-map->list noop table)))))
 323
 324 ;;;
 325 ;;; hashx
 326 ;;;
 327
 328 (with-test-prefix "hashx"
 329   (pass-if-exception
 330    "hashx-set! (lambda (k s) 1) (lambda (k al) #t) table 'foo 'bar"
 331    exception:wrong-type-arg
 332    (hashx-set! (lambda (k s) 1) (lambda (k al) #t) (make-hash-table) 'foo 'bar))
 333   )
 334
 335
 336 ;;;
 337 ;;; hash-count
 338 ;;;
 339
 340 (with-test-prefix "hash-count"
 341   (let ((table (make-hash-table)))
 342     (hashq-set! table 'foo "bar")
 343     (hashq-set! table 'braz "zonk")
 344     (hashq-create-handle! table 'frob #f)
 345
 346     (pass-if (equal? 3 (hash-count (const #t) table)))
 347
 348     (pass-if (equal? 2 (hash-count (lambda (k v)
 349                                      (string? v)) table)))))