1;;;; hash.test --- test guile hashing -*- scheme -*- 2;;;; 3;;;; Copyright (C) 2004, 2005, 2006, 2008, 2011, 2012, 4;;;; 2014, 2020 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 (with-test-prefix "keyword" 44 (pass-if "equality" 45 (= (hash #:foo most-positive-fixnum) 46 (hash #:foo most-positive-fixnum))) 47 (pass-if "inequality" 48 ;; Inequality cannot be 100% guaranteed but should definitely be 49 ;; met for such a case. 50 (not (= (hash #:foo most-positive-fixnum) 51 (hash #:bar most-positive-fixnum))))) 52 53 (pass-if "cyclic vectors" 54 (let () 55 (define (cyclic-vector n) 56 (let ((v (make-vector n))) 57 (vector-fill! v v) 58 v)) 59 (and (= 0 (hash (cyclic-vector 3) 1)) 60 (= 0 (hash (cyclic-vector 10) 1)))))) 61 62;;; 63;;; hashv 64;;; 65 66(with-test-prefix "hashv" 67 (pass-if (->bool (object-documentation hashv))) 68 (pass-if-exception "hashv #t -1" exception:out-of-range 69 (hashv #t -1)) 70 (pass-if-exception "hashv #t 0" exception:out-of-range 71 (hashv #t 0)) 72 (pass-if (= 0 (hashv #t 1))) 73 (pass-if (= 0 (hashv #f 1))) 74 (pass-if (= 0 (hashv noop 1)))) 75 76;;; 77;;; hashq 78;;; 79 80(with-test-prefix "hashq" 81 (pass-if (->bool (object-documentation hashq))) 82 (pass-if-exception "hashq #t -1" exception:out-of-range 83 (hashq #t -1)) 84 (pass-if-exception "hashq #t 0" exception:out-of-range 85 (hashq #t 0)) 86 (pass-if (= 0 (hashq #t 1))) 87 (pass-if (= 0 (hashq #f 1))) 88 (pass-if (= 0 (hashq noop 1)))) 89 90;;; 91;;; make-hash-table 92;;; 93 94(with-test-prefix 95 "make-hash-table, hash-table?" 96 (pass-if-exception "make-hash-table -1" exception:out-of-range 97 (make-hash-table -1)) 98 (pass-if (hash-table? (make-hash-table 0))) ;; default 99 (pass-if (not (hash-table? 'not-a-hash-table))) 100 (pass-if (string-suffix? " 0/113>" 101 (with-output-to-string 102 (lambda () 103 (write (make-hash-table 100))))))) 104 105;;; 106;;; alist->hash-table 107;;; 108 109(with-test-prefix 110 "alist conversion" 111 112 (pass-if "alist->hash-table" 113 (let ((table (alist->hash-table '(("foo" . 1) 114 ("bar" . 2) 115 ("foo" . 3))))) 116 (and (= (hash-ref table "foo") 1) 117 (= (hash-ref table "bar") 2)))) 118 119 (pass-if "alist->hashq-table" 120 (let ((table (alist->hashq-table '((foo . 1) 121 (bar . 2) 122 (foo . 3))))) 123 (and (= (hashq-ref table 'foo) 1) 124 (= (hashq-ref table 'bar) 2)))) 125 126 (pass-if "alist->hashv-table" 127 (let ((table (alist->hashv-table '((1 . 1) 128 (2 . 2) 129 (1 . 3))))) 130 (and (= (hashv-ref table 1) 1) 131 (= (hashv-ref table 2) 2)))) 132 133 (pass-if "alist->hashx-table" 134 (let ((table (alist->hashx-table hash assoc '((foo . 1) 135 (bar . 2) 136 (foo . 3))))) 137 (and (= (hashx-ref hash assoc table 'foo) 1) 138 (= (hashx-ref hash assoc table 'bar) 2))))) 139 140;;; 141;;; usual set and reference 142;;; 143 144(with-test-prefix 145 "hash-set and hash-ref" 146 147 ;; auto-resizing 148 (pass-if (let ((table (make-hash-table 1))) ;;actually makes size 31 149 (hash-set! table 'one 1) 150 (hash-set! table 'two #t) 151 (hash-set! table 'three #t) 152 (hash-set! table 'four #t) 153 (hash-set! table 'five #t) 154 (hash-set! table 'six #t) 155 (hash-set! table 'seven #t) 156 (hash-set! table 'eight #t) 157 (hash-set! table 'nine 9) 158 (hash-set! table 'ten #t) 159 (hash-set! table 'eleven #t) 160 (hash-set! table 'twelve #t) 161 (hash-set! table 'thirteen #t) 162 (hash-set! table 'fourteen #t) 163 (hash-set! table 'fifteen #t) 164 (hash-set! table 'sixteen #t) 165 (hash-set! table 'seventeen #t) 166 (hash-set! table 18 #t) 167 (hash-set! table 19 #t) 168 (hash-set! table 20 #t) 169 (hash-set! table 21 #t) 170 (hash-set! table 22 #t) 171 (hash-set! table 23 #t) 172 (hash-set! table 24 #t) 173 (hash-set! table 25 #t) 174 (hash-set! table 26 #t) 175 (hash-set! table 27 #t) 176 (hash-set! table 28 #t) 177 (hash-set! table 29 #t) 178 (hash-set! table 30 'thirty) 179 (hash-set! table 31 #t) 180 (hash-set! table 32 #t) 181 (hash-set! table 33 'thirty-three) 182 (hash-set! table 34 #t) 183 (hash-set! table 35 #t) 184 (hash-set! table 'foo 'bar) 185 (and (equal? 1 (hash-ref table 'one)) 186 (equal? 9 (hash-ref table 'nine)) 187 (equal? 'thirty (hash-ref table 30)) 188 (equal? 'thirty-three (hash-ref table 33)) 189 (equal? 'bar (hash-ref table 'foo)) 190 (string-suffix? " 36/61>" 191 (with-output-to-string 192 (lambda () (write table))))))) 193 194 ;; 1 and 1 are equal? and eqv? (but not necessarily eq?) 195 (pass-if (equal? 'foo 196 (let ((table (make-hash-table))) 197 (hash-set! table 1 'foo) 198 (hash-ref table 1)))) 199 (pass-if (equal? 'foo 200 (let ((table (make-hash-table))) 201 (hashv-set! table 1 'foo) 202 (hashv-ref table 1)))) 203 204 ;; 1/2 and 2/4 are equal? and eqv? (but not necessarily eq?) 205 (pass-if (equal? 'foo 206 (let ((table (make-hash-table))) 207 (hash-set! table 1/2 'foo) 208 (hash-ref table 2/4)))) 209 (pass-if (equal? 'foo 210 (let ((table (make-hash-table))) 211 (hashv-set! table 1/2 'foo) 212 (hashv-ref table 2/4)))) 213 214 ;; (list 1 2) is equal? but not eqv? or eq? to another (list 1 2) 215 (pass-if (equal? 'foo 216 (let ((table (make-hash-table))) 217 (hash-set! table (list 1 2) 'foo) 218 (hash-ref table (list 1 2))))) 219 (pass-if (equal? #f 220 (let ((table (make-hash-table))) 221 (hashv-set! table (list 1 2) 'foo) 222 (hashv-ref table (list 1 2))))) 223 (pass-if (equal? #f 224 (let ((table (make-hash-table))) 225 (hashq-set! table (list 1 2) 'foo) 226 (hashq-ref table (list 1 2))))) 227 228 ;; ref default argument 229 (pass-if (equal? 'bar 230 (let ((table (make-hash-table))) 231 (hash-ref table 'foo 'bar)))) 232 (pass-if (equal? 'bar 233 (let ((table (make-hash-table))) 234 (hashv-ref table 'foo 'bar)))) 235 (pass-if (equal? 'bar 236 (let ((table (make-hash-table))) 237 (hashq-ref table 'foo 'bar)))) 238 (pass-if (equal? 'bar 239 (let ((table (make-hash-table))) 240 (hashx-ref hash equal? table 'foo 'bar)))) 241 242 ;; wrong type argument 243 (pass-if-exception "(hash-ref 'not-a-table 'key)" exception:wrong-type-arg 244 (hash-ref 'not-a-table 'key)) 245 ) 246 247;;; 248;;; hashx 249;;; 250 251(with-test-prefix 252 "auto-resizing hashx" 253 ;; auto-resizing 254 (let ((table (make-hash-table 1))) ;;actually makes size 31 255 (hashx-set! hash assoc table 1/2 'equal) 256 (hashx-set! hash assoc table 1/3 'equal) 257 (hashx-set! hash assoc table 4 'equal) 258 (hashx-set! hash assoc table 1/5 'equal) 259 (hashx-set! hash assoc table 1/6 'equal) 260 (hashx-set! hash assoc table 7 'equal) 261 (hashx-set! hash assoc table 1/8 'equal) 262 (hashx-set! hash assoc table 1/9 'equal) 263 (hashx-set! hash assoc table 10 'equal) 264 (hashx-set! hash assoc table 1/11 'equal) 265 (hashx-set! hash assoc table 1/12 'equal) 266 (hashx-set! hash assoc table 13 'equal) 267 (hashx-set! hash assoc table 1/14 'equal) 268 (hashx-set! hash assoc table 1/15 'equal) 269 (hashx-set! hash assoc table 16 'equal) 270 (hashx-set! hash assoc table 1/17 'equal) 271 (hashx-set! hash assoc table 1/18 'equal) 272 (hashx-set! hash assoc table 19 'equal) 273 (hashx-set! hash assoc table 1/20 'equal) 274 (hashx-set! hash assoc table 1/21 'equal) 275 (hashx-set! hash assoc table 22 'equal) 276 (hashx-set! hash assoc table 1/23 'equal) 277 (hashx-set! hash assoc table 1/24 'equal) 278 (hashx-set! hash assoc table 25 'equal) 279 (hashx-set! hash assoc table 1/26 'equal) 280 (hashx-set! hash assoc table 1/27 'equal) 281 (hashx-set! hash assoc table 28 'equal) 282 (hashx-set! hash assoc table 1/29 'equal) 283 (hashx-set! hash assoc table 1/30 'equal) 284 (hashx-set! hash assoc table 31 'equal) 285 (hashx-set! hash assoc table 1/32 'equal) 286 (hashx-set! hash assoc table 1/33 'equal) 287 (hashx-set! hash assoc table 34 'equal) 288 (pass-if (equal? 'equal (hash-ref table 2/4))) 289 (pass-if (equal? 'equal (hash-ref table 2/6))) 290 (pass-if (equal? 'equal (hash-ref table 4))) 291 (pass-if (equal? 'equal (hashx-ref hash assoc table 2/64))) 292 (pass-if (equal? 'equal (hashx-ref hash assoc table 2/66))) 293 (pass-if (equal? 'equal (hashx-ref hash assoc table 34))) 294 (pass-if (string-suffix? " 33/61>" 295 (with-output-to-string 296 (lambda () (write table))))))) 297 298(with-test-prefix 299 "hashx" 300 (pass-if (let ((table (make-hash-table))) 301 (hashx-set! (lambda (k v) 1) 302 (lambda (k al) (assoc 'foo al)) 303 table 'foo 'bar) 304 (equal? 305 'bar (hashx-ref (lambda (k v) 1) 306 (lambda (k al) (assoc 'foo al)) 307 table 'baz)))) 308 (pass-if (let ((table (make-hash-table 31))) 309 (hashx-set! (lambda (k v) 1) assoc table 'foo 'bar) 310 (equal? #f 311 (hashx-ref (lambda (k v) 2) assoc table 'foo)))) 312 (pass-if (let ((table (make-hash-table))) 313 (hashx-set! hash assoc table 'foo 'bar) 314 (equal? #f 315 (hashx-ref hash (lambda (k al) #f) table 'foo)))) 316 (pass-if-exception 317 "hashx-set! (lambda (k s) 1) equal? table 'foo 'bar" 318 exception:wrong-type-arg ;; there must be a better exception than that... 319 (hashx-set! (lambda (k s) 1) (lambda (k al) #t) (make-hash-table) 'foo 'bar)) 320 ) 321 322 323;;; 324;;; hashx-remove! 325;;; 326(with-test-prefix "hashx-remove!" 327 (pass-if (->bool (object-documentation hashx-remove!))) 328 329 (pass-if (let ((table (make-hash-table))) 330 (hashx-set! hashq assq table 'x 123) 331 (hashx-remove! hashq assq table 'x) 332 (null? (hash-map->list noop table))))) 333 334;;; 335;;; hashx 336;;; 337 338(with-test-prefix "hashx" 339 (pass-if-exception 340 "hashx-set! (lambda (k s) 1) (lambda (k al) #t) table 'foo 'bar" 341 exception:wrong-type-arg 342 (hashx-set! (lambda (k s) 1) (lambda (k al) #t) (make-hash-table) 'foo 'bar)) 343 ) 344 345 346;;; 347;;; hash-count 348;;; 349 350(with-test-prefix "hash-count" 351 (let ((table (make-hash-table))) 352 (hashq-set! table 'foo "bar") 353 (hashq-set! table 'braz "zonk") 354 (hashq-create-handle! table 'frob #f) 355 356 (pass-if (equal? 3 (hash-count (const #t) table))) 357 358 (pass-if (equal? 2 (hash-count (lambda (k v) 359 (string? v)) table))))) 360 361;;; 362;;; weak key hash table 363;;; 364 365(with-test-prefix "weak key hash table" 366 (pass-if "hash-for-each after gc" 367 (let ((table (make-weak-key-hash-table))) 368 (hashq-set! table (list 'foo) 'bar) 369 (gc) 370 ;; Iterate over deleted weak ref without crashing. 371 (unspecified? (hash-for-each (lambda (key value) key) table))))) 372