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

Last change on this file was 35501, checked in by Kooda, 20 months ago

Update CHICKEN 5's srfi-18 egg

File size: 2.0 KB
Line 
1(print "srfi-18-signal-test.scm")
2 
3#+mingw32
4(begin
5  (print "this test can not be run on Windows/mingw unless we find a way to send signals")
6  (exit))
7
8(import (chicken process signal) (chicken foreign) srfi-18)
9
10(define done #f)
11
12; set done = true on timer expiration
13(set-signal-handler! signal/alrm (lambda (signal) (set! done #t)))
14
15(define (work-loop count)
16  (cond ((> count 100) (error "Loop limit exceeded"))
17        ((not done)
18         (display ".")
19         (thread-sleep! 0.25)
20         (work-loop (add1 count)))))
21
22(define (new-thread)
23  (set! done #f)
24  (make-thread (lambda () (work-loop 0))))
25
26;; Needs external signal (not from another thread) it seems,
27;; so let the OS deliver it to us when we're ready:
28(foreign-declare "#include <sys/time.h>")
29((foreign-lambda* void ()
30   "#ifndef __MINGW32__ \n"
31   "struct itimerval timer;"
32   "timer.it_value.tv_sec = 1;"
33   "timer.it_value.tv_usec = 0;"
34   "timer.it_interval.tv_sec = 0;"
35   "timer.it_interval.tv_usec = 0;"
36   "setitimer(ITIMER_REAL, &timer, NULL);\n"
37   "#endif"))
38
39(display "Testing correct handling of thread-join! with external signals:")
40(flush-output)
41(let ((t (new-thread)))
42  (thread-start! t)
43  (thread-join! t))
44
45(print " thread terminated gracefully, this is good")
46
47(display "thread-join with timeout: ")
48(flush-output)
49(let ((t (new-thread)))
50  (condition-case (begin (thread-start! t)
51                         (thread-join! t 1))
52    ((join-timeout-exception)
53     (print "timeout exception as expected")
54     (thread-terminate! t))
55    (exn ()
56         (thread-terminate! t)
57         (signal exn))))
58
59
60(display "thread-join with return value:")
61(flush-output)
62(let ((t (new-thread)))
63  (assert (condition-case (begin (thread-start! t)
64                                 (thread-join! t 1 'bla))
65           ((join-timeout-exception)
66            (print " timeout exception as expected")
67            (thread-terminate! t))
68           (exn ()
69                (thread-terminate! t)
70                (signal exn)))
71          'bla))
72
73(print " done.")
Note: See TracBrowser for help on using the repository browser.