1: ;;
    2: ;; test for weak vector / weak hash table
    3: ;; $Id: weak.scm,v 1.2 2007/06/01 00:53:23 shirok Exp $
    4: 
    5: ;; The collection of garbage is affected by lots of factors.
    6: ;; The following tests make effort to cause the weakly referenced
    7: ;; objects collected, but may fail on certain occasions.
    8: 
    9: (use gauche.test)
   10: (use srfi-1)
   11: 
   12: (test-start "weak pointers")
   13: 
   14: ;; A dummy function to overwrite the VM stack, so that we can clear out
   15: ;; any dangling reference to the object that are pointed by weak structure.
   16: ;; (This wouldn't be necessary once we implement a sane GC mark handler
   17: ;; on the VM stack.)
   18: (define (fact n)
   19:   (if (zero? n)
   20:     1
   21:     (* n (fact (- n 1)))))
   22: 
   23: (define (clear-references)
   24:   (fact 1000) ;; clear the stack
   25:   (dotimes (n 10) (gc)))
   26: 
   27: (test-section "weak vector")
   28: 
   29: (define x (make-weak-vector 5))
   30: 
   31: (test* "make-weak-vector" #t (is-a? x <weak-vector>))
   32: (test* "weak-vector-length" 5 (weak-vector-length x))
   33: 
   34: (test* "weak-vector-set!/ref" '((1 2 3) (4 5 6) (7 8 9) #f #f)
   35:        (begin (weak-vector-set! x 0 (list 1 2 3))
   36:               (weak-vector-set! x 1 (list 4 5 6))
   37:               (weak-vector-set! x 2 (list 7 8 9))
   38:               (map (cut weak-vector-ref x <>) '(0 1 2 3 4))))
   39: 
   40: (clear-references)
   41: 
   42: (test* "weak-vector-set!/ref (after gc)" '(#f #f #f #f #f)
   43:        (map (cut weak-vector-ref x <>) '(0 1 2 3 4)))
   44: 
   45: 
   46: ; (test-section "weak hash table")
   47: 
   48: ; (define x (make-weak-hash-table 'eqv? 'value 'gone))
   49: 
   50: ; (test* "make-weak-hash-table (value-weak)" <weak-hash-table>
   51: ;        (class-of x))
   52: 
   53: ; (test* "weak-hash-table-type" 'eqv? (weak-hash-table-type x))
   54: ; (test* "weak-hash-table-weakness" 'value (weak-hash-table-weakness x))
   55: 
   56: ; (test* "weak-hash-table-get (nonexistent)" *test-error*
   57: ;        (weak-hash-table-get x 123))
   58: ; (test* "weak-hash-table-get (nonexistent)" 'foo
   59: ;        (weak-hash-table-get x 123 'foo))
   60: 
   61: ; (test* "weak-hash-table-put!/get" '(1 2 3)
   62: ;        (begin
   63: ;          (weak-hash-table-put! x 123 (list 1 2 3))
   64: ;          (weak-hash-table-get x 123)))
   65: ; (test* "weak-hash-table-put!/get" '(4 5 6)
   66: ;        (begin
   67: ;          (weak-hash-table-put! x 456 (list 4 5 6))
   68: ;          (weak-hash-table-get x 456)))
   69: 
   70: ; (clear-references)
   71: 
   72: ; (test* "weak-hash-table-get (after gc)" '(gone gone)
   73: ;        (map (cut weak-hash-table-get x <>) '(123 456)))
   74: 
   75: ; (test* "weak-hash-table-keys & values" '((111 222 123 456)
   76: ;                                          ((1 1 1) (2 2 2) gone gone))
   77: ;        (let ((ones (list 1 1 1))
   78: ;              (twos (list 2 2 2)))
   79: ;          (weak-hash-table-put! x 111 ones)
   80: ;          (weak-hash-table-put! x 222 twos)
   81: ;          (list (weak-hash-table-keys x)
   82: ;                (weak-hash-table-values x)))
   83: ;        (lambda (expected got)
   84: ;          (and (lset= equal? (car expected) (car got))
   85: ;               (lset= equal? (cadr expected) (cadr got)))))
   86:          
   87: ; (define x (make-weak-hash-table 'equal? 'key 'gone))
   88: 
   89: ; (test* "make-weak-hash-table (key-weak)" <weak-hash-table>
   90: ;        (class-of x))
   91: 
   92: ; (test* "weak-hash-table-weakness" 'key (weak-hash-table-weakness x))
   93: 
   94: ; (test* "weak-hash-table-get (nonexistent)" *test-error*
   95: ;        (weak-hash-table-get x (list 1 2 3)))
   96: ; (test* "weak-hash-table-get (nonexistent)" 'foo
   97: ;        (weak-hash-table-get x (list 1 2 3) 'foo))
   98: 
   99: 
  100: ; (define y (list 7 8 9))
  101: 
  102: ; (test* "weak-hash-table-put!/get" 123
  103: ;        (begin
  104: ;          (weak-hash-table-put! x (list 1 2 3) 123)
  105: ;          (weak-hash-table-get x '(1 2 3) 'huh?)))
  106: ; (test* "weak-hash-table-put!/get" 456
  107: ;        (begin
  108: ;          (weak-hash-table-put! x (list 4 5 6) 456)
  109: ;          (weak-hash-table-get x '(4 5 6) 'huh?)))
  110: ; (test* "weak-hash-table-put!/get" 789
  111: ;        (begin
  112: ;          (weak-hash-table-put! x y 789)
  113: ;          (weak-hash-table-get x '(7 8 9) 'huh?)))
  114: 
  115: ; (clear-references)
  116: 
  117: ; (test* "weak-hash-table-get (after gc)" '(foo foo 789)
  118: ;        (map (cut weak-hash-table-get x <> 'foo) '((1 2 3) (4 5 6) (7 8 9))))
  119: 
  120: ; (test* "weak-hash-table-keys&values" '(((7 8 9)) (789))
  121: ;        (list (weak-hash-table-keys x)
  122: ;              (weak-hash-table-values x)))
  123: 
  124: (test-end)
  125: 
  126: