source: project/release/5/mailbox/tags/3.0.1/tests/reader-writer-test.scm @ 36201

Last change on this file since 36201 was 36201, checked in by Kon Lovett, 15 months ago

C5 so explicit time-number (fix+float only), rel 3.0.1

File size: 2.9 KB
Line 
1;;;; mailbox tests/reader-writer-test.scm
2
3;;;
4
5(import mailbox)
6(import srfi-18)
7
8;;; Test support
9
10(define-constant MESSAGE-LIMIT 5)
11
12;(define-constant TIMEOUT 4)    ;slow but otherwise ok
13;(define-constant TIMEOUT 0.5)
14(define-constant TIMEOUT 0.25)
15
16(define (current-thread-name) (thread-name (current-thread)))
17
18(define (current-seconds) (time->seconds (current-time)))
19
20(define *critical-section-mutex* (make-mutex (gensym 'critical-section)))
21
22(define-syntax critical-section
23  (syntax-rules (*critical-section-mutex*)
24    ((_ ?body ...)
25      (dynamic-wind
26        (lambda () (mutex-lock! *critical-section-mutex*))
27        (lambda () ?body ...)
28        (lambda () (mutex-unlock! *critical-section-mutex*)) ) ) ) )
29
30(define (thread-labeled-print . args)
31        (critical-section (apply print (current-thread-name) " - " args) ) )
32
33(define (makmsg x) (cons (current-thread-name) x))
34(define (msgfrm x) (car x))
35(define (msgval x) (cdr x))
36
37
38;;; Test mailbox
39
40(let ((mailbox-one (make-mailbox 'one)))
41
42  (define writer-thread-one
43    (make-thread
44      (lambda ()
45        (thread-labeled-print "Started!")
46        (let loop ((cnt 0))
47          (thread-labeled-print "Sending at " (current-seconds) " sec")
48          (mailbox-send! mailbox-one (makmsg cnt))
49          (if (= MESSAGE-LIMIT cnt) (mailbox-send! mailbox-one (makmsg 'quit))
50              (let ((sleep@seconds (current-seconds)))
51                (thread-labeled-print "Sleep at " sleep@seconds " sec")
52                (thread-sleep! TIMEOUT)
53                (thread-labeled-print "Awake after " (- (current-seconds) sleep@seconds) " sec")
54                (loop (add1 cnt)) ) ) ) )
55      'Writer-One) )
56
57  (define reader-thread-one
58    (make-thread
59      (lambda ()
60        (thread-labeled-print "Started!")
61        (let loop ()
62          (let ((rcv@sec (current-seconds)))
63            (condition-case
64                (begin
65                  (thread-labeled-print "Receiving at " rcv@sec  " sec")
66                  (let ((msg (mailbox-receive! mailbox-one TIMEOUT)))
67                    (thread-labeled-print "Message From " (msgfrm msg) " Is " (msgval msg))
68                    (unless (eq? 'quit (msgval msg))
69                      (loop) ) ) )
70              ((exn mailbox timeout)
71                (thread-labeled-print "Timedout after " (- (current-seconds) rcv@sec) " sec")
72                (loop))
73              (exp ()
74                (thread-labeled-print
75                  "Exception: " exp
76                  "; " ((condition-property-accessor 'exn 'location) exp)
77                  ": " ((condition-property-accessor 'exn 'message) exp)
78                  " - " ((condition-property-accessor 'exn 'arguments) exp)) ) ) ) ) )
79      'Reader-One) )
80
81  (newline)
82  (print "** Test mailbox **")
83  (print "Message Limit = " MESSAGE-LIMIT " Timeout = " TIMEOUT " seconds")
84  (newline)
85
86  (thread-start! writer-thread-one)
87  (thread-start! reader-thread-one)
88
89  (thread-join! writer-thread-one)
90  (thread-join! reader-thread-one) )
Note: See TracBrowser for help on using the repository browser.