mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-19 05:39:18 +02:00
4e5cdedc03
By convention, a library meant for testing exports "run-tests". Also by convention, assume the test for (foo bar) is (foo bar-test), keeping the test in the same directory and avoiding confusion since (chibi test) is not a test for (chibi). - Avoids the hack of "load"ing test, with resulting namespace complications. - Allows keeping tests together with the libraries. - Allows setting up test hooks before running. - Allows implicit inference of test locations when using above conventions.
114 lines
3.8 KiB
Scheme
114 lines
3.8 KiB
Scheme
(define-library (srfi 18 test)
|
|
(export run-tests)
|
|
(import (chibi) (srfi 18) (srfi 39) (chibi test))
|
|
(begin
|
|
(define (run-tests)
|
|
(test-begin "srfi-18: threads")
|
|
|
|
(test "no threads" 'ok (begin 'ok))
|
|
|
|
(test "unstarted thread" 'ok
|
|
(let ((t (make-thread (lambda () (error "oops"))))) 'ok))
|
|
|
|
(test "ignored thread terminates" 'ok
|
|
(let ((t (make-thread (lambda () 'oops)))) (thread-start! t) 'ok))
|
|
|
|
(test "ignored thread hangs" 'ok
|
|
(let ((t (make-thread (lambda () (let lp () (lp))))))
|
|
(thread-start! t)
|
|
'ok))
|
|
|
|
(test "joined thread terminates" 'ok
|
|
(let ((t (make-thread (lambda () 'oops))))
|
|
(thread-start! t)
|
|
(thread-join! t)
|
|
'ok))
|
|
|
|
(test "joined thread hangs, timeout" 'timeout
|
|
(let ((t (make-thread (lambda () (let lp () (lp))))))
|
|
(thread-start! t)
|
|
(thread-join! t 0.1 'timeout)))
|
|
|
|
(test "basic mutex" 'ok
|
|
(let ((m (make-mutex)))
|
|
(and (mutex? m) 'ok)))
|
|
|
|
(test "mutex unlock" 'ok
|
|
(let ((m (make-mutex)))
|
|
(and (mutex-unlock! m) 'ok)))
|
|
|
|
(test "mutex lock/unlock" 'ok
|
|
(let ((m (make-mutex)))
|
|
(and (mutex-lock! m)
|
|
(mutex-unlock! m)
|
|
'ok)))
|
|
|
|
(test "mutex lock/lock" 'timeout
|
|
(let ((m (make-mutex)))
|
|
(and (mutex-lock! m)
|
|
(if (mutex-lock! m 0.1) 'fail 'timeout))))
|
|
|
|
(test "mutex lock timeout" 'timeout
|
|
(let* ((m (make-mutex))
|
|
(t (make-thread (lambda () (mutex-lock! m)))))
|
|
(thread-start! t)
|
|
(thread-yield!)
|
|
(if (mutex-lock! m 0.1) 'fail 'timeout)))
|
|
|
|
(test "mutex lock/unlock/lock/lock" 'timeout
|
|
(let* ((m (make-mutex))
|
|
(t (make-thread (lambda () (mutex-unlock! m)))))
|
|
(mutex-lock! m)
|
|
(thread-start! t)
|
|
(if (mutex-lock! m 0.1)
|
|
(if (mutex-lock! m 0.1) 'fail-second 'timeout)
|
|
'bad-timeout)))
|
|
|
|
(test "thread-join! end result" 5
|
|
(let* ((th (make-thread (lambda () (+ 3 2)))))
|
|
(thread-start! th)
|
|
(thread-join! th)))
|
|
|
|
(test-error "thread-join! exception"
|
|
(let* ((th (make-thread
|
|
(lambda ()
|
|
(parameterize ((current-error-port (open-output-string)))
|
|
(+ 3 "2"))))))
|
|
(thread-start! th)
|
|
(thread-join! th)))
|
|
|
|
(test-assert "make-condition-variable"
|
|
(condition-variable? (make-condition-variable)))
|
|
|
|
(test "condition-variable signal" 'ok
|
|
(let* ((mutex (make-mutex))
|
|
(cndvar (make-condition-variable))
|
|
(th (make-thread
|
|
(lambda ()
|
|
(if (mutex-unlock! mutex cndvar 0.1) 'ok 'timeout1)))))
|
|
(thread-start! th)
|
|
(thread-yield!)
|
|
(condition-variable-signal! cndvar)
|
|
(thread-join! th 0.1 'timeout2)))
|
|
|
|
(test "condition-variable broadcast" '(ok1 ok2)
|
|
(let* ((mutex (make-mutex))
|
|
(cndvar (make-condition-variable))
|
|
(th1 (make-thread
|
|
(lambda ()
|
|
(mutex-lock! mutex)
|
|
(if (mutex-unlock! mutex cndvar 1.0) 'ok1 'timeout1))))
|
|
(th2 (make-thread
|
|
(lambda ()
|
|
(mutex-lock! mutex)
|
|
(if (mutex-unlock! mutex cndvar 1.0) 'ok2 'timeout2)))))
|
|
(thread-start! th1)
|
|
(thread-start! th2)
|
|
(thread-yield!)
|
|
(mutex-lock! mutex)
|
|
(condition-variable-broadcast! cndvar)
|
|
(mutex-unlock! mutex)
|
|
(list (thread-join! th1 0.1 'timeout3)
|
|
(thread-join! th2 0.1 'timeout4))))
|
|
|
|
(test-end))))
|