source: project/chicken/branches/hygienic/tests/srfi-18-tests.scm @ 11038

Last change on this file since 11038 was 11038, checked in by Kon Lovett, 11 years ago

Rplcd 'use' w/ 'require-extension'.

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