source: project/release/5/mailbox/trunk/tests/reader-writer-test.scm @ 39700

Last change on this file since 39700 was 39700, checked in by Kon Lovett, 2 months ago

new test runner, remove "primitives", stop variant `check-' proc gen, fix record printers

File size: 3.0 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  (apply print (current-thread-name) " - " args)
32  #; ;only 2 threads!
33        (critical-section (apply print (current-thread-name) " - " args) ) )
34
35(define (makmsg x) (cons (current-thread-name) x))
36(define (msgfrm x) (car x))
37(define (msgval x) (cdr x))
38
39
40;;; Test mailbox
41
42(let ((mailbox-one (make-mailbox 'one)))
43
44  (define writer-thread-one
45    (make-thread
46      (lambda ()
47        (thread-labeled-print "Started!")
48        (let loop ((cnt 0))
49          (thread-labeled-print "Sending at " (current-seconds) " sec")
50          (mailbox-send! mailbox-one (makmsg cnt))
51          (if (= MESSAGE-LIMIT cnt) (mailbox-send! mailbox-one (makmsg 'quit))
52              (let ((sleep@seconds (current-seconds)))
53                (thread-labeled-print "Sleep at " sleep@seconds " sec")
54                (thread-sleep! TIMEOUT)
55                (thread-labeled-print "Awake after " (- (current-seconds) sleep@seconds) " sec")
56                (loop (add1 cnt)) ) ) ) )
57      'Writer-One) )
58
59  (define reader-thread-one
60    (make-thread
61      (lambda ()
62        (thread-labeled-print "Started!")
63        (let loop ()
64          (let ((rcv@sec (current-seconds)))
65            (condition-case
66                (begin
67                  (thread-labeled-print "Receiving at " rcv@sec  " sec")
68                  (let ((msg (mailbox-receive! mailbox-one TIMEOUT)))
69                    (thread-labeled-print "Message From " (msgfrm msg) " Is " (msgval msg))
70                    (unless (eq? 'quit (msgval msg))
71                      (loop) ) ) )
72              ((exn mailbox timeout)
73                (thread-labeled-print "Timedout after " (- (current-seconds) rcv@sec) " sec")
74                (loop))
75              (exp ()
76                (thread-labeled-print
77                  "Exception: " exp
78                  "; " ((condition-property-accessor 'exn 'location) exp)
79                  ": " ((condition-property-accessor 'exn 'message) exp)
80                  " - " ((condition-property-accessor 'exn 'arguments) exp)) ) ) ) ) )
81      'Reader-One) )
82
83  (newline)
84  (print "** Test mailbox **")
85  (print "Message Limit = " MESSAGE-LIMIT " Timeout = " TIMEOUT " seconds")
86  (newline)
87
88  (thread-start! writer-thread-one)
89  (thread-start! reader-thread-one)
90
91  (thread-join! writer-thread-one)
92  (thread-join! reader-thread-one) )
Note: See TracBrowser for help on using the repository browser.