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

Last change on this file since 35707 was 35707, checked in by evhan, 14 months ago

reset prerelease eggs to version 0.1

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