1 ;;;; srfi-18.test --- Test suite for Guile's SRFI-18 functions. -*- scheme -*-
2 ;;;; Julian Graham, 2007-10-26
4 ;;;; Copyright (C) 2007, 2008, 2012 Free Software Foundation, Inc.
6 ;;;; This library is free software; you can redistribute it and/or
7 ;;;; modify it under the terms of the GNU Lesser General Public
8 ;;;; License as published by the Free Software Foundation; either
9 ;;;; version 3 of the License, or (at your option) any later version.
11 ;;;; This library is distributed in the hope that it will be useful,
12 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
14 ;;;; Lesser General Public License for more details.
16 ;;;; You should have received a copy of the GNU Lesser General Public
17 ;;;; License along with this library; if not, write to the Free Software
18 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
20 (define-module (test-suite test-srfi-18)
21 #:use-module (test-suite lib))
23 ;; two expressions so that the srfi-18 import is in effect for expansion
25 (if (provided? 'threads)
26 (use-modules (srfi srfi-18)))
30 (with-test-prefix "current-thread"
32 (pass-if "current-thread eq current-thread"
33 (eq? (current-thread) (current-thread))))
35 (with-test-prefix "thread?"
37 (pass-if "current-thread is thread"
38 (thread? (current-thread)))
40 (pass-if "foo not thread"
41 (not (thread? 'foo))))
43 (with-test-prefix "make-thread"
45 (pass-if "make-thread creates new thread"
46 (let* ((n (length (all-threads)))
47 (t (make-thread (lambda () 'foo) 'make-thread-1))
48 (r (> (length (all-threads)) n)))
49 (thread-terminate! t) r)))
51 (with-test-prefix "thread-name"
53 (pass-if "make-thread with name binds name"
54 (let* ((t (make-thread (lambda () 'foo) 'thread-name-1))
55 (r (eq? (thread-name t) 'thread-name-1)))
56 (thread-terminate! t) r))
58 (pass-if "make-thread without name does not bind name"
59 (let* ((t (make-thread (lambda () 'foo)))
60 (r (not (thread-name t))))
61 (thread-terminate! t) r)))
63 (with-test-prefix "thread-specific"
65 (pass-if "thread-specific is initially #f"
66 (let* ((t (make-thread (lambda () 'foo) 'thread-specific-1))
67 (r (not (thread-specific t))))
68 (thread-terminate! t) r))
70 (pass-if "thread-specific-set! can set value"
71 (let ((t (make-thread (lambda () 'foo) 'thread-specific-2)))
72 (thread-specific-set! t "hello")
73 (let ((r (equal? (thread-specific t) "hello")))
74 (thread-terminate! t) r))))
76 (with-test-prefix "thread-start!"
78 (pass-if "thread activates only after start"
80 (m (make-mutex 'thread-start-mutex))
81 (t (make-thread (lambda () (set! started #t)) 'thread-start-1)))
82 (and (not started) (thread-start! t) (thread-join! t) started))))
84 (with-test-prefix "thread-yield!"
86 (pass-if "thread yield suceeds"
89 (with-test-prefix "thread-sleep!"
91 (pass-if "thread sleep with time"
92 (let ((future-time (seconds->time (+ (time->seconds (current-time)) 2))))
93 (unspecified? (thread-sleep! future-time))))
95 (pass-if "thread sleep with number"
96 (let ((old-secs (car (current-time))))
97 (unspecified? (thread-sleep! (+ (time->seconds (current-time)))))))
99 (pass-if "thread does not sleep on past time"
100 (let ((past-time (seconds->time (- (time->seconds (current-time)) 2))))
101 (unspecified? (thread-sleep! past-time)))))
103 (with-test-prefix "thread-terminate!"
105 (pass-if "termination destroys non-started thread"
106 (let ((t (make-thread (lambda () 'nothing) 'thread-terminate-1))
107 (num-threads (length (all-threads)))
109 (thread-terminate! t)
110 (with-exception-handler
111 (lambda (obj) (set! success (terminated-thread-exception? obj)))
112 (lambda () (thread-join! t)))
115 (pass-if "termination destroys started thread"
116 (let* ((m1 (make-mutex 'thread-terminate-2a))
117 (m2 (make-mutex 'thread-terminate-2b))
118 (c (make-condition-variable 'thread-terminate-2))
119 (t (make-thread (lambda ()
121 (condition-variable-signal! c)
124 'thread-terminate-2))
130 (thread-terminate! t)
131 (with-exception-handler
132 (lambda (obj) (set! success (terminated-thread-exception? obj)))
133 (lambda () (thread-join! t)))
136 (with-test-prefix "thread-join!"
138 (pass-if "join receives result of thread"
139 (let ((t (make-thread (lambda () 'foo) 'thread-join-1)))
141 (eq? (thread-join! t) 'foo)))
143 (pass-if "join receives timeout val if timeout expires"
144 (let* ((m (make-mutex 'thread-join-2))
145 (t (make-thread (lambda () (mutex-lock! m)) 'thread-join-2)))
148 (let ((r (thread-join! t (current-time) 'bar)))
149 (thread-terminate! t)
152 (pass-if "join throws exception on timeout without timeout val"
153 (let* ((m (make-mutex 'thread-join-3))
154 (t (make-thread (lambda () (mutex-lock! m)) 'thread-join-3))
158 (with-exception-handler
159 (lambda (obj) (set! success (join-timeout-exception? obj)))
160 (lambda () (thread-join! t (current-time))))
161 (thread-terminate! t)
164 (pass-if "join waits on timeout"
165 (let ((t (make-thread (lambda () (sleep 1) 'foo) 'thread-join-4)))
167 (eq? (thread-join! t (+ (time->seconds (current-time)) 2)) 'foo))))
169 (with-test-prefix "mutex?"
171 (pass-if "make-mutex creates mutex"
172 (mutex? (make-mutex)))
174 (pass-if "symbol not mutex"
175 (not (mutex? 'foo))))
177 (with-test-prefix "mutex-name"
179 (pass-if "make-mutex with name binds name"
180 (let* ((m (make-mutex 'mutex-name-1)))
181 (eq? (mutex-name m) 'mutex-name-1)))
183 (pass-if "make-mutex without name does not bind name"
184 (let* ((m (make-mutex)))
185 (not (mutex-name m)))))
187 (with-test-prefix "mutex-specific"
189 (pass-if "mutex-specific is initially #f"
190 (let ((m (make-mutex 'mutex-specific-1)))
191 (not (mutex-specific m))))
193 (pass-if "mutex-specific-set! can set value"
194 (let ((m (make-mutex 'mutex-specific-2)))
195 (mutex-specific-set! m "hello")
196 (equal? (mutex-specific m) "hello"))))
198 (with-test-prefix "mutex-state"
200 (pass-if "mutex state is initially not-abandoned"
201 (let ((m (make-mutex 'mutex-state-1)))
202 (eq? (mutex-state m) 'not-abandoned)))
204 (pass-if "mutex state of locked, owned mutex is owner thread"
205 (let ((m (make-mutex 'mutex-state-2)))
207 (eq? (mutex-state m) (current-thread))))
209 (pass-if "mutex state of locked, unowned mutex is not-owned"
210 (let ((m (make-mutex 'mutex-state-3)))
211 (mutex-lock! m #f #f)
212 (eq? (mutex-state m) 'not-owned)))
214 (pass-if "mutex state of unlocked, abandoned mutex is abandoned"
215 (let* ((m (make-mutex 'mutex-state-4))
216 (t (make-thread (lambda () (mutex-lock! m)))))
219 (eq? (mutex-state m) 'abandoned))))
221 (with-test-prefix "mutex-lock!"
223 (pass-if "mutex-lock! returns true on successful lock"
224 (let* ((m (make-mutex 'mutex-lock-1)))
227 (pass-if "mutex-lock! returns false on timeout"
228 (let* ((m (make-mutex 'mutex-lock-2))
229 (t (make-thread (lambda () (mutex-lock! m (current-time) #f)))))
232 (not (thread-join! t))))
234 (pass-if "mutex-lock! returns true when lock obtained within timeout"
235 (let* ((m (make-mutex 'mutex-lock-3))
236 (t (make-thread (lambda ()
237 (mutex-lock! m (+ (time->seconds (current-time))
245 (pass-if "can lock mutex for non-current thread"
246 (let* ((m1 (make-mutex 'mutex-lock-4a))
247 (m2 (make-mutex 'mutex-lock-4b))
248 (t (make-thread (lambda () (mutex-lock! m1)) 'mutex-lock-4)))
251 (mutex-lock! m2 #f t)
252 (let ((success (eq? (mutex-state m2) t)))
253 (thread-terminate! t) success)))
255 (pass-if "locking abandoned mutex throws exception"
256 (let* ((m (make-mutex 'mutex-lock-5))
257 (t (make-thread (lambda () (mutex-lock! m)) 'mutex-lock-5))
261 (with-exception-handler
262 (lambda (obj) (set! success (abandoned-mutex-exception? obj)))
263 (lambda () (mutex-lock! m)))
264 (and success (eq? (mutex-state m) (current-thread)))))
266 (pass-if "sleeping threads notified of abandonment"
267 (let* ((m1 (make-mutex 'mutex-lock-6a))
268 (m2 (make-mutex 'mutex-lock-6b))
269 (c (make-condition-variable 'mutex-lock-6))
270 (t (make-thread (lambda ()
273 (condition-variable-signal! c))))
277 (with-exception-handler
278 (lambda (obj) (set! success (abandoned-mutex-exception? obj)))
279 (lambda () (mutex-unlock! m1 c) (mutex-lock! m2)))
282 (with-test-prefix "mutex-unlock!"
284 (pass-if "unlock changes mutex state"
285 (let* ((m (make-mutex 'mutex-unlock-1)))
288 (eq? (mutex-state m) 'not-abandoned)))
290 (pass-if "can unlock from any thread"
291 (let* ((m (make-mutex 'mutex-unlock-2))
292 (t (make-thread (lambda () (mutex-unlock! m)) 'mutex-unlock-2)))
296 (eq? (mutex-state m) 'not-abandoned)))
298 (pass-if "mutex unlock is true when condition is signalled"
299 (let* ((m (make-mutex 'mutex-unlock-3))
300 (c (make-condition-variable 'mutex-unlock-3))
301 (t (make-thread (lambda ()
303 (condition-variable-signal! c)
304 (mutex-unlock! m)))))
307 (mutex-unlock! m c)))
309 (pass-if "mutex unlock is false when condition times out"
310 (let* ((m (make-mutex 'mutex-unlock-4))
311 (c (make-condition-variable 'mutex-unlock-4)))
313 (not (mutex-unlock! m c (+ (time->seconds (current-time)) 1))))))
315 (with-test-prefix "condition-variable?"
317 (pass-if "make-condition-variable creates condition variable"
318 (condition-variable? (make-condition-variable)))
320 (pass-if "symbol not condition variable"
321 (not (condition-variable? 'foo))))
323 (with-test-prefix "condition-variable-name"
325 (pass-if "make-condition-variable with name binds name"
326 (let* ((c (make-condition-variable 'condition-variable-name-1)))
327 (eq? (condition-variable-name c) 'condition-variable-name-1)))
329 (pass-if "make-condition-variable without name does not bind name"
330 (let* ((c (make-condition-variable)))
331 (not (condition-variable-name c)))))
333 (with-test-prefix "condition-variable-specific"
335 (pass-if "condition-variable-specific is initially #f"
336 (let ((c (make-condition-variable 'condition-variable-specific-1)))
337 (not (condition-variable-specific c))))
339 (pass-if "condition-variable-specific-set! can set value"
340 (let ((c (make-condition-variable 'condition-variable-specific-1)))
341 (condition-variable-specific-set! c "hello")
342 (equal? (condition-variable-specific c) "hello"))))
344 (with-test-prefix "condition-variable-signal!"
346 (pass-if "condition-variable-signal! wakes up single thread"
347 (let* ((m (make-mutex 'condition-variable-signal-1))
348 (c (make-condition-variable 'condition-variable-signal-1))
349 (t (make-thread (lambda ()
351 (condition-variable-signal! c)
352 (mutex-unlock! m)))))
355 (mutex-unlock! m c))))
357 (with-test-prefix "condition-variable-broadcast!"
359 (pass-if "condition-variable-broadcast! wakes up multiple threads"
361 (c1 (make-condition-variable 'condition-variable-broadcast-1-a))
362 (m1 (make-mutex 'condition-variable-broadcast-1-a))
363 (c2 (make-condition-variable 'condition-variable-broadcast-1-b))
364 (m2 (make-mutex 'condition-variable-broadcast-1-b))
368 (condition-variable-broadcast! c1)
372 (while (eqv? sem 0) (wait-condition-variable c1 m1))
375 (t1 (make-thread (lambda ()
378 (mutex-unlock! m2 c2)
380 (t2 (make-thread (lambda ()
383 (mutex-unlock! m2 c2)
390 (condition-variable-broadcast! c2)
395 (with-test-prefix "time?"
397 (pass-if "current-time is time" (time? (current-time)))
398 (pass-if "number is not time" (not (time? 123)))
399 (pass-if "symbol not time" (not (time? 'foo))))
401 (with-test-prefix "time->seconds"
403 (pass-if "time->seconds makes time into rational"
404 (rational? (time->seconds (current-time))))
406 (pass-if "time->seconds is reversible"
407 (let ((t (current-time)))
408 (equal? t (seconds->time (time->seconds t))))))
410 (with-test-prefix "seconds->time"
412 (pass-if "seconds->time makes rational into time"
413 (time? (seconds->time 123.456)))
415 (pass-if "seconds->time is reversible"
416 (let ((t (time->seconds (current-time))))
417 (equal? t (time->seconds (seconds->time t))))))
419 (with-test-prefix "current-exception-handler"
421 (pass-if "current handler returned at top level"
422 (procedure? (current-exception-handler)))
424 (pass-if "specified handler set under with-exception-handler"
425 (let ((h (lambda (key . args) 'nothing)))
426 (with-exception-handler h (lambda () (eq? (current-exception-handler)
429 (pass-if "multiple levels of handler nesting"
430 (let ((h (lambda (key . args) 'nothing))
431 (i (current-exception-handler)))
432 (and (with-exception-handler h (lambda ()
433 (eq? (current-exception-handler) h)))
434 (eq? (current-exception-handler) i))))
436 (pass-if "exception handler installation is thread-safe"
437 (let* ((h1 (current-exception-handler))
438 (h2 (lambda (key . args) 'nothing-2))
439 (m (make-mutex 'current-exception-handler-4))
440 (c (make-condition-variable 'current-exception-handler-4))
441 (t (make-thread (lambda ()
442 (with-exception-handler
445 (condition-variable-signal! c)
446 (wait-condition-variable c m)
447 (and (eq? (current-exception-handler) h2)
448 (mutex-unlock! m)))))
449 'current-exception-handler-4)))
452 (wait-condition-variable c m)
453 (and (eq? (current-exception-handler) h1)
454 (condition-variable-signal! c)
458 (with-test-prefix "uncaught-exception-reason"
460 (pass-if "initial handler captures top level exception"
461 (let ((t (make-thread (lambda () (raise 'foo))))
464 (with-exception-handler
466 (and (uncaught-exception? obj)
467 (eq? (uncaught-exception-reason obj) 'foo)
469 (lambda () (thread-join! t)))
472 (pass-if "initial handler captures non-SRFI-18 throw"
473 (let ((t (make-thread (lambda () (throw 'foo))))
476 (with-exception-handler
478 (and (uncaught-exception? obj)
479 (eq? (uncaught-exception-reason obj) 'foo)
481 (lambda () (thread-join! t)))