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