From 38ff4606a1292f414fb0a2ba64448ceae6026e50 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Sun, 7 Dec 2008 16:26:32 +0000 Subject: [PATCH] Several new hash table tests, written by Gregory Marton. * test-suite/tests/hash.test ("make-hash-table, hash-table?", "hash-set and hash-ref", "auto-resizing hashx", "hashx"): New tests. * AUTHORS, THANKS: Add Gregory Marton as a contributor. --- AUTHORS | 4 + THANKS | 1 + test-suite/tests/hash.test | 203 +++++++++++++++++++++++++++++++++++++ 3 files changed, 208 insertions(+) diff --git a/AUTHORS b/AUTHORS index d93cd49d6..ed2adbab7 100644 --- a/AUTHORS +++ b/AUTHORS @@ -339,3 +339,7 @@ In the subdirectory libguile, changes to: John W. Eaton, based on code from AT&T Bell Laboratories and Bellcore: The complex number division method in libguile/numbers.c. + +Gregory Marton: +In the subdirectory test-suite/tests, changes to: + hash.test diff --git a/THANKS b/THANKS index 43c6558ce..3b3b91443 100644 --- a/THANKS +++ b/THANKS @@ -5,6 +5,7 @@ Contributors since the last release: Julian Graham Stefan Jahn Neil Jerram + Gregory Marton Antoine Mathys Thien-Thi Nguyen Han-Wen Nienhuys diff --git a/test-suite/tests/hash.test b/test-suite/tests/hash.test index 959c28541..ccfd24ece 100644 --- a/test-suite/tests/hash.test +++ b/test-suite/tests/hash.test @@ -62,6 +62,209 @@ (pass-if (= 0 (hashq #f 1))) (pass-if (= 0 (hashq noop 1)))) +;;; +;;; make-hash-table +;;; + +(with-test-prefix + "make-hash-table, hash-table?" + (pass-if-exception "make-hash-table -1" exception:out-of-range + (make-hash-table -1)) + (pass-if (hash-table? (make-hash-table 0))) ;; default + (pass-if (not (hash-table? 'not-a-hash-table))) + (pass-if (equal? "#" + (with-output-to-string + (lambda () (write (make-hash-table 100))))))) + +;;; +;;; usual set and reference +;;; + +(with-test-prefix + "hash-set and hash-ref" + + ;; auto-resizing + (pass-if (let ((table (make-hash-table 1))) ;;actually makes size 31 + (hash-set! table 'one 1) + (hash-set! table 'two #t) + (hash-set! table 'three #t) + (hash-set! table 'four #t) + (hash-set! table 'five #t) + (hash-set! table 'six #t) + (hash-set! table 'seven #t) + (hash-set! table 'eight #t) + (hash-set! table 'nine 9) + (hash-set! table 'ten #t) + (hash-set! table 'eleven #t) + (hash-set! table 'twelve #t) + (hash-set! table 'thirteen #t) + (hash-set! table 'fourteen #t) + (hash-set! table 'fifteen #t) + (hash-set! table 'sixteen #t) + (hash-set! table 'seventeen #t) + (hash-set! table 18 #t) + (hash-set! table 19 #t) + (hash-set! table 20 #t) + (hash-set! table 21 #t) + (hash-set! table 22 #t) + (hash-set! table 23 #t) + (hash-set! table 24 #t) + (hash-set! table 25 #t) + (hash-set! table 26 #t) + (hash-set! table 27 #t) + (hash-set! table 28 #t) + (hash-set! table 29 #t) + (hash-set! table 30 'thirty) + (hash-set! table 31 #t) + (hash-set! table 32 #t) + (hash-set! table 33 'thirty-three) + (hash-set! table 34 #t) + (hash-set! table 35 #t) + (hash-set! table 'foo 'bar) + (and (equal? 1 (hash-ref table 'one)) + (equal? 9 (hash-ref table 'nine)) + (equal? 'thirty (hash-ref table 30)) + (equal? 'thirty-three (hash-ref table 33)) + (equal? 'bar (hash-ref table 'foo)) + (equal? "#" + (with-output-to-string (lambda () (write table))))))) + + ;; 1 and 1 are equal? and eqv? and eq? + (pass-if (equal? 'foo + (let ((table (make-hash-table))) + (hash-set! table 1 'foo) + (hash-ref table 1)))) + (pass-if (equal? 'foo + (let ((table (make-hash-table))) + (hashv-set! table 1 'foo) + (hashv-ref table 1)))) + (pass-if (equal? 'foo + (let ((table (make-hash-table))) + (hashq-set! table 1 'foo) + (hashq-ref table 1)))) + + ;; 1/2 and 2/4 are equal? and eqv? but not eq? + (pass-if (equal? 'foo + (let ((table (make-hash-table))) + (hash-set! table 1/2 'foo) + (hash-ref table 2/4)))) + (pass-if (equal? 'foo + (let ((table (make-hash-table))) + (hashv-set! table 1/2 'foo) + (hashv-ref table 2/4)))) + (pass-if (equal? #f + (let ((table (make-hash-table))) + (hashq-set! table 1/2 'foo) + (hashq-ref table 2/4)))) + + ;; (list 1 2) is equal? but not eqv? or eq? to another (list 1 2) + (pass-if (equal? 'foo + (let ((table (make-hash-table))) + (hash-set! table (list 1 2) 'foo) + (hash-ref table (list 1 2))))) + (pass-if (equal? #f + (let ((table (make-hash-table))) + (hashv-set! table (list 1 2) 'foo) + (hashv-ref table (list 1 2))))) + (pass-if (equal? #f + (let ((table (make-hash-table))) + (hashq-set! table (list 1 2) 'foo) + (hashq-ref table (list 1 2))))) + + ;; ref default argument + (pass-if (equal? 'bar + (let ((table (make-hash-table))) + (hash-ref table 'foo 'bar)))) + (pass-if (equal? 'bar + (let ((table (make-hash-table))) + (hashv-ref table 'foo 'bar)))) + (pass-if (equal? 'bar + (let ((table (make-hash-table))) + (hashq-ref table 'foo 'bar)))) + (pass-if (equal? 'bar + (let ((table (make-hash-table))) + (hashx-ref hash equal? table 'foo 'bar)))) + + ;; wrong type argument + (pass-if-exception "(hash-ref 'not-a-table 'key)" exception:wrong-type-arg + (hash-ref 'not-a-table 'key)) + ) + +;;; +;;; hashx +;;; + +(with-test-prefix + "auto-resizing hashx" + ;; auto-resizing + (let ((table (make-hash-table 1))) ;;actually makes size 31 + (hashx-set! hash assoc table 1/2 'equal) + (hashx-set! hash assoc table 1/3 'equal) + (hashx-set! hash assoc table 4 'equal) + (hashx-set! hash assoc table 1/5 'equal) + (hashx-set! hash assoc table 1/6 'equal) + (hashx-set! hash assoc table 7 'equal) + (hashx-set! hash assoc table 1/8 'equal) + (hashx-set! hash assoc table 1/9 'equal) + (hashx-set! hash assoc table 10 'equal) + (hashx-set! hash assoc table 1/11 'equal) + (hashx-set! hash assoc table 1/12 'equal) + (hashx-set! hash assoc table 13 'equal) + (hashx-set! hash assoc table 1/14 'equal) + (hashx-set! hash assoc table 1/15 'equal) + (hashx-set! hash assoc table 16 'equal) + (hashx-set! hash assoc table 1/17 'equal) + (hashx-set! hash assoc table 1/18 'equal) + (hashx-set! hash assoc table 19 'equal) + (hashx-set! hash assoc table 1/20 'equal) + (hashx-set! hash assoc table 1/21 'equal) + (hashx-set! hash assoc table 22 'equal) + (hashx-set! hash assoc table 1/23 'equal) + (hashx-set! hash assoc table 1/24 'equal) + (hashx-set! hash assoc table 25 'equal) + (hashx-set! hash assoc table 1/26 'equal) + (hashx-set! hash assoc table 1/27 'equal) + (hashx-set! hash assoc table 28 'equal) + (hashx-set! hash assoc table 1/29 'equal) + (hashx-set! hash assoc table 1/30 'equal) + (hashx-set! hash assoc table 31 'equal) + (hashx-set! hash assoc table 1/32 'equal) + (hashx-set! hash assoc table 1/33 'equal) + (hashx-set! hash assoc table 34 'equal) + (pass-if (equal? 'equal (hash-ref table 2/4))) + (pass-if (equal? 'equal (hash-ref table 2/6))) + (pass-if (equal? 'equal (hash-ref table 4))) + (pass-if (equal? 'equal (hashx-ref hash assoc table 2/64))) + (pass-if (equal? 'equal (hashx-ref hash assoc table 2/66))) + (pass-if (equal? 'equal (hashx-ref hash assoc table 34))) + (pass-if (equal? "#" + (with-output-to-string (lambda () (write table))))))) + +(with-test-prefix + "hashx" + (pass-if (let ((table (make-hash-table))) + (hashx-set! (lambda (k v) 1) + (lambda (k al) (assoc 'foo al)) + table 'foo 'bar) + (equal? + 'bar (hashx-ref (lambda (k v) 1) + (lambda (k al) (assoc 'foo al)) + table 'baz)))) + (pass-if (let ((table (make-hash-table 31))) + (hashx-set! (lambda (k v) 1) assoc table 'foo 'bar) + (equal? #f + (hashx-ref (lambda (k v) 2) assoc table 'foo)))) + (pass-if (let ((table (make-hash-table))) + (hashx-set! hash assoc table 'foo 'bar) + (equal? #f + (hashx-ref hash (lambda (k al) #f) table 'foo)))) + (pass-if-exception + "hashx-set! (lambda (k s) 1) equal? table 'foo 'bar" + exception:wrong-type-arg ;; there must be a better exception than that... + (hashx-set! (lambda (k s) 1) (lambda (k al) #t) (make-hash-table) 'foo 'bar)) + ) + + ;;; ;;; hashx-remove! ;;;