source: project/release/5/srfi-69/trunk/tests/hash-table-tests.scm @ 31403

Last change on this file since 31403 was 31403, checked in by felix winkelmann, 6 years ago

added srfi-18 and srfi-69 eggs

File size: 9.3 KB
Line 
1;;;; hash-table-tests.scm
2
3(require-extension srfi-69 data-structures extras)
4
5(print "SRFI 69 procedures")
6(assert (eq? hash equal?-hash))
7(assert (eq? hash-by-identity eq?-hash))
8
9;; Re-use variable
10(define ht)
11
12(print "HT - No Parameters")
13(set! ht (make-hash-table))
14(assert (hash-table? ht))
15(assert (eq? equal? (hash-table-equivalence-function ht)))
16(assert (eq? equal?-hash (hash-table-hash-function ht)))
17(assert (not (hash-table-has-initial? ht)))
18
19(print "HT - Test Parameter")
20(set! ht (make-hash-table eq?))
21(assert (hash-table? ht))
22(assert (eq? eq? (hash-table-equivalence-function ht)))
23(assert (eq? eq?-hash (hash-table-hash-function ht)))
24(assert (not (hash-table-has-initial? ht)))
25
26(print "HT - Number Test Parameter")
27(set! ht (make-hash-table =))
28(assert (hash-table? ht))
29(assert (eq? = (hash-table-equivalence-function ht)))
30(assert (eq? number-hash (hash-table-hash-function ht)))
31(assert (not (hash-table-has-initial? ht)))
32
33(print "HT - All Optional Parameters")
34(set! ht (make-hash-table eqv? eqv?-hash 23))
35(assert (hash-table? ht))
36(assert (not (hash-table-has-initial? ht)))
37
38(print "HT - All Parameters")
39(set! ht (make-hash-table eqv? eqv?-hash 23
40                          #:test equal? #:hash equal?-hash
41                          #:initial 'foo
42                          #:size 500
43                          #:min-load 0.45 #:max-load 0.85
44                          #:weak-keys #t #:weak-values #t))
45(assert (hash-table? ht))
46(assert (not (hash-table-weak-keys ht)))
47(assert (not (hash-table-weak-values ht)))
48(assert (eq? equal? (hash-table-equivalence-function ht)))
49(assert (eq? equal?-hash (hash-table-hash-function ht)))
50(assert (hash-table-has-initial? ht))
51(assert (eq? (hash-table-initial ht) 'foo))
52
53(print "HT - Insert with setter")
54(set! (hash-table-ref ht 23.0) 'bar)
55(assert (eq? (hash-table-ref ht 23.0) 'bar))
56
57(print "HT - Insert with update!")
58(hash-table-update! ht 'baz identity (lambda () 'foo))
59(assert (eq? (hash-table-ref ht 'baz) 'foo))
60(assert (= (hash-table-size ht) 2))
61
62(print "HT - A-List")
63(let ([alist (hash-table->alist ht)])
64  (assert (list? alist))
65  (assert (= (length alist) 2))
66  (assert (eq? (alist-ref 23.0 alist) 'bar))
67  (assert (eq? (alist-ref 'baz alist) 'foo)) )
68
69(print "HT - set! overwrites")
70(hash-table-set! ht 23.0 'foo-bar)
71(assert (eq? (hash-table-ref ht 23.0) 'foo-bar))
72
73(print "HT - Delete")
74(assert (hash-table-delete! ht 23.0))
75(assert (not (hash-table-exists? ht 23.0)))
76(assert (= (hash-table-size ht) 1))
77
78(print "HT - Remove")
79(assert (hash-table-remove! ht (lambda (k v) (eq? k 'baz))))
80(assert (not (hash-table-exists? ht 'baz)))
81(assert (= (hash-table-size ht) 0))
82
83(print "HT - Make from A-List")
84(set! ht (alist->hash-table '(("abc" . #t) ("cbs" . #t) ("cnn" . #f))))
85(assert (hash-table? ht))
86(assert (= (hash-table-size ht) 3))
87
88(print "HT - Merge!")
89(let ([ht2 (make-hash-table)])
90  (set! (hash-table-ref ht2 23.0) 'bar)
91  (set! (hash-table-ref ht2 'baz) 'foo)
92  (let ([ht3 (hash-table-merge! ht2 ht)])
93    (assert (eq? ht3 ht2))
94    (assert (not (eq? ht3 ht)))
95    (let ([alist (hash-table->alist ht3)])
96      (assert (list? alist))
97      (assert (= (length alist) 5))
98      (assert (eq? (alist-ref "abc" alist equal?) #t))
99      (assert (eq? (alist-ref "cbs" alist equal?) #t))
100      (assert (eq? (alist-ref "cnn" alist equal?) #f))
101      (assert (eq? (alist-ref 23.0 alist) 'bar))
102      (assert (eq? (alist-ref 'baz alist) 'foo)) ) ) )
103
104(print "HT - Merge")
105(let ([ht2 (make-hash-table)])
106  (set! (hash-table-ref ht2 23.0) 'bar)
107  (set! (hash-table-ref ht2 'baz) 'foo)
108  (let ([ht3 (hash-table-merge ht2 ht)])
109    (assert (not (eq? ht3 ht2)))
110    (assert (not (eq? ht3 ht)))
111    (let ([alist (hash-table->alist ht3)])
112      (assert (list? alist))
113      (assert (= (length alist) 5))
114      (assert (eq? (alist-ref "abc" alist equal?) #t))
115      (assert (eq? (alist-ref "cbs" alist equal?) #t))
116      (assert (eq? (alist-ref "cnn" alist equal?) #f))
117      (assert (eq? (alist-ref 23.0 alist) 'bar))
118      (assert (eq? (alist-ref 'baz alist) 'foo)) ) ) )
119
120(print "HT - Map")
121(let ([alist (hash-table-map ht (lambda (k v) (cons k v)))])
122  (assert (list? alist))
123  (assert (= (length alist) 3)) )
124
125(print "HT - Fold")
126(let ([alist (hash-table-fold ht (lambda (k v a) (cons (cons k v) a)) '())])
127  (assert (list? alist))
128  (assert (= (length alist) 3)) )
129
130(print "HT - Built-in string hash function")
131(set! ht (make-hash-table string=?))
132(hash-table-set! ht "test" 123)
133(hash-table-set! ht "one" 1)
134(assert (= 123 (hash-table-ref ht "test")))
135(assert (= 1 (hash-table-ref ht "one")))
136
137;; Issue #818, found by Jim Ursetto (srfi-13 defines its own string-hash)
138(print "HT - After overwriting 'string-hash' should still work")
139(set! string-hash (lambda (x) (error "Wrong string-hash called")))
140(set! ht (make-hash-table string=?))
141(hash-table-set! ht "foo" "bar")
142(assert (string=? (hash-table-ref ht "foo") "bar"))
143
144(set! ht (make-hash-table equal? (lambda (object bounds)
145                                   (case object
146                                     ((test) 0)
147                                     ((one two) 1)
148                                     (else (+ bounds 1))))))
149(print "HT - custom hash function")
150(hash-table-set! ht 'test 123)
151(hash-table-set! ht 'one 1)
152(hash-table-set! ht 'two 2)
153(assert (= 123 (hash-table-ref ht 'test)))
154(assert (= 1 (hash-table-ref ht 'one)))
155(assert (= 2 (hash-table-ref ht 'two)))
156
157(print "HT - out of bounds value is caught")
158(assert (handle-exceptions exn #t (hash-table-set! ht 'out-of-bounds 123) #f))
159
160(print "Hash collision weaknesses")
161;; If these fail, it might be bad luck caused by the randomization/modulo combo
162;; So don't *immediately* dismiss a hash implementation when it fails here
163(assert (not (= (hash "a" 10 1) (hash "a" 10 2))))
164(assert (not (= (hash (make-string 1 #\nul) 10 10) 0)))
165;; Long identical suffixes should not hash to the same value
166(assert (not (= (hash (string-append (make-string 1000000 #\a)
167                                     (make-string 1000000 #\c)) 10 1)
168                (hash (string-append (make-string 1000000 #\b)
169                                     (make-string 1000000 #\c)) 10 1))))
170;; Same for prefixes
171(assert (not (= (hash (string-append (make-string 1000000 #\a)
172                                     (make-string 1000000 #\b)) 10 1)
173                (hash (string-append (make-string 1000000 #\a)
174                                     (make-string 1000000 #\c)) 10 1))))
175;; And palindromes, too
176(assert (not (= (hash (string-append (make-string 1000000 #\a)
177                                     (make-string 1000000 #\b)
178                                     (make-string 1000000 #\a)) 10 1)
179                (hash (string-append (make-string 1000000 #\a)
180                                     (make-string 1000000 #\c)
181                                     (make-string 1000000 #\a)) 10 1))))
182;; differing number of nul bytes should not be identical
183(assert (not (= (hash (make-string 1 #\nul) 10 1)
184                (hash (make-string 2 #\nul) 10 1))))
185;; ensure very long NUL strings don't cause the random value to get pushed out
186(assert (not (= (hash (make-string 1000000 #\nul) 10 1)
187                (hash (make-string 1000001  #\nul) 10 1))))
188
189;; Stress Test
190
191(set! ht (make-hash-table))
192
193(define-constant stress-size 100000)
194
195(print "HT - Stress Insert " stress-size " Fixnum Key Items")
196(time
197  (do ([i 0 (fx+ i 1)])
198      [(fx= i stress-size)]
199    (set! (hash-table-ref ht i) i) ) )
200
201(print "HT - Stress Retrieve " stress-size " Fixnum Key Items")
202(time
203  (do ([i 0 (fx+ i 1)])
204      [(fx= i stress-size)]
205    (assert (fx= i (hash-table-ref ht i))) ) )
206
207(print "HT - copy")
208(define l '((1 a) (2 b) (3 c)))
209(set! ht (alist->hash-table l))
210(define ht2 (hash-table-copy ht))
211(assert (= (hash-table-size ht2) (hash-table-size ht)))
212(print l " -- " (hash-table->alist ht2))
213(assert (equal? l (sort (hash-table->alist ht2)
214                        (lambda (e1 e2) (< (car e1) (car e2))))))
215;; Ensure that lookup still works (#905, randomization value was reset)
216(assert (equal? '(a) (hash-table-ref ht2 1)))
217
218(print "HT - recursive depth/length")
219(assert (fixnum? (recursive-hash-max-depth)))
220(assert (positive? (recursive-hash-max-depth)))
221(assert (fixnum? (recursive-hash-max-length)))
222(assert (positive? (recursive-hash-max-length)))
223
224(let ((dd (recursive-hash-max-depth))
225      (tls (list (random 100000) (random 100000) (list (random 100000) (list (random 100000) (list (random 100000) (list (random 100000) (list (random 100000) (list (random 100000) (list (random 100000) (list (random 100000) (list (random 100000) (list (random 100000) (list (random 100000) (list (random 100000))))))))))))))))
226  (let ((hsh1 (equal?-hash tls 536870912 0)))
227    (recursive-hash-max-depth 10)
228    (assert (fx= 10 (recursive-hash-max-depth)))
229    (let ((hsh2 (equal?-hash tls 536870912 0)))
230      (recursive-hash-max-depth dd)
231      (print hsh1 " <?> " hsh2)
232      (assert (not (= hsh1 hsh2))) ) ) )
233
234(let ((dl (recursive-hash-max-length))
235      (tv (vector (random 100000) (random 100000) (random 100000) (random 100000) (random 100000) (random 100000) (random 100000) (random 100000) (random 100000) (random 100000) (random 100000) (random 100000))))
236  (let ((hsh1 (equal?-hash tv 536870912 0)))
237    (recursive-hash-max-length 10)
238    (assert (fx= 10 (recursive-hash-max-length)))
239    (let ((hsh2 (equal?-hash tv 536870912 0)))
240      (recursive-hash-max-length dl)
241      (print hsh1 " <?> " hsh2)
242      (assert (not (= hsh1 hsh2))) ) ) )
Note: See TracBrowser for help on using the repository browser.