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

Last change on this file since 34718 was 34718, checked in by sjamaan, 19 months ago

release/5: Replace use by import in eggs

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