1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
;;; test-weak.scm -- weak hashtable tests for the MPS toy Scheme interpreter
;;; $Id$

(load "test-common.scm")

(define (populate ht kvs)
  (let ((f (lambda (kv) (hashtable-set! ht (car kv) (cdr kv)))))
    (for-each f kvs)))

;; The MPS doesn't actually guarantee promptness of splatting. But we
;; have to test it somehow!

(define (ht-test ht-fun hash cmp f1 f2 kvs)
  (let* ((ht (ht-fun hash cmp))
         (f (lambda (kv) (equal? (hashtable-ref ht (car kv) #f) (cdr kv)))))
    (populate ht kvs)
    (list (begin (gc) (all (map f kvs)))
          (begin (for-each f1 kvs) (gc) (hashtable-size ht))
          (begin (for-each f2 kvs) (gc) (hashtable-size ht)))))

(define (dk kv) (set-car! kv #f))
(define (dv kv) (set-cdr! kv #f))

(check '(ht-test make-hashtable string-hash string=? dk dv
                 '(("one" . 1) ("two" . 2) ("three" . 3)))
       '(#t 3 3))

(check '(ht-test make-weak-key-hashtable eq-hash eq? dk dv
                 '((ONE . 1) (TWO . 2) (THREE . 3)))
       '(#t 0 0))

(check '(ht-test make-weak-key-hashtable eqv-hash eqv? dv dk
                 '((1 . 1) (2 . 2) (3 . 3)))
       '(#t 3 0))

(check '(ht-test make-weak-value-hashtable string-hash string=? dk dv
                 '(("one" . 1) ("two" . 2) ("three" . 3)))
       '(#t 3 0))

(check '(ht-test make-weak-value-hashtable string-hash string=? dv dk
                 '(("one" . 1) ("two" . 2) ("three" . 3)))
       '(#t 0 0))

(check '(ht-test make-doubly-weak-hashtable eq-hash eq? dk dv
                 '(("one" . 1) ("two" . 2) ("three" . 3)))
       '(#t 0 0))

(check '(ht-test make-doubly-weak-hashtable eqv-hash eqv? dv dk
                 '((#\a . 1) (#\b . 2) (#\c . 3)))
       '(#t 0 0))

(write-string "All tests pass.")
(newline)