source: project/release/5/srfi-18/trunk/tests/signal-tests.scm @ 35501

Last change on this file since 35501 was 35501, checked in by kooda, 13 months ago

Update CHICKEN 5's srfi-18 egg

File size: 3.1 KB
Line 
1;;;; signal-tests.scm
2
3(module signal-tests ()
4
5  (import scheme
6          (only chicken flush-output select)
7          (chicken base)
8          (chicken foreign)
9          (chicken format)
10          (chicken random)
11          (chicken process)
12          (chicken process signal)
13          (chicken process-context)
14          srfi-18)
15
16(print "signal-tests.scm")
17
18#+mingw32
19(begin
20  (print "this test can not be run on Windows/mingw")
21  (exit))
22
23
24(define all-go? (make-parameter #f))
25
26;; This is set before starting the child to avoid the race condition
27;; from #877.  The child itself overwrites these signal handlers
28;; before sending the "all go" signal (usr1) to the parent.
29(set-signal-handler! signal/usr1 (lambda (sig) (all-go? #t)))
30
31(define received1 0)
32(define received2 0)
33
34(define (tick c)
35  (write-char c)
36  (flush-output))
37
38(define (handler sig)
39  (select sig
40    ((signal/usr1)
41     (tick #\1)
42     (set! received1 (add1 received1)))
43    ((signal/usr2)
44     (tick #\2)
45     (set! received2 (add1 received2)))))
46
47(define (fini _)
48  (printf "~%child terminating, received: ~a USR1, ~a USR2~%"
49    received1 received2)
50  (thread-sleep! 0.5)
51  (process-signal (parent-process-id) signal/usr1)
52  (exit))
53
54(define (child)
55  (print "child started")
56  (thread-start!
57   (lambda ()
58     (do () (#f)
59       (thread-sleep! 0.5)
60       (tick #\_))))
61  (set-signal-handler! signal/usr1 handler)
62  (set-signal-handler! signal/usr2 handler)
63  (set-signal-handler! signal/term fini)
64  (process-signal (parent-process-id) signal/usr1)
65  (do () (#f)
66    (thread-sleep! 1)
67    (tick #\.)))
68
69(define posix-sleep (foreign-lambda unsigned-int "sleep" unsigned-int))
70
71(let ((pid (process-fork child))
72      (sent1 0)
73      (sent2 0))
74  (print "Sleeping until child wakes us up") ; signal *should* interrupt the sleep
75  (print "would have slept for " (posix-sleep 5) " more seconds")
76  (cond ((all-go?)
77         (print "sending signals to " pid)
78         (do ((i 1000 (sub1 i)))
79             ((zero? i))
80           (thread-sleep! (/ (pseudo-random-integer 10) 1000))
81           (do ((j (pseudo-random-integer 4) (sub1 j)))
82               ((zero? j))
83             (case (pseudo-random-integer 2)
84               ((0)
85                (tick #\A)
86                (set! sent1 (add1 sent1))
87                (process-signal pid signal/usr1))
88               ((1)
89                (tick #\B)
90                (set! sent2 (add1 sent2))
91                (process-signal pid signal/usr2)))))
92         (printf "~%signals sent: ~a USR1, ~a USR2~%" sent1 sent2)
93         (print "terminating child process ...")
94         (all-go? #f)
95         (print "Sending signal and waiting for acknowledgement from child")
96         (process-signal pid signal/term)
97         (unless (all-go?) ; There's a bit of a race condition here, but that's okay
98           (print "Would've slept for " (posix-sleep 5) " more seconds"))
99         (cond ((all-go?)
100                (print "Everything is ok!")
101                (exit 0))
102               (else
103                (print "ERROR! Did not receive acknowledgement of child shutdown within 5 seconds, or another process awoke us")
104                (print "Attempting to kill child forcefully via SIGKILL")
105                (process-signal pid signal/kill)
106                (exit 1))))
107        (else (print "ERROR! Did not receive a signal from child within 10 seconds, or another process awoke us")
108              (print "terminating child process ...")
109              (exit 1))))
110
111)
Note: See TracBrowser for help on using the repository browser.