mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 11:50:28 +02:00
3fdc1d05ae
Guile implements this library in terms of SRFI-69, which is a bit vague on the arity of hash functions, whereas `(rnrs hashtables)' explicitly specifies unary ones. * module/rnrs/hashtables.scm (wrap-hash-function): Assume SRFI-69 will pass the table capacity as the second argument; return the result of proc modulo the capacity. * test-suite/tests/r6rs-hashtables.test (make-hashtable): New test case for hash functions that return large values.
184 lines
7.4 KiB
Text
184 lines
7.4 KiB
Text
;;; r6rs-hashtables.test --- Test suite for R6RS (rnrs hashtables)
|
||
|
||
;; Copyright (C) 2010 Free Software Foundation, Inc.
|
||
;;
|
||
;; This library is free software; you can redistribute it and/or
|
||
;; modify it under the terms of the GNU Lesser General Public
|
||
;; License as published by the Free Software Foundation; either
|
||
;; version 3 of the Lice6nse, or (at your option) any later version.
|
||
;;
|
||
;; This library is distributed in the hope that it will be useful,
|
||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||
;; Lesser General Public License for more details.
|
||
;;
|
||
;; You should have received a copy of the GNU Lesser General Public
|
||
;; License along with this library; if not, write to the Free Software
|
||
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
||
|
||
|
||
(define-module (test-suite test-rnrs-hashtable)
|
||
:use-module (ice-9 receive)
|
||
:use-module ((rnrs hashtables) :version (6))
|
||
:use-module (srfi srfi-1)
|
||
:use-module (test-suite lib))
|
||
|
||
(with-test-prefix "make-eq-hashtable"
|
||
(pass-if "eq hashtable compares keys with eq?"
|
||
(let ((eq-hashtable (make-eq-hashtable)))
|
||
(hashtable-set! eq-hashtable (list 'foo) #t)
|
||
(hashtable-set! eq-hashtable 'sym #t)
|
||
(and (not (hashtable-contains? eq-hashtable (list 'foo)))
|
||
(hashtable-contains? eq-hashtable 'sym)))))
|
||
|
||
(with-test-prefix "make-eqv-hashtable"
|
||
(pass-if "eqv hashtable compares keys with eqv?"
|
||
(let ((eqv-hashtable (make-eqv-hashtable)))
|
||
(hashtable-set! eqv-hashtable (list 'foo) #t)
|
||
(hashtable-set! eqv-hashtable 4 #t)
|
||
(and (not (hashtable-contains? eqv-hashtable (list 'foo)))
|
||
(hashtable-contains? eqv-hashtable 4)))))
|
||
|
||
(with-test-prefix "make-hashtable"
|
||
(pass-if "hashtable compares keys with custom equality function"
|
||
(let* ((abs-eqv? (lambda (x y) (eqv? (abs x) (abs y))))
|
||
(abs-hashtable (make-hashtable abs abs-eqv?)))
|
||
(hashtable-set! abs-hashtable -4 #t)
|
||
(and (not (hashtable-contains? abs-hashtable 6))
|
||
(hashtable-contains? abs-hashtable 4))))
|
||
|
||
(pass-if "hash function value used modulo capacity"
|
||
(let* ((constant-hash (lambda (x) most-positive-fixnum))
|
||
(constant-hashtable (make-hashtable constant-hash eq?)))
|
||
(hashtable-set! constant-hashtable 'foo 'bar)
|
||
(hashtable-contains? constant-hashtable 'foo))))
|
||
|
||
(with-test-prefix "hashtable?"
|
||
(pass-if "hashtable? is #t on hashtables"
|
||
(let ((hashtable (make-eq-hashtable)))
|
||
(hashtable? hashtable)))
|
||
|
||
(pass-if "hashtable? is #f on non-hashtables"
|
||
(let ((not-hashtable (list)))
|
||
(not (hashtable? not-hashtable)))))
|
||
|
||
(with-test-prefix "hashtable-size"
|
||
(pass-if "hashtable-size returns current size"
|
||
(let ((hashtable (make-eq-hashtable)))
|
||
(and (eqv? (hashtable-size hashtable) 0)
|
||
(hashtable-set! hashtable 'foo #t)
|
||
(eqv? (hashtable-size hashtable) 1)))))
|
||
|
||
(with-test-prefix "hashtable-ref"
|
||
(pass-if "hashtable-ref returns value for bound key"
|
||
(let ((hashtable (make-eq-hashtable)))
|
||
(hashtable-set! hashtable 'sym 'foo)
|
||
(eq? (hashtable-ref hashtable 'sym 'bar) 'foo)))
|
||
|
||
(pass-if "hashtable-ref returns default for unbound key"
|
||
(let ((hashtable (make-eq-hashtable)))
|
||
(eq? (hashtable-ref hashtable 'sym 'bar) 'bar))))
|
||
|
||
(with-test-prefix "hashtable-set!"
|
||
(pass-if "hashtable-set! returns unspecified"
|
||
(let ((hashtable (make-eq-hashtable)))
|
||
(unspecified? (hashtable-set! hashtable 'foo 'bar))))
|
||
|
||
(pass-if "hashtable-set! allows storing #f"
|
||
(let ((hashtable (make-eq-hashtable)))
|
||
(hashtable-set! hashtable 'foo #f)
|
||
(not (hashtable-ref hashtable 'foo 'bar)))))
|
||
|
||
(with-test-prefix "hashtable-delete!"
|
||
(pass-if "hashtable-delete! removes association"
|
||
(let ((hashtable (make-eq-hashtable)))
|
||
(hashtable-set! hashtable 'foo 'bar)
|
||
(and (unspecified? (hashtable-delete! hashtable 'foo))
|
||
(not (hashtable-ref hashtable 'foo #f))))))
|
||
|
||
(with-test-prefix "hashtable-contains?"
|
||
(pass-if "hashtable-contains? returns #t when association present"
|
||
(let ((hashtable (make-eq-hashtable)))
|
||
(hashtable-set! hashtable 'foo 'bar)
|
||
(let ((contains (hashtable-contains? hashtable 'foo)))
|
||
(and (boolean? contains) contains))))
|
||
|
||
(pass-if "hashtable-contains? returns #f when association not present"
|
||
(let ((hashtable (make-eq-hashtable)))
|
||
(not (hashtable-contains? hashtable 'foo)))))
|
||
|
||
(with-test-prefix "hashtable-update!"
|
||
(pass-if "hashtable-update! adds return value of proc on bound key"
|
||
(let ((hashtable (make-eq-hashtable)))
|
||
(hashtable-set! hashtable 'foo 0)
|
||
(hashtable-update! hashtable 'foo (lambda (x) (+ x 1)) 100)
|
||
(eqv? (hashtable-ref hashtable 'foo #f) 1)))
|
||
|
||
(pass-if "hashtable-update! adds default value on unbound key"
|
||
(let ((hashtable (make-eq-hashtable)))
|
||
(hashtable-update! hashtable 'foo (lambda (x) (+ x 1)) 100)
|
||
(eqv? (hashtable-ref hashtable 'foo #f) 101))))
|
||
|
||
(with-test-prefix "hashtable-copy"
|
||
(pass-if "hashtable-copy produces copy of hashtable"
|
||
(let ((hashtable (make-eq-hashtable)))
|
||
(hashtable-set! hashtable 'foo 1)
|
||
(hashtable-set! hashtable 'bar 2)
|
||
(let ((copied-table (hashtable-copy hashtable)))
|
||
(and (eqv? (hashtable-ref hashtable 'foo #f) 1)
|
||
(eqv? (hashtable-ref hashtable 'bar #f) 2)))))
|
||
|
||
(pass-if "hashtable-copy with mutability #f produces immutable copy"
|
||
(let ((copied-table (hashtable-copy (make-eq-hashtable) #f)))
|
||
(hashtable-set! copied-table 'foo 1)
|
||
(not (hashtable-ref copied-table 'foo #f)))))
|
||
|
||
(with-test-prefix "hashtable-clear!"
|
||
(pass-if "hashtable-clear! removes all values from hashtable"
|
||
(let ((hashtable (make-eq-hashtable)))
|
||
(hashtable-set! hashtable 'foo 1)
|
||
(hashtable-set! hashtable 'bar 2)
|
||
(and (unspecified? (hashtable-clear! hashtable))
|
||
(eqv? (hashtable-size hashtable) 0)))))
|
||
|
||
(with-test-prefix "hashtable-keys"
|
||
(pass-if "hashtable-keys returns all keys"
|
||
(let ((hashtable (make-eq-hashtable)))
|
||
(hashtable-set! hashtable 'foo #t)
|
||
(hashtable-set! hashtable 'bar #t)
|
||
(let ((keys (vector->list (hashtable-keys hashtable))))
|
||
(and (memq 'foo keys) (memq 'bar keys) #t)))))
|
||
|
||
(with-test-prefix "hashtable-entries"
|
||
(pass-if "hashtable-entries returns all entries"
|
||
(let ((hashtable (make-eq-hashtable)))
|
||
(hashtable-set! hashtable 'foo 1)
|
||
(hashtable-set! hashtable 'bar 2)
|
||
(receive
|
||
(keys values)
|
||
(hashtable-entries hashtable)
|
||
(let f ((counter 0) (success #t))
|
||
(if (or (not success) (= counter 2))
|
||
success
|
||
(case (vector-ref keys counter)
|
||
((foo) (f (+ counter 1) (eqv? (vector-ref values counter) 1)))
|
||
((bar) (f (+ counter 1) (eqv? (vector-ref values counter) 2)))
|
||
(else f 0 #f))))))))
|
||
|
||
(with-test-prefix "hashtable-equivalence-function"
|
||
(pass-if "hashtable-equivalence-function returns eqv function"
|
||
(let* ((abs-eqv? (lambda (x y) (eqv? (abs x) (abs y))))
|
||
(abs-hashtable (make-hashtable abs abs-eqv?)))
|
||
(eq? (hashtable-equivalence-function abs-hashtable) abs-eqv?))))
|
||
|
||
(with-test-prefix "hashtable-hash-function"
|
||
(pass-if "hashtable-hash-function returns hash function"
|
||
(let ((abs-hashtable (make-hashtable abs eqv?)))
|
||
(eq? (hashtable-hash-function abs-hashtable) abs))))
|
||
|
||
(with-test-prefix "hashtable-mutable?"
|
||
(pass-if "hashtable-mutable? is #t on mutable hashtables"
|
||
(hashtable-mutable? (hashtable-copy (make-eq-hashtable) #t)))
|
||
|
||
(pass-if "hashtable-mutable? is #f on immutable hashtables"
|
||
(not (hashtable-mutable? (hashtable-copy (make-eq-hashtable) #f)))))
|