source: project/release/5/mailbox/trunk/tests/mailbox-cursor-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: 2.7 KB
Line 
1;;;; mailbox tests/mailbox-cursor-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 #;0.5 0.25)
13
14(define (current-thread-name) (thread-name (current-thread)))
15
16(define (current-seconds) (time->seconds (current-time)))
17
18(define *critical-section-mutex* (make-mutex (gensym 'critical-section)))
19
20(define-syntax critical-section
21  (syntax-rules (*critical-section-mutex*)
22    ((_ ?body ...)
23      (dynamic-wind
24        (lambda () (mutex-lock! *critical-section-mutex*))
25        (lambda () ?body ...)
26        (lambda () (mutex-unlock! *critical-section-mutex*)) ) ) ) )
27
28(define (thread-labeled-print . args)
29  (apply print (current-thread-name) " - " args)
30  #; ;only 2 threads!
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-cursor
39
40;;
41
42(let ((mailbox-one (make-mailbox 'one)))
43
44  (define (writer-thread-body)
45    (thread-labeled-print "Started!")
46    (let loop ((cnt 0))
47      (thread-sleep! TIMEOUT)
48      (if (= MESSAGE-LIMIT cnt) (mailbox-send! mailbox-one (makmsg 'quit))
49          (begin
50            (mailbox-send! mailbox-one (makmsg cnt))
51            (loop (add1 cnt))) ) ) )
52
53  (define (make-reader-thread-body test)
54    (lambda ()
55      (thread-labeled-print "Started!")
56      (let ((mbc (make-mailbox-cursor mailbox-one)))
57        (let loop ()
58          (let ((msg (mailbox-cursor-next mbc)))
59            (thread-labeled-print "Message From " (msgfrm msg) " Is " (msgval msg))
60            (unless (eq? 'quit (msgval msg))
61              (when (test msg)
62                (thread-labeled-print "Test Match - Removing Message: " msg)
63                (mailbox-cursor-extract-and-rewind! mbc) )
64              (loop) ) ) ) ) ) )
65
66  ;;
67
68  (define writer-thread-one (make-thread writer-thread-body 'Writer-One))
69
70  (define writer-thread-two (make-thread writer-thread-body 'Writer-Two))
71
72  (define reader-thread-one
73    (make-thread
74      (make-reader-thread-body
75        (lambda (msg) (even? (msgval msg))))
76      'Reader-One) )
77
78  (define reader-thread-two
79    (make-thread
80      (make-reader-thread-body
81        (lambda (msg) (odd? (msgval msg))))
82      'Reader-Two) )
83
84  (newline)
85  (print "** Test mailbox-cursor **")
86  (print "Message Limit = " MESSAGE-LIMIT " Timeout = " TIMEOUT " seconds")
87  (newline)
88
89  (thread-start! reader-thread-one)
90  (thread-start! reader-thread-two)
91  (thread-start! writer-thread-one)
92  (thread-start! writer-thread-two)
93
94  (thread-join! writer-thread-one)
95  (thread-join! writer-thread-two)
96  (thread-join! reader-thread-one)
97  (thread-join! reader-thread-two) )
98
Note: See TracBrowser for help on using the repository browser.