Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-19 05:39:18 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

fleshing out hash tests

Browse source
This commit is contained in:
Alex Shinn 2012-06-25 22:38:27 -07:00
parent a7e899ce8d
commit 88b84d5232
1 changed files with 157 additions and 22 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

161
tests/hash-tests.scm
View file

@ -1,33 +1,168 @@
(cond-expand (cond-expand
(modules (import (srfi 69) (only (chibi test) test-begin test test-end))) (modules (import (srfi 1) (srfi 69) (chibi test)))
(else #f)) (else #f))
(test-begin "hash") (test-begin "hash")
(test (define-syntax test-lset-eq?
'white (syntax-rules ()
(let ((ht (make-hash-table eq?))) ((test-lset= . args)
(test-equal (lambda (a b) (lset= eq? a b)) . args))))
(define-syntax test-lset-equal?
(syntax-rules ()
((test-lset-equal? . args)
(test-equal (lambda (a b) (lset= equal? a b)) . args))))
(let ((ht (make-hash-table eq?)))
;; 3 initial elements
(test 0 (hash-table-size ht))
(hash-table-set! ht 'cat 'black) (hash-table-set! ht 'cat 'black)
(hash-table-set! ht 'dog 'white) (hash-table-set! ht 'dog 'white)
(hash-table-set! ht 'elephant 'pink) (hash-table-set! ht 'elephant 'pink)
(hash-table-ref/default ht 'dog #f))) (test 3 (hash-table-size ht))
(test-assert (hash-table-exists? ht 'dog))
(test-assert (hash-table-exists? ht 'cat))
(test-assert (hash-table-exists? ht 'elephant))
(test-not (hash-table-exists? ht 'goose))
(test 'white (hash-table-ref ht 'dog))
(test 'black (hash-table-ref ht 'cat))
(test 'pink (hash-table-ref ht 'elephant))
(test-error (hash-table-ref ht 'goose))
(test 'grey (hash-table-ref ht 'goose (lambda () 'grey)))
(test 'grey (hash-table-ref/default ht 'goose 'grey))
(test-lset-eq? '(cat dog elephant) (hash-table-keys ht))
(test-lset-eq? '(black white pink) (hash-table-values ht))
(test-lset-equal? '((cat . black) (dog . white) (elephant . pink))
(hash-table->alist ht))
(test ;; remove an element
'white (hash-table-delete! ht 'dog)
(let ((ht (make-hash-table equal?))) (test 2 (hash-table-size ht))
(test-not (hash-table-exists? ht 'dog))
(test-assert (hash-table-exists? ht 'cat))
(test-assert (hash-table-exists? ht 'elephant))
(test-error (hash-table-ref ht 'dog))
(test 'black (hash-table-ref ht 'cat))
(test 'pink (hash-table-ref ht 'elephant))
(test-lset-eq? '(cat elephant) (hash-table-keys ht))
(test-lset-eq? '(black pink) (hash-table-values ht))
(test-lset-equal? '((cat . black) (elephant . pink)) (hash-table->alist ht))
;; remove a non-existing element
(hash-table-delete! ht 'dog)
(test 2 (hash-table-size ht))
(test-not (hash-table-exists? ht 'dog))
;; overwrite an existing element
(hash-table-set! ht 'cat 'calico)
(test 2 (hash-table-size ht))
(test-not (hash-table-exists? ht 'dog))
(test-assert (hash-table-exists? ht 'cat))
(test-assert (hash-table-exists? ht 'elephant))
(test-error (hash-table-ref ht 'dog))
(test 'calico (hash-table-ref ht 'cat))
(test 'pink (hash-table-ref ht 'elephant))
(test-lset-eq? '(cat elephant) (hash-table-keys ht))
(test-lset-eq? '(calico pink) (hash-table-values ht))
(test-lset-equal? '((cat . calico) (elephant . pink)) (hash-table->alist ht))
;; walk and fold
(test-lset-equal?
'((cat . calico) (elephant . pink))
(let ((a '()))
(hash-table-walk ht (lambda (k v) (set! a (cons (cons k v) a))))
a))
(test-lset-equal? '((cat . calico) (elephant . pink))
(hash-table-fold ht (lambda (k v a) (cons (cons k v) a)) '()))
;; copy
(let ((ht2 (hash-table-copy ht)))
(test 2 (hash-table-size ht2))
(test-not (hash-table-exists? ht2 'dog))
(test-assert (hash-table-exists? ht2 'cat))
(test-assert (hash-table-exists? ht2 'elephant))
(test-error (hash-table-ref ht2 'dog))
(test 'calico (hash-table-ref ht2 'cat))
(test 'pink (hash-table-ref ht2 'elephant))
(test-lset-eq? '(cat elephant) (hash-table-keys ht2))
(test-lset-eq? '(calico pink) (hash-table-values ht2))
(test-lset-equal? '((cat . calico) (elephant . pink))
(hash-table->alist ht2)))
;; merge
(let ((ht2 (make-hash-table eq?)))
(hash-table-set! ht2 'bear 'brown)
(test 1 (hash-table-size ht2))
(test-not (hash-table-exists? ht2 'dog))
(test-assert (hash-table-exists? ht2 'bear))
(hash-table-merge! ht2 ht)
(test 3 (hash-table-size ht2))
(test-assert (hash-table-exists? ht2 'bear))
(test-assert (hash-table-exists? ht2 'cat))
(test-assert (hash-table-exists? ht2 'elephant))
(test-not (hash-table-exists? ht2 'goose))
(test 'brown (hash-table-ref ht2 'bear))
(test 'calico (hash-table-ref ht2 'cat))
(test 'pink (hash-table-ref ht2 'elephant))
(test-error (hash-table-ref ht2 'goose))
(test 'grey (hash-table-ref/default ht2 'goose 'grey))
(test-lset-eq? '(bear cat elephant) (hash-table-keys ht2))
(test-lset-eq? '(brown calico pink) (hash-table-values ht2))
(test-lset-equal? '((cat . calico) (bear . brown) (elephant . pink))
(hash-table->alist ht2)))
;; alist->hash-table
(test-lset-equal? (hash-table->alist ht)
(hash-table->alist
(alist->hash-table
'((cat . calico) (elephant . pink))))))
;; update
(let ((ht (make-hash-table eq?))
(add1 (lambda (x) (+ x 1))))
(hash-table-set! ht 'sheep 0)
(hash-table-update! ht 'sheep add1)
(hash-table-update! ht 'sheep add1)
(test 2 (hash-table-ref ht 'sheep))
(hash-table-update!/default ht 'crows add1 0)
(hash-table-update!/default ht 'crows add1 0)
(hash-table-update!/default ht 'crows add1 0)
(test 3 (hash-table-ref ht 'crows)))
;; string keys
(let ((ht (make-hash-table equal?)))
(hash-table-set! ht "cat" 'black) (hash-table-set! ht "cat" 'black)
(hash-table-set! ht "dog" 'white) (hash-table-set! ht "dog" 'white)
(hash-table-set! ht "elephant" 'pink) (hash-table-set! ht "elephant" 'pink)
(hash-table-ref/default ht "dog" #f))) (hash-table-ref/default ht "dog" #f)
(test 'white (hash-table-ref ht "dog"))
(test 'black (hash-table-ref ht "cat"))
(test 'pink (hash-table-ref ht "elephant"))
(test-error (hash-table-ref ht "goose"))
(test 'grey (hash-table-ref/default ht "goose" 'grey))
(test-lset-equal? '("cat" "dog" "elephant") (hash-table-keys ht))
(test-lset-equal? '(black white pink) (hash-table-values ht))
(test-lset-equal?
'(("cat" . black) ("dog" . white) ("elephant" . pink))
(hash-table->alist ht)))
(test ;; string-ci keys
'white (let ((ht (make-hash-table string-ci=? string-ci-hash)))
(let ((ht (make-hash-table string-ci=? string-ci-hash)))
(hash-table-set! ht "cat" 'black) (hash-table-set! ht "cat" 'black)
(hash-table-set! ht "dog" 'white) (hash-table-set! ht "dog" 'white)
(hash-table-set! ht "elephant" 'pink) (hash-table-set! ht "elephant" 'pink)
(hash-table-ref/default ht "DOG" #f))) (hash-table-ref/default ht "DOG" #f)
(test 'white (hash-table-ref ht "DOG"))
(test 'black (hash-table-ref ht "Cat"))
(test 'pink (hash-table-ref ht "eLePhAnT"))
(test-error (hash-table-ref ht "goose"))
(test-lset-equal? '("cat" "dog" "elephant") (hash-table-keys ht))
(test-lset-equal? '(black white pink) (hash-table-values ht))
(test-lset-equal?
'(("cat" . black) ("dog" . white) ("elephant" . pink))
(hash-table->alist ht)))
(test 625 (test 625
(let ((ht (make-hash-table))) (let ((ht (make-hash-table)))