source: project/release/4/pool/trunk/tests/run.scm @ 18789

Last change on this file since 18789 was 18789, checked in by Moritz Heidkamp, 10 years ago

pool: use a condition variable instead of sleep intervals to signal when locks are freed to waiting threads and bump version to 0.2

File size: 1.7 KB
Line 
1(load-relative "../pool.scm")
2(import pool)
3(use test srfi-18)
4
5(define pool (make-pool '(foo bar baz)))
6
7(test 'foo (call-with-value-from-pool pool identity))
8(test 'foo (call-with-value-from-pool pool identity))
9
10(test 'foo (call-with-value-from-pool pool 
11             (lambda (v)
12               (call-with-value-from-pool pool 
13                 (lambda (v)
14                   (call-with-value-from-pool pool identity))))))
15
16(test 'baz (call-with-value-from-pool pool 
17             (lambda (v)
18               (thread-join! (call-with-value-from-pool-in-thread pool
19                               (lambda (v)
20                                 (thread-join! (call-with-value-from-pool-in-thread pool identity))))))))
21
22
23(test "returning false from the proc" #f (call-with-value-from-pool pool (constantly #f)))
24
25(test-error "deadlock"
26            (let ((pool (make-pool '(a))))
27              (call-with-value-from-pool pool 
28                (lambda (v)
29                  (thread-join! 
30                   (call-with-value-from-pool-in-thread pool identity))))))
31(let* ((value 0)
32       (pool (make-pool '(1))))
33  (for-each (lambda (i)
34              (call-with-value-from-pool-in-thread pool
35                (lambda (v)
36                  (set! value (add1 value)))))
37            (list-tabulate 10 (constantly 1)))
38
39  (let loop ((threads (##sys#all-threads)))
40    (unless (null? threads)
41      (thread-join! (car threads))
42      (loop (##sys#all-threads))))
43
44  (test 10 value))
45
46
47;; this one is left to fail - it needs dynamic-wind to be fixed but I couldn't make it work so far
48(let ((jump #f)
49      (done #f))
50
51  (call-with-value-from-pool pool 
52    (lambda (v)
53      (call/cc (lambda (c)
54                 (set! jump c)))
55
56      (when done
57        (test "value is still locked" 'foo (alist-ref (current-thread) (pool-locked-values pool))))))
58 
59  (unless done 
60    (set! done #t)
61    (call-with-value-from-pool-in-thread pool (lambda (v) (thread-suspend! (current-thread))))
62    (jump #t)))
Note: See TracBrowser for help on using the repository browser.