source: project/chicken/branches/scrutiny/tests/srfi-18-tests.scm @ 14827

Last change on this file since 14827 was 14827, checked in by felix winkelmann, 10 years ago

merged trunk changes until 14826 into scrutiny branch

File size: 2.0 KB
Line 
1(require-extension srfi-18)
2
3(cond-expand (dribble
4(define-for-syntax count 0)
5(define-syntax trail
6  (er-macro-transformer
7  (lambda (form r c)                    ; doesn't bother much with renaming
8    (let ((loc (cadr form))
9          (expr (caddr form)))
10      (set! count (add1 count))
11      `(,(r 'begin)
12        (print "(" ,count ") " ,loc ": " ',expr ": get: " (##sys#slot get-mutex 5) ", put: " (##sys#slot put-mutex 5))
13        (let ((xxx ,expr))
14          (print "  (" ,count ") " ,loc ": " ',expr ": get: " (##sys#slot get-mutex 5) ", put: " (##sys#slot put-mutex 5))
15          xxx) ) )))))
16(else (define-syntax trail (syntax-rules () ((_ loc expr) expr)))))
17
18(define (tprint . x)
19 (printf "~a " (current-milliseconds))
20 (apply print x))
21
22(define (make-empty-mailbox)
23 (let ((put-mutex (make-mutex))        ; allow put! operation
24       (get-mutex (make-mutex))
25       (cell #f))
26
27   (define (put! obj)
28     (trail 'put! (mutex-lock! put-mutex #f #f))     ; prevent put! operation
29     (set! cell obj)
30     (trail 'put! (mutex-unlock! get-mutex)) )
31
32   (define (get!)
33     (trail 'get! (mutex-lock! get-mutex #f #f))     ; wait until object in mailbox
34     (let ((result cell))
35       (set! cell #f)                  ; prevent space leaks
36       (trail 'get! (mutex-unlock! put-mutex))       ; allow put! operation
37       result))
38
39   (trail 'main (mutex-lock! get-mutex #f #f))       ; prevent get! operation
40
41   (lambda (print)
42     (case print
43       ((put!) put!)
44       ((get!) get!)
45       (else (error "unknown message"))))))
46
47(define (mailbox-put! m obj) ((m 'put!) obj))
48(define (mailbox-get! m) ((m 'get!)))
49
50;(tprint 'start)
51
52(define mb (make-empty-mailbox))
53
54(thread-start!
55 (make-thread
56 (lambda ()
57   (let lp ()
58     ;(print "1: get")
59     (let ((x (mailbox-get! mb)))
60       ;(tprint "read: " x)
61       (assert x)
62       (lp))))))
63
64(thread-start!
65 (make-thread
66 (lambda ()
67   (thread-sleep! 1)
68   ;(tprint 'put)
69   ;(print "2: put")
70   (mailbox-put! mb 'test)
71   #;(print "2: endput"))))
72
73(thread-sleep! 3)
74;(tprint 'exit)
Note: See TracBrowser for help on using the repository browser.