Commit | Line | Data |
---|---|---|
2b95784c JG |
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)) | |
3fdc1d05 JG |
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)))) | |
2b95784c JG |
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))))) |