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