1(import (rnrs)
2	(srfi :69)
3	(srfi :1)
4	(srfi :64))
5
6;; tests from Chibi Scheme.
7(test-begin "SRFI-69 Basic hash tables")
8
9(define-syntax test (identifier-syntax test-equal))
10
11(define-syntax test-not
12  (syntax-rules ()
13    ((_ expr)
14     (test-not 'expr expr))
15    ((_ name expr)
16     (test-assert name (not expr)))))
17
18(define-syntax test-lset-eq?
19  (syntax-rules ()
20    ((test-lset= a b)
21     (test-assert 'a (lset= eq? a b)))))
22
23(define-syntax test-lset-equal?
24  (syntax-rules ()
25    ((test-lset-equal? a b)
26     (test-assert 'a (lset= equal? a b)))))
27
28(let ((ht (make-hash-table eq?)))
29  ;; 3 initial elements
30  (test 0 (hash-table-size ht))
31  (hash-table-set! ht 'cat 'black)
32  (hash-table-set! ht 'dog 'white)
33  (hash-table-set! ht 'elephant 'pink)
34  (test 3 (hash-table-size ht))
35  (test-assert (hash-table-exists? ht 'dog))
36  (test-assert (hash-table-exists? ht 'cat))
37  (test-assert (hash-table-exists? ht 'elephant))
38  (test-not (hash-table-exists? ht 'goose))
39  (test 'white (hash-table-ref ht 'dog))
40  (test 'black (hash-table-ref ht 'cat))
41  (test 'pink (hash-table-ref ht 'elephant))
42  (test-error (hash-table-ref ht 'goose))
43  (test 'grey (hash-table-ref ht 'goose (lambda () 'grey)))
44  (test 'grey (hash-table-ref/default ht 'goose 'grey))
45  (test-lset-eq? '(cat dog elephant) (hash-table-keys ht))
46  (test-lset-eq? '(black white pink) (hash-table-values ht))
47  (test-lset-equal? '((cat . black) (dog . white) (elephant . pink))
48                    (hash-table->alist ht))
49
50  ;; remove an element
51  (hash-table-delete! ht 'dog)
52  (test 2 (hash-table-size ht))
53  (test-not (hash-table-exists? ht 'dog))
54  (test-assert (hash-table-exists? ht 'cat))
55  (test-assert (hash-table-exists? ht 'elephant))
56  (test-error (hash-table-ref ht 'dog))
57  (test 'black (hash-table-ref ht 'cat))
58  (test 'pink (hash-table-ref ht 'elephant))
59  (test-lset-eq? '(cat elephant) (hash-table-keys ht))
60  (test-lset-eq? '(black pink) (hash-table-values ht))
61  (test-lset-equal? '((cat . black) (elephant . pink)) (hash-table->alist ht))
62
63  ;; remove a non-existing element
64  (hash-table-delete! ht 'dog)
65  (test 2 (hash-table-size ht))
66  (test-not (hash-table-exists? ht 'dog))
67
68  ;; overwrite an existing element
69  (hash-table-set! ht 'cat 'calico)
70  (test 2 (hash-table-size ht))
71  (test-not (hash-table-exists? ht 'dog))
72  (test-assert (hash-table-exists? ht 'cat))
73  (test-assert (hash-table-exists? ht 'elephant))
74  (test-error (hash-table-ref ht 'dog))
75  (test 'calico (hash-table-ref ht 'cat))
76  (test 'pink (hash-table-ref ht 'elephant))
77  (test-lset-eq? '(cat elephant) (hash-table-keys ht))
78  (test-lset-eq? '(calico pink) (hash-table-values ht))
79  (test-lset-equal? '((cat . calico) (elephant . pink)) (hash-table->alist ht))
80
81  ;; walk and fold
82  (test-lset-equal?
83   '((cat . calico) (elephant . pink))
84   (let ((a '()))
85     (hash-table-walk ht (lambda (k v) (set! a (cons (cons k v) a))))
86     a))
87  (test-lset-equal? '((cat . calico) (elephant . pink))
88                    (hash-table-fold ht (lambda (k v a) (cons (cons k v) a)) '()))
89
90  ;; copy
91  (let ((ht2 (hash-table-copy ht)))
92    (test 2 (hash-table-size ht2))
93    (test-not (hash-table-exists? ht2 'dog))
94    (test-assert (hash-table-exists? ht2 'cat))
95    (test-assert (hash-table-exists? ht2 'elephant))
96    (test-error (hash-table-ref ht2 'dog))
97    (test 'calico (hash-table-ref ht2 'cat))
98    (test 'pink (hash-table-ref ht2 'elephant))
99    (test-lset-eq? '(cat elephant) (hash-table-keys ht2))
100    (test-lset-eq? '(calico pink) (hash-table-values ht2))
101    (test-lset-equal? '((cat . calico) (elephant . pink))
102                      (hash-table->alist ht2)))
103
104  ;; merge
105  (let ((ht2 (make-hash-table eq?)))
106    (hash-table-set! ht2 'bear 'brown)
107    (test 1 (hash-table-size ht2))
108    (test-not (hash-table-exists? ht2 'dog))
109    (test-assert (hash-table-exists? ht2 'bear))
110    (hash-table-merge! ht2 ht)
111    (test 3 (hash-table-size ht2))
112    (test-assert (hash-table-exists? ht2 'bear))
113    (test-assert (hash-table-exists? ht2 'cat))
114    (test-assert (hash-table-exists? ht2 'elephant))
115    (test-not (hash-table-exists? ht2 'goose))
116    (test 'brown (hash-table-ref ht2 'bear))
117    (test 'calico (hash-table-ref ht2 'cat))
118    (test 'pink (hash-table-ref ht2 'elephant))
119    (test-error (hash-table-ref ht2 'goose))
120    (test 'grey (hash-table-ref/default ht2 'goose 'grey))
121    (test-lset-eq? '(bear cat elephant) (hash-table-keys ht2))
122    (test-lset-eq? '(brown calico pink) (hash-table-values ht2))
123    (test-lset-equal? '((cat . calico) (bear . brown) (elephant . pink))
124                      (hash-table->alist ht2)))
125
126  ;; alist->hash-table
127  (test-lset-equal? (hash-table->alist ht)
128                    (hash-table->alist
129                     (alist->hash-table
130                      '((cat . calico) (elephant . pink))))))
131
132;; update
133(let ((ht (make-hash-table eq?))
134      (add1 (lambda (x) (+ x 1))))
135  (hash-table-set! ht 'sheep 0)
136  (hash-table-update! ht 'sheep add1)
137  (hash-table-update! ht 'sheep add1)
138  (test 2 (hash-table-ref ht 'sheep))
139  (hash-table-update!/default ht 'crows add1 0)
140  (hash-table-update!/default ht 'crows add1 0)
141  (hash-table-update!/default ht 'crows add1 0)
142  (test 3 (hash-table-ref ht 'crows)))
143
144;; string keys
145(let ((ht (make-hash-table equal?)))
146  (hash-table-set! ht "cat" 'black)
147  (hash-table-set! ht "dog" 'white)
148  (hash-table-set! ht "elephant" 'pink)
149  (hash-table-ref/default ht "dog" #f)
150  (test 'white (hash-table-ref ht "dog"))
151  (test 'black (hash-table-ref ht "cat"))
152  (test 'pink (hash-table-ref ht "elephant"))
153  (test-error (hash-table-ref ht "goose"))
154  (test 'grey (hash-table-ref/default ht "goose" 'grey))
155  (test-lset-equal? '("cat" "dog" "elephant") (hash-table-keys ht))
156  (test-lset-equal? '(black white pink) (hash-table-values ht))
157  (test-lset-equal?
158   '(("cat" . black) ("dog" . white) ("elephant" . pink))
159   (hash-table->alist ht)))
160
161;; string-ci keys
162(let ((ht (make-hash-table string-ci=? string-ci-hash)))
163  (hash-table-set! ht "cat" 'black)
164  (hash-table-set! ht "dog" 'white)
165  (hash-table-set! ht "elephant" 'pink)
166  (hash-table-ref/default ht "DOG" #f)
167  (test 'white (hash-table-ref ht "DOG"))
168  (test 'black (hash-table-ref ht "Cat"))
169  (test 'pink (hash-table-ref ht "eLePhAnT"))
170  (test-error (hash-table-ref ht "goose"))
171  (test-lset-equal? '("cat" "dog" "elephant") (hash-table-keys ht))
172  (test-lset-equal? '(black white pink) (hash-table-values ht))
173  (test-lset-equal?
174   '(("cat" . black) ("dog" . white) ("elephant" . pink))
175   (hash-table->alist ht)))
176
177;; This doesn't apply for Sagittarius so remove it
178;; Exception values - this works because the return value from the
179;; primitives is a cell, and we use the cdr opcode to retrieve the
180;; cell value.  Thus there is no FFI issue with storing exceptions.
181;; (let ((ht (make-hash-table)))
182;;   (hash-table-set! ht 'boom (make-exception 'my-exn-type "boom!" '() #f #f))
183;;   (test 'my-exn-type (exception-kind (hash-table-ref ht 'boom))))
184
185;; stress test
186(test 625
187 (let ((ht (make-hash-table)))
188   (do ((i 0 (+ i 1))) ((= i 1000))
189     (hash-table-set! ht i (* i i)))
190   (hash-table-ref/default ht 25 #f)))
191
192(test-end)
193
194