mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-01 20:30:28 +02:00
Code Activity

srfi-18 test fix

Browse source 
* test-suite/tests/srfi-18.test: Enclose the tests in a begin instead of
  an and.  Before, they were not being run, for some reason I don't
  fully understand.
This commit is contained in:
Andy Wingo 2012-02-24 20:01:47 +01:00
parent 006163e02f
commit a850c3ccc4
1 changed files with 373 additions and 376 deletions
Download patch file Download diff file Expand all files Collapse all files

915
test-suite/tests/srfi-18.test
View file

@ -1,7 +1,7 @@
;;;; srfi-18.test --- Test suite for Guile's SRFI-18 functions. -*- scheme -*- ;;;; srfi-18.test --- Test suite for Guile's SRFI-18 functions. -*- scheme -*-
;;;; Julian Graham, 2007-10-26 ;;;; Julian Graham, 2007-10-26
;;;; ;;;;
;;;; Copyright (C) 2007, 2008 Free Software Foundation, Inc. ;;;; Copyright (C) 2007, 2008, 2012 Free Software Foundation, Inc.
;;;; ;;;;
;;;; This library is free software; you can redistribute it and/or ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -25,461 +25,458 @@
(if (provided? 'threads) (if (provided? 'threads)
(use-modules (srfi srfi-18))) (use-modules (srfi srfi-18)))
(and (cond
(provided? 'threads) ((provided? 'threads)
(with-test-prefix "current-thread"
(with-test-prefix "current-thread"
(pass-if "current-thread eq current-thread"
(pass-if "current-thread eq current-thread" (eq? (current-thread) (current-thread))))
(eq? (current-thread) (current-thread))))
(with-test-prefix "thread?"
(with-test-prefix "thread?"
(pass-if "current-thread is thread"
(pass-if "current-thread is thread" (thread? (current-thread)))
(thread? (current-thread)))
(pass-if "foo not thread"
(pass-if "foo not thread" (not (thread? 'foo))))
(not (thread? 'foo))))
(with-test-prefix "make-thread"
(with-test-prefix "make-thread"
(pass-if "make-thread creates new thread"
(pass-if "make-thread creates new thread" (let* ((n (length (all-threads)))
(let* ((n (length (all-threads))) (t (make-thread (lambda () 'foo) 'make-thread-1))
(t (make-thread (lambda () 'foo) 'make-thread-1)) (r (> (length (all-threads)) n)))
(r (> (length (all-threads)) n))) (thread-terminate! t) r)))
(thread-terminate! t) r)))
(with-test-prefix "thread-name"
(with-test-prefix "thread-name"
(pass-if "make-thread with name binds name"
(pass-if "make-thread with name binds name" (let* ((t (make-thread (lambda () 'foo) 'thread-name-1))
(let* ((t (make-thread (lambda () 'foo) 'thread-name-1)) (r (eq? (thread-name t) 'thread-name-1)))
(r (eq? (thread-name t) 'thread-name-1))) (thread-terminate! t) r))
(thread-terminate! t) r))
(pass-if "make-thread without name does not bind name"
(pass-if "make-thread without name does not bind name" (let* ((t (make-thread (lambda () 'foo)))
(let* ((t (make-thread (lambda () 'foo))) (r (not (thread-name t))))
(r (not (thread-name t)))) (thread-terminate! t) r)))
(thread-terminate! t) r)))
(with-test-prefix "thread-specific"
(with-test-prefix "thread-specific"
(pass-if "thread-specific is initially #f"
(pass-if "thread-specific is initially #f" (let* ((t (make-thread (lambda () 'foo) 'thread-specific-1))
(let* ((t (make-thread (lambda () 'foo) 'thread-specific-1)) (r (not (thread-specific t))))
(r (not (thread-specific t)))) (thread-terminate! t) r))
(thread-terminate! t) r))
(pass-if "thread-specific-set! can set value"
(pass-if "thread-specific-set! can set value" (let ((t (make-thread (lambda () 'foo) 'thread-specific-2)))
(let ((t (make-thread (lambda () 'foo) 'thread-specific-2))) (thread-specific-set! t "hello")
(thread-specific-set! t "hello") (let ((r (equal? (thread-specific t) "hello")))
(let ((r (equal? (thread-specific t) "hello"))) (thread-terminate! t) r))))
(thread-terminate! t) r))))
(with-test-prefix "thread-start!"
(with-test-prefix "thread-start!"
(pass-if "thread activates only after start"
(pass-if "thread activates only after start" (let* ((started #f)
(let* ((started #f) (m (make-mutex 'thread-start-mutex))
(m (make-mutex 'thread-start-mutex)) (t (make-thread (lambda () (set! started #t)) 'thread-start-1)))
(t (make-thread (lambda () (set! started #t)) 'thread-start-1))) (and (not started) (thread-start! t) (thread-join! t) started))))
(and (not started) (thread-start! t) (thread-join! t) started))))
(with-test-prefix "thread-yield!"
(with-test-prefix "thread-yield!"
(pass-if "thread yield suceeds"
(pass-if "thread yield suceeds" (thread-yield!) #t))
(thread-yield!) #t))
(with-test-prefix "thread-sleep!"
(with-test-prefix "thread-sleep!"
(pass-if "thread sleep with time"
(pass-if "thread sleep with time" (let ((future-time (seconds->time (+ (time->seconds (current-time)) 2))))
(let ((future-time (seconds->time (+ (time->seconds (current-time)) 2)))) (unspecified? (thread-sleep! future-time))))
(unspecified? (thread-sleep! future-time))))
(pass-if "thread sleep with number"
(pass-if "thread sleep with number" (let ((old-secs (car (current-time))))
(let ((old-secs (car (current-time)))) (unspecified? (thread-sleep! (+ (time->seconds (current-time)))))))
(unspecified? (thread-sleep! (+ (time->seconds (current-time)))))))
(pass-if "thread does not sleep on past time"
(pass-if "thread does not sleep on past time" (let ((past-time (seconds->time (- (time->seconds (current-time)) 2))))
(let ((past-time (seconds->time (- (time->seconds (current-time)) 2)))) (unspecified? (thread-sleep! past-time)))))
(unspecified? (thread-sleep! past-time)))))
(with-test-prefix "thread-terminate!"
(with-test-prefix "thread-terminate!"
(pass-if "termination destroys non-started thread"
(pass-if "termination destroys non-started thread" (let ((t (make-thread (lambda () 'nothing) 'thread-terminate-1))
(let ((t (make-thread (lambda () 'nothing) 'thread-terminate-1)) (num-threads (length (all-threads)))
(num-threads (length (all-threads))) (success #f))
(success #f)) (thread-terminate! t)
(thread-terminate! t) (with-exception-handler
(with-exception-handler (lambda (obj) (set! success (terminated-thread-exception? obj)))
(lambda (obj) (set! success (terminated-thread-exception? obj))) (lambda () (thread-join! t)))
(lambda () (thread-join! t))) success))
success))
(pass-if "termination destroys started thread"
(pass-if "termination destroys started thread" (let* ((m1 (make-mutex 'thread-terminate-2a))
(let* ((m1 (make-mutex 'thread-terminate-2a)) (m2 (make-mutex 'thread-terminate-2b))
(m2 (make-mutex 'thread-terminate-2b)) (c (make-condition-variable 'thread-terminate-2))
(c (make-condition-variable 'thread-terminate-2)) (t (make-thread (lambda ()
(t (make-thread (lambda () (mutex-lock! m1)
(mutex-lock! m1) (condition-variable-signal! c)
(condition-variable-signal! c) (mutex-unlock! m1)
(mutex-unlock! m1) (mutex-lock! m2))
(mutex-lock! m2)) 'thread-terminate-2))
'thread-terminate-2)) (success #f))
(success #f)) (mutex-lock! m1)
(mutex-lock! m1) (mutex-lock! m2)
(mutex-lock! m2) (thread-start! t)
(thread-start! t) (mutex-unlock! m1 c)
(mutex-unlock! m1 c) (thread-terminate! t)
(thread-terminate! t) (with-exception-handler
(with-exception-handler (lambda (obj) (set! success (terminated-thread-exception? obj)))
(lambda (obj) (set! success (terminated-thread-exception? obj))) (lambda () (thread-join! t)))
(lambda () (thread-join! t))) success)))
success)))
(with-test-prefix "thread-join!"
(with-test-prefix "thread-join!"
(pass-if "join receives result of thread"
(pass-if "join receives result of thread" (let ((t (make-thread (lambda () 'foo) 'thread-join-1)))
(let ((t (make-thread (lambda () 'foo) 'thread-join-1))) (thread-start! t)
(thread-start! t) (eq? (thread-join! t) 'foo)))
(eq? (thread-join! t) 'foo)))
(pass-if "join receives timeout val if timeout expires"
(pass-if "join receives timeout val if timeout expires" (let* ((m (make-mutex 'thread-join-2))
(let* ((m (make-mutex 'thread-join-2)) (t (make-thread (lambda () (mutex-lock! m)) 'thread-join-2)))
(t (make-thread (lambda () (mutex-lock! m)) 'thread-join-2))) (mutex-lock! m)
(mutex-lock! m) (thread-start! t)
(thread-start! t) (let ((r (thread-join! t (current-time) 'bar)))
(let ((r (thread-join! t (current-time) 'bar))) (thread-terminate! t)
(thread-terminate! t) (eq? r 'bar))))
(eq? r 'bar))))
(pass-if "join throws exception on timeout without timeout val"
(pass-if "join throws exception on timeout without timeout val" (let* ((m (make-mutex 'thread-join-3))
(let* ((m (make-mutex 'thread-join-3)) (t (make-thread (lambda () (mutex-lock! m)) 'thread-join-3))
(t (make-thread (lambda () (mutex-lock! m)) 'thread-join-3)) (success #f))
(success #f)) (mutex-lock! m)
(mutex-lock! m) (thread-start! t)
(thread-start! t) (with-exception-handler
(with-exception-handler (lambda (obj) (set! success (join-timeout-exception? obj)))
(lambda (obj) (set! success (join-timeout-exception? obj))) (lambda () (thread-join! t (current-time))))
(lambda () (thread-join! t (current-time)))) (thread-terminate! t)
(thread-terminate! t) success))
success))
(pass-if "join waits on timeout"
(pass-if "join waits on timeout" (let ((t (make-thread (lambda () (sleep 1) 'foo) 'thread-join-4)))
(let ((t (make-thread (lambda () (sleep 1) 'foo) 'thread-join-4))) (thread-start! t)
(thread-start! t) (eq? (thread-join! t (+ (time->seconds (current-time)) 2)) 'foo))))
(eq? (thread-join! t (+ (time->seconds (current-time)) 2)) 'foo))))
(with-test-prefix "mutex?"
(with-test-prefix "mutex?"
(pass-if "make-mutex creates mutex"
(pass-if "make-mutex creates mutex" (mutex? (make-mutex)))
(mutex? (make-mutex)))
(pass-if "symbol not mutex"
(pass-if "symbol not mutex" (not (mutex? 'foo))))
(not (mutex? 'foo))))
(with-test-prefix "mutex-name"
(with-test-prefix "mutex-name"
(pass-if "make-mutex with name binds name"
(pass-if "make-mutex with name binds name" (let* ((m (make-mutex 'mutex-name-1)))
(let* ((m (make-mutex 'mutex-name-1))) (eq? (mutex-name m) 'mutex-name-1)))
(eq? (mutex-name m) 'mutex-name-1)))
(pass-if "make-mutex without name does not bind name"
(pass-if "make-mutex without name does not bind name" (let* ((m (make-mutex)))
(let* ((m (make-mutex))) (not (mutex-name m)))))
(not (mutex-name m)))))
(with-test-prefix "mutex-specific"
(with-test-prefix "mutex-specific"
(pass-if "mutex-specific is initially #f"
(pass-if "mutex-specific is initially #f" (let ((m (make-mutex 'mutex-specific-1)))
(let ((m (make-mutex 'mutex-specific-1))) (not (mutex-specific m))))
(not (mutex-specific m))))
(pass-if "mutex-specific-set! can set value"
(pass-if "mutex-specific-set! can set value" (let ((m (make-mutex 'mutex-specific-2)))
(let ((m (make-mutex 'mutex-specific-2))) (mutex-specific-set! m "hello")
(mutex-specific-set! m "hello") (equal? (mutex-specific m) "hello"))))
(equal? (mutex-specific m) "hello"))))
(with-test-prefix "mutex-state"
(with-test-prefix "mutex-state"
(pass-if "mutex state is initially not-abandoned"
(pass-if "mutex state is initially not-abandoned" (let ((m (make-mutex 'mutex-state-1)))
(let ((m (make-mutex 'mutex-state-1))) (eq? (mutex-state m) 'not-abandoned)))
(eq? (mutex-state m) 'not-abandoned)))
(pass-if "mutex state of locked, owned mutex is owner thread"
(pass-if "mutex state of locked, owned mutex is owner thread" (let ((m (make-mutex 'mutex-state-2)))
(let ((m (make-mutex 'mutex-state-2))) (mutex-lock! m)
(mutex-lock! m) (eq? (mutex-state m) (current-thread))))
(eq? (mutex-state m) (current-thread))))
(pass-if "mutex state of locked, unowned mutex is not-owned"
(pass-if "mutex state of locked, unowned mutex is not-owned" (let ((m (make-mutex 'mutex-state-3)))
(let ((m (make-mutex 'mutex-state-3))) (mutex-lock! m #f #f)
(mutex-lock! m #f #f) (eq? (mutex-state m) 'not-owned)))
(eq? (mutex-state m) 'not-owned)))
(pass-if "mutex state of unlocked, abandoned mutex is abandoned"
(pass-if "mutex state of unlocked, abandoned mutex is abandoned" (let* ((m (make-mutex 'mutex-state-4))
(let* ((m (make-mutex 'mutex-state-4)) (t (make-thread (lambda () (mutex-lock! m)))))
(t (make-thread (lambda () (mutex-lock! m))))) (thread-start! t)
(thread-start! t) (thread-join! t)
(thread-join! t) (eq? (mutex-state m) 'abandoned))))
(eq? (mutex-state m) 'abandoned))))
(with-test-prefix "mutex-lock!"
(with-test-prefix "mutex-lock!"
(pass-if "mutex-lock! returns true on successful lock"
(pass-if "mutex-lock! returns true on successful lock" (let* ((m (make-mutex 'mutex-lock-1)))
(let* ((m (make-mutex 'mutex-lock-1))) (mutex-lock! m)))
(mutex-lock! m)))
(pass-if "mutex-lock! returns false on timeout"
(pass-if "mutex-lock! returns false on timeout" (let* ((m (make-mutex 'mutex-lock-2))
(let* ((m (make-mutex 'mutex-lock-2)) (t (make-thread (lambda () (mutex-lock! m (current-time) #f)))))
(t (make-thread (lambda () (mutex-lock! m (current-time) #f))))) (mutex-lock! m)
(mutex-lock! m) (thread-start! t)
(thread-start! t) (not (thread-join! t))))
(not (thread-join! t))))
(pass-if "mutex-lock! returns true when lock obtained within timeout"
(pass-if "mutex-lock! returns true when lock obtained within timeout" (let* ((m (make-mutex 'mutex-lock-3))
(let* ((m (make-mutex 'mutex-lock-3)) (t (make-thread (lambda ()
(t (make-thread (lambda () (mutex-lock! m (+ (time->seconds (current-time))
(mutex-lock! m (+ (time->seconds (current-time)) 100)
100) #f)))))
#f))))) (mutex-lock! m)
(mutex-lock! m) (thread-start! t)
(thread-start! t) (mutex-unlock! m)
(mutex-unlock! m) (thread-join! t)))
(thread-join! t)))
(pass-if "can lock mutex for non-current thread"
(pass-if "can lock mutex for non-current thread" (let* ((m1 (make-mutex 'mutex-lock-4a))
(let* ((m1 (make-mutex 'mutex-lock-4a)) (m2 (make-mutex 'mutex-lock-4b))
(m2 (make-mutex 'mutex-lock-4b)) (t (make-thread (lambda () (mutex-lock! m1)) 'mutex-lock-4)))
(t (make-thread (lambda () (mutex-lock! m1)) 'mutex-lock-4))) (mutex-lock! m1)
(mutex-lock! m1) (thread-start! t)
(thread-start! t) (mutex-lock! m2 #f t)
(mutex-lock! m2 #f t) (let ((success (eq? (mutex-state m2) t)))
(let ((success (eq? (mutex-state m2) t))) (thread-terminate! t) success)))
(thread-terminate! t) success)))
(pass-if "locking abandoned mutex throws exception"
(pass-if "locking abandoned mutex throws exception" (let* ((m (make-mutex 'mutex-lock-5))
(let* ((m (make-mutex 'mutex-lock-5)) (t (make-thread (lambda () (mutex-lock! m)) 'mutex-lock-5))
(t (make-thread (lambda () (mutex-lock! m)) 'mutex-lock-5)) (success #f))
(success #f)) (thread-start! t)
(thread-start! t) (thread-join! t)
(thread-join! t) (with-exception-handler
(with-exception-handler (lambda (obj) (set! success (abandoned-mutex-exception? obj)))
(lambda (obj) (set! success (abandoned-mutex-exception? obj))) (lambda () (mutex-lock! m)))
(lambda () (mutex-lock! m))) (and success (eq? (mutex-state m) (current-thread)))))
(and success (eq? (mutex-state m) (current-thread)))))
(pass-if "sleeping threads notified of abandonment"
(pass-if "sleeping threads notified of abandonment" (let* ((m1 (make-mutex 'mutex-lock-6a))
(let* ((m1 (make-mutex 'mutex-lock-6a)) (m2 (make-mutex 'mutex-lock-6b))
(m2 (make-mutex 'mutex-lock-6b)) (c (make-condition-variable 'mutex-lock-6))
(c (make-condition-variable 'mutex-lock-6)) (t (make-thread (lambda ()
(t (make-thread (lambda () (mutex-lock! m1)
(mutex-lock! m1) (mutex-lock! m2)
(mutex-lock! m2) (condition-variable-signal! c))))
(condition-variable-signal! c)))) (success #f))
(success #f)) (mutex-lock! m1)
(mutex-lock! m1) (thread-start! t)
(thread-start! t) (with-exception-handler
(with-exception-handler (lambda (obj) (set! success (abandoned-mutex-exception? obj)))
(lambda (obj) (set! success (abandoned-mutex-exception? obj))) (lambda () (mutex-unlock! m1 c) (mutex-lock! m2)))
(lambda () (mutex-unlock! m1 c) (mutex-lock! m2))) success)))
success)))
(with-test-prefix "mutex-unlock!"
(with-test-prefix "mutex-unlock!"
(pass-if "unlock changes mutex state"
(pass-if "unlock changes mutex state" (let* ((m (make-mutex 'mutex-unlock-1)))
(let* ((m (make-mutex 'mutex-unlock-1))) (mutex-lock! m)
(mutex-lock! m) (mutex-unlock! m)
(mutex-unlock! m) (eq? (mutex-state m) 'not-abandoned)))
(eq? (mutex-state m) 'not-abandoned)))
(pass-if "can unlock from any thread"
(pass-if "can unlock from any thread" (let* ((m (make-mutex 'mutex-unlock-2))
(let* ((m (make-mutex 'mutex-unlock-2)) (t (make-thread (lambda () (mutex-unlock! m)) 'mutex-unlock-2)))
(t (make-thread (lambda () (mutex-unlock! m)) 'mutex-unlock-2))) (mutex-lock! m)
(mutex-lock! m) (thread-start! t)
(thread-start! t) (thread-join! t)
(thread-join! t) (eq? (mutex-state m) 'not-abandoned)))
(eq? (mutex-state m) 'not-abandoned)))
(pass-if "mutex unlock is true when condition is signalled"
(pass-if "mutex unlock is true when condition is signalled" (let* ((m (make-mutex 'mutex-unlock-3))
(let* ((m (make-mutex 'mutex-unlock-3)) (c (make-condition-variable 'mutex-unlock-3))
(c (make-condition-variable 'mutex-unlock-3)) (t (make-thread (lambda ()
(t (make-thread (lambda () (mutex-lock! m)
(mutex-lock! m) (condition-variable-signal! c)
(condition-variable-signal! c) (mutex-unlock! m)))))
(mutex-unlock! m))))) (mutex-lock! m)
(mutex-lock! m) (thread-start! t)
(thread-start! t) (mutex-unlock! m c)))
(mutex-unlock! m c)))
(pass-if "mutex unlock is false when condition times out"
(pass-if "mutex unlock is false when condition times out" (let* ((m (make-mutex 'mutex-unlock-4))
(let* ((m (make-mutex 'mutex-unlock-4)) (c (make-condition-variable 'mutex-unlock-4)))
(c (make-condition-variable 'mutex-unlock-4))) (mutex-lock! m)
(mutex-lock! m) (not (mutex-unlock! m c (+ (time->seconds (current-time)) 1))))))
(not (mutex-unlock! m c (+ (time->seconds (current-time)) 1))))))
(with-test-prefix "condition-variable?"
(with-test-prefix "condition-variable?"
(pass-if "make-condition-variable creates condition variable"
(pass-if "make-condition-variable creates condition variable" (condition-variable? (make-condition-variable)))
(condition-variable? (make-condition-variable)))
(pass-if "symbol not condition variable"
(pass-if "symbol not condition variable" (not (condition-variable? 'foo))))
(not (condition-variable? 'foo))))
(with-test-prefix "condition-variable-name"
(with-test-prefix "condition-variable-name"
(pass-if "make-condition-variable with name binds name"
(pass-if "make-condition-variable with name binds name" (let* ((c (make-condition-variable 'condition-variable-name-1)))
(let* ((c (make-condition-variable 'condition-variable-name-1))) (eq? (condition-variable-name c) 'condition-variable-name-1)))
(eq? (condition-variable-name c) 'condition-variable-name-1)))
(pass-if "make-condition-variable without name does not bind name"
(pass-if "make-condition-variable without name does not bind name" (let* ((c (make-condition-variable)))
(let* ((c (make-condition-variable))) (not (condition-variable-name c)))))
(not (condition-variable-name c)))))
(with-test-prefix "condition-variable-specific"
(with-test-prefix "condition-variable-specific"
(pass-if "condition-variable-specific is initially #f"
(pass-if "condition-variable-specific is initially #f" (let ((c (make-condition-variable 'condition-variable-specific-1)))
(let ((c (make-condition-variable 'condition-variable-specific-1))) (not (condition-variable-specific c))))
(not (condition-variable-specific c))))
(pass-if "condition-variable-specific-set! can set value"
(pass-if "condition-variable-specific-set! can set value" (let ((c (make-condition-variable 'condition-variable-specific-1)))
(let ((c (make-condition-variable 'condition-variable-specific-1))) (condition-variable-specific-set! c "hello")
(condition-variable-specific-set! c "hello") (equal? (condition-variable-specific c) "hello"))))
(equal? (condition-variable-specific c) "hello"))))
(with-test-prefix "condition-variable-signal!"
(with-test-prefix "condition-variable-signal!"
(pass-if "condition-variable-signal! wakes up single thread"
(pass-if "condition-variable-signal! wakes up single thread" (let* ((m (make-mutex 'condition-variable-signal-1))
(let* ((m (make-mutex 'condition-variable-signal-1)) (c (make-condition-variable 'condition-variable-signal-1))
(c (make-condition-variable 'condition-variable-signal-1)) (t (make-thread (lambda ()
(t (make-thread (lambda () (mutex-lock! m)
(mutex-lock! m) (condition-variable-signal! c)
(condition-variable-signal! c) (mutex-unlock! m)))))
(mutex-unlock! m))))) (mutex-lock! m)
(mutex-lock! m) (thread-start! t)
(thread-start! t) (mutex-unlock! m c))))
(mutex-unlock! m c))))
(with-test-prefix "condition-variable-broadcast!"
(with-test-prefix "condition-variable-broadcast!"
(pass-if "condition-variable-broadcast! wakes up multiple threads"
(pass-if "condition-variable-broadcast! wakes up multiple threads" (let* ((sem 0)
(let* ((sem 0) (c1 (make-condition-variable 'condition-variable-broadcast-1-a))
(c1 (make-condition-variable 'condition-variable-broadcast-1-a)) (m1 (make-mutex 'condition-variable-broadcast-1-a))
(m1 (make-mutex 'condition-variable-broadcast-1-a)) (c2 (make-condition-variable 'condition-variable-broadcast-1-b))
(c2 (make-condition-variable 'condition-variable-broadcast-1-b)) (m2 (make-mutex 'condition-variable-broadcast-1-b))
(m2 (make-mutex 'condition-variable-broadcast-1-b)) (inc-sem! (lambda ()
(inc-sem! (lambda () (mutex-lock! m1)
(mutex-lock! m1) (set! sem (+ sem 1))
(set! sem (+ sem 1)) (condition-variable-broadcast! c1)
(condition-variable-broadcast! c1) (mutex-unlock! m1)))
(mutex-unlock! m1))) (dec-sem! (lambda ()
(dec-sem! (lambda () (mutex-lock! m1)
(mutex-lock! m1) (while (eqv? sem 0) (wait-condition-variable c1 m1))
(while (eqv? sem 0) (wait-condition-variable c1 m1)) (set! sem (- sem 1))
(set! sem (- sem 1)) (mutex-unlock! m1)))
(mutex-unlock! m1))) (t1 (make-thread (lambda ()
(t1 (make-thread (lambda () (mutex-lock! m2)
(mutex-lock! m2) (inc-sem!)
(inc-sem!) (mutex-unlock! m2 c2)
(mutex-unlock! m2 c2) (inc-sem!))))
(inc-sem!)))) (t2 (make-thread (lambda ()
(t2 (make-thread (lambda () (mutex-lock! m2)
(mutex-lock! m2) (inc-sem!)
(inc-sem!) (mutex-unlock! m2 c2)
(mutex-unlock! m2 c2) (inc-sem!)))))
(inc-sem!))))) (thread-start! t1)
(thread-start! t1) (thread-start! t2)
(thread-start! t2) (dec-sem!)
(dec-sem!) (dec-sem!)
(dec-sem!) (mutex-lock! m2)
(mutex-lock! m2) (condition-variable-broadcast! c2)
(condition-variable-broadcast! c2) (mutex-unlock! m2)
(mutex-unlock! m2) (dec-sem!)
(dec-sem!) (dec-sem!))))
(dec-sem!))))
(with-test-prefix "time?"
(with-test-prefix "time?"
(pass-if "current-time is time" (time? (current-time)))
(pass-if "current-time is time" (time? (current-time))) (pass-if "number is not time" (not (time? 123)))
(pass-if "number is not time" (not (time? 123))) (pass-if "symbol not time" (not (time? 'foo))))
(pass-if "symbol not time" (not (time? 'foo))))
(with-test-prefix "time->seconds"
(with-test-prefix "time->seconds"
(pass-if "time->seconds makes time into rational"
(pass-if "time->seconds makes time into rational" (rational? (time->seconds (current-time))))
(rational? (time->seconds (current-time))))
(pass-if "time->seconds is reversible"
(pass-if "time->seconds is reversible" (let ((t (current-time)))
(let ((t (current-time))) (equal? t (seconds->time (time->seconds t))))))
(equal? t (seconds->time (time->seconds t))))))
(with-test-prefix "seconds->time"
(with-test-prefix "seconds->time"
(pass-if "seconds->time makes rational into time"
(pass-if "seconds->time makes rational into time" (time? (seconds->time 123.456)))
(time? (seconds->time 123.456)))
(pass-if "seconds->time is reversible"
(pass-if "seconds->time is reversible" (let ((t (time->seconds (current-time))))
(let ((t (time->seconds (current-time)))) (equal? t (time->seconds (seconds->time t))))))
(equal? t (time->seconds (seconds->time t))))))
(with-test-prefix "current-exception-handler"
(with-test-prefix "current-exception-handler"
(pass-if "current handler returned at top level"
(pass-if "current handler returned at top level" (procedure? (current-exception-handler)))
(procedure? (current-exception-handler)))
(pass-if "specified handler set under with-exception-handler"
(pass-if "specified handler set under with-exception-handler" (let ((h (lambda (key . args) 'nothing)))
(let ((h (lambda (key . args) 'nothing))) (with-exception-handler h (lambda () (eq? (current-exception-handler)
(with-exception-handler h (lambda () (eq? (current-exception-handler) h)))))
h)))))
(pass-if "multiple levels of handler nesting"
(pass-if "multiple levels of handler nesting" (let ((h (lambda (key . args) 'nothing))
(let ((h (lambda (key . args) 'nothing)) (i (current-exception-handler)))
(i (current-exception-handler))) (and (with-exception-handler h (lambda ()
(and (with-exception-handler h (lambda () (eq? (current-exception-handler) h)))
(eq? (current-exception-handler) h))) (eq? (current-exception-handler) i))))
(eq? (current-exception-handler) i))))
(pass-if "exception handler installation is thread-safe"
(pass-if "exception handler installation is thread-safe" (let* ((h1 (current-exception-handler))
(let* ((h1 (current-exception-handler)) (h2 (lambda (key . args) 'nothing-2))
(h2 (lambda (key . args) 'nothing-2)) (m (make-mutex 'current-exception-handler-4))
(m (make-mutex 'current-exception-handler-4)) (c (make-condition-variable 'current-exception-handler-4))
(c (make-condition-variable 'current-exception-handler-4)) (t (make-thread (lambda ()
(t (make-thread (lambda () (with-exception-handler
(with-exception-handler h2 (lambda ()
h2 (lambda () (mutex-lock! m)
(mutex-lock! m) (condition-variable-signal! c)
(condition-variable-signal! c) (wait-condition-variable c m)
(wait-condition-variable c m) (and (eq? (current-exception-handler) h2)
(and (eq? (current-exception-handler) h2) (mutex-unlock! m)))))
(mutex-unlock! m))))) 'current-exception-handler-4)))
'current-exception-handler-4))) (mutex-lock! m)
(mutex-lock! m) (thread-start! t)
(thread-start! t) (wait-condition-variable c m)
(wait-condition-variable c m) (and (eq? (current-exception-handler) h1)
(and (eq? (current-exception-handler) h1) (condition-variable-signal! c)
(condition-variable-signal! c) (mutex-unlock! m)
(mutex-unlock! m) (thread-join! t)))))
(thread-join! t)))))
(with-test-prefix "uncaught-exception-reason"
(with-test-prefix "uncaught-exception-reason"
(pass-if "initial handler captures top level exception"
(pass-if "initial handler captures top level exception" (let ((t (make-thread (lambda () (raise 'foo))))
(let ((t (make-thread (lambda () (raise 'foo)))) (success #f))
(success #f)) (thread-start! t)
(thread-start! t) (with-exception-handler
(with-exception-handler (lambda (obj)
(lambda (obj) (and (uncaught-exception? obj)
(and (uncaught-exception? obj) (eq? (uncaught-exception-reason obj) 'foo)
(eq? (uncaught-exception-reason obj) 'foo) (set! success #t)))
(set! success #t))) (lambda () (thread-join! t)))
(lambda () (thread-join! t))) success))
success))
(pass-if "initial handler captures non-SRFI-18 throw"
(pass-if "initial handler captures non-SRFI-18 throw" (let ((t (make-thread (lambda () (throw 'foo))))
(let ((t (make-thread (lambda () (throw 'foo)))) (success #f))
(success #f)) (thread-start! t)
(thread-start! t) (with-exception-handler
(with-exception-handler (lambda (obj)
(lambda (obj) (and (uncaught-exception? obj)
(and (uncaught-exception? obj) (eq? (uncaught-exception-reason obj) 'foo)
(eq? (uncaught-exception-reason obj) 'foo) (set! success #t)))
(set! success #t))) (lambda () (thread-join! t)))
(lambda () (thread-join! t))) success)))))
success)))
)