~ chicken-core (chicken-5) /tests/test-finalizers-2.scm

 1;;;; test-finalizers-2.scm - test finalizers + GC roots
 2
 3(import (chicken gc) (chicken fixnum))
 4
 5(define (list-tabulate n proc)
 6  (let loop ((i 0))
 7    (if (fx>= i n)
 8	'()
 9	(cons (proc i) (loop (fx+ i 1))))))
10
11(define *n* 1000)
12(define *count* 0)
13
14#>
15static void *
16makef(int f, C_word x)
17{
18  void *r = f ? CHICKEN_new_finalizable_gc_root() : CHICKEN_new_gc_root();
19
20  CHICKEN_gc_root_set(r, x);
21  return r;
22}
23
24static void
25freef(void *r)
26{
27  CHICKEN_delete_gc_root(r);
28}
29<#
30
31
32(define makef (foreign-lambda c-pointer "makef" bool scheme-object))
33(define freef (foreign-lambda void "freef" c-pointer))
34
35(define ((fin f e) x)
36  (set! *count* (add1 *count*))
37  (assert ((if e even? odd?) (car x)))
38  (when e (freef f)))
39
40(print "creating gc roots")
41
42(let* ((x (list-tabulate *n* list))
43       (fs (list-tabulate *n* (lambda (x) (zero? (modulo x 2)))))
44       (rs (map makef fs x)))
45  (for-each 
46   (lambda (x f e)
47     (set-finalizer! x (fin f e)))
48   x rs fs)
49  (print "forcing finalizers")
50  (##sys#force-finalizers)
51  (assert (zero? *count*))
52  (print "dropping data")
53  (set! x #f)
54  (print "forcing finalizables")
55  (##sys#force-finalizers)
56  (print *count*)
57  (assert (= (quotient *n* 2) *count*))
58  (print "releasing non-finalizable gc roots")
59  (for-each 
60   (lambda (f e)
61     (unless e (freef f)))
62   rs fs)
63  (print "forcing remaining")
64  (##sys#force-finalizers)
65  (assert (= *n* *count*)))
66
67;;; new finalizer API
68
69(define c1 (list *count*))
70(define f1 (make-finalizer c1))
71(add-to-finalizer f1 (make-vector 10))
72(define f2 (make-finalizer f1))
73(gc #t)
74(assert (vector? (f1)))
75(assert (not (f1)))
76(set! c1 #f)
77(gc #t)
78(assert (equal? (f1) (list *count*)))
79(assert (not (f1)))
80(set! f1 #f)
81(gc #t)
82(assert (procedure? (f2)))
83(assert (not (f2)))