1 ;;;; srfi-18.test --- Test suite for Guile's SRFI-18 functions. -*- scheme -*-
2 ;;;; Julian Graham, 2007-10-26
4 ;;;; Copyright (C) 2007, 2008 Free Software Foundation, Inc.
6 ;;;; This program is free software; you can redistribute it and/or modify
7 ;;;; it under the terms of the GNU General Public License as published by
8 ;;;; the Free Software Foundation; either version 2, or (at your option)
9 ;;;; any later version.
11 ;;;; This program 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
14 ;;;; GNU General Public License for more details.
16 ;;;; You should have received a copy of the GNU General Public License
17 ;;;; along with this software; see the file COPYING. If not, write to
18 ;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
19 ;;;; Boston, MA 02110-1301 USA
21 (define-module (test-suite test-srfi-18)
22 #:use-module (test-suite lib))
24 (and (provided? 'threads)
25 (use-modules (srfi srfi-18))
27 (with-test-prefix "current-thread"
29 (pass-if "current-thread eq current-thread"
30 (eq? (current-thread) (current-thread))))
32 (with-test-prefix "thread?"
34 (pass-if "current-thread is thread"
35 (thread? (current-thread)))
37 (pass-if "foo not thread"
38 (not (thread? 'foo))))
40 (with-test-prefix "make-thread"
42 (pass-if "make-thread creates new thread"
43 (let* ((n (length (all-threads)))
44 (t (make-thread (lambda () 'foo) 'make-thread-1))
45 (r (> (length (all-threads)) n)))
46 (thread-terminate! t) r)))
48 (with-test-prefix "thread-name"
50 (pass-if "make-thread with name binds name"
51 (let* ((t (make-thread (lambda () 'foo) 'thread-name-1))
52 (r (eq? (thread-name t) 'thread-name-1)))
53 (thread-terminate! t) r))
55 (pass-if "make-thread without name does not bind name"
56 (let* ((t (make-thread (lambda () 'foo)))
57 (r (not (thread-name t))))
58 (thread-terminate! t) r)))
60 (with-test-prefix "thread-specific"
62 (pass-if "thread-specific is initially #f"
63 (let* ((t (make-thread (lambda () 'foo) 'thread-specific-1))
64 (r (not (thread-specific t))))
65 (thread-terminate! t) r))
67 (pass-if "thread-specific-set! can set value"
68 (let ((t (make-thread (lambda () 'foo) 'thread-specific-2)))
69 (thread-specific-set! t "hello")
70 (let ((r (equal? (thread-specific t) "hello")))
71 (thread-terminate! t) r))))
73 (with-test-prefix "thread-start!"
75 (pass-if "thread activates only after start"
77 (m (make-mutex 'thread-start-mutex))
78 (t (make-thread (lambda () (set! started #t)) 'thread-start-1)))
79 (and (not started) (thread-start! t) (thread-join! t) started))))
81 (with-test-prefix "thread-yield!"
83 (pass-if "thread yield suceeds"
86 (with-test-prefix "thread-sleep!"
88 (pass-if "thread sleep with time"
89 (let ((future-time (seconds->time (+ (time->seconds (current-time)) 2))))
90 (unspecified? (thread-sleep! future-time))))
92 (pass-if "thread sleep with number"
93 (let ((old-secs (car (current-time))))
94 (unspecified? (thread-sleep! (+ (time->seconds (current-time)))))))
96 (pass-if "thread does not sleep on past time"
97 (let ((past-time (seconds->time (- (time->seconds (current-time)) 2))))
98 (unspecified? (thread-sleep! past-time)))))
100 (with-test-prefix "thread-terminate!"
102 (pass-if "termination destroys non-started thread"
103 (let ((t (make-thread (lambda () 'nothing) 'thread-terminate-1))
104 (num-threads (length (all-threads)))
106 (thread-terminate! t)
107 (with-exception-handler
108 (lambda (obj) (set! success (terminated-thread-exception? obj)))
109 (lambda () (thread-join! t)))
112 (pass-if "termination destroys started thread"
113 (let* ((m1 (make-mutex 'thread-terminate-2a))
114 (m2 (make-mutex 'thread-terminate-2b))
115 (c (make-condition-variable 'thread-terminate-2))
116 (t (make-thread (lambda ()
118 (condition-variable-signal! c)
121 'thread-terminate-2))
127 (thread-terminate! t)
128 (with-exception-handler
129 (lambda (obj) (set! success (terminated-thread-exception? obj)))
130 (lambda () (thread-join! t)))
133 (with-test-prefix "thread-join!"
135 (pass-if "join receives result of thread"
136 (let ((t (make-thread (lambda () 'foo) 'thread-join-1)))
138 (eq? (thread-join! t) 'foo)))
140 (pass-if "join receives timeout val if timeout expires"
141 (let* ((m (make-mutex 'thread-join-2))
142 (t (make-thread (lambda () (mutex-lock! m)) 'thread-join-2)))
145 (let ((r (thread-join! t (current-time) 'bar)))
146 (thread-terminate! t)
149 (pass-if "join throws exception on timeout without timeout val"
150 (let* ((m (make-mutex 'thread-join-3))
151 (t (make-thread (lambda () (mutex-lock! m)) 'thread-join-3))
155 (with-exception-handler
156 (lambda (obj) (set! success (join-timeout-exception? obj)))
157 (lambda () (thread-join! t (current-time))))
158 (thread-terminate! t)
161 (pass-if "join waits on timeout"
162 (let ((t (make-thread (lambda () (sleep 1) 'foo) 'thread-join-4)))
164 (eq? (thread-join! t (+ (time->seconds (current-time)) 2)) 'foo))))
166 (with-test-prefix "mutex?"
168 (pass-if "make-mutex creates mutex"
169 (mutex? (make-mutex)))
171 (pass-if "symbol not mutex"
172 (not (mutex? 'foo))))
174 (with-test-prefix "mutex-name"
176 (pass-if "make-mutex with name binds name"
177 (let* ((m (make-mutex 'mutex-name-1)))
178 (eq? (mutex-name m) 'mutex-name-1)))
180 (pass-if "make-mutex without name does not bind name"
181 (let* ((m (make-mutex)))
182 (not (mutex-name m)))))
184 (with-test-prefix "mutex-specific"
186 (pass-if "mutex-specific is initially #f"
187 (let ((m (make-mutex 'mutex-specific-1)))
188 (not (mutex-specific m))))
190 (pass-if "mutex-specific-set! can set value"
191 (let ((m (make-mutex 'mutex-specific-2)))
192 (mutex-specific-set! m "hello")
193 (equal? (mutex-specific m) "hello"))))
195 (with-test-prefix "mutex-state"
197 (pass-if "mutex state is initially not-abandoned"
198 (let ((m (make-mutex 'mutex-state-1)))
199 (eq? (mutex-state m) 'not-abandoned)))
201 (pass-if "mutex state of locked, owned mutex is owner thread"
202 (let ((m (make-mutex 'mutex-state-2)))
204 (eq? (mutex-state m) (current-thread))))
206 (pass-if "mutex state of locked, unowned mutex is not-owned"
207 (let ((m (make-mutex 'mutex-state-3)))
208 (mutex-lock! m #f #f)
209 (eq? (mutex-state m) 'not-owned)))
211 (pass-if "mutex state of unlocked, abandoned mutex is abandoned"
212 (let* ((m (make-mutex 'mutex-state-4))
213 (t (make-thread (lambda () (mutex-lock! m)))))
216 (eq? (mutex-state m) 'abandoned))))
218 (with-test-prefix "mutex-lock!"
220 (pass-if "mutex-lock! returns true on successful lock"
221 (let* ((m (make-mutex 'mutex-lock-1)))
224 (pass-if "mutex-lock! returns false on timeout"
225 (let* ((m (make-mutex 'mutex-lock-2))
226 (t (make-thread (lambda () (mutex-lock! m (current-time) #f)))))
229 (not (thread-join! t))))
231 (pass-if "mutex-lock! returns true when lock obtained within timeout"
232 (let* ((m (make-mutex 'mutex-lock-3))
233 (t (make-thread (lambda ()
234 (mutex-lock! m (+ (time->seconds (current-time))
242 (pass-if "can lock mutex for non-current thread"
243 (let* ((m1 (make-mutex 'mutex-lock-4a))
244 (m2 (make-mutex 'mutex-lock-4b))
245 (t (make-thread (lambda () (mutex-lock! m1)) 'mutex-lock-4)))
248 (mutex-lock! m2 #f t)
249 (let ((success (eq? (mutex-state m2) t)))
250 (thread-terminate! t) success)))
252 (pass-if "locking abandoned mutex throws exception"
253 (let* ((m (make-mutex 'mutex-lock-5))
254 (t (make-thread (lambda () (mutex-lock! m)) 'mutex-lock-5))
258 (with-exception-handler
259 (lambda (obj) (set! success (abandoned-mutex-exception? obj)))
260 (lambda () (mutex-lock! m)))
261 (and success (eq? (mutex-state m) (current-thread)))))
263 (pass-if "sleeping threads notified of abandonment"
264 (let* ((m1 (make-mutex 'mutex-lock-6a))
265 (m2 (make-mutex 'mutex-lock-6b))
266 (c (make-condition-variable 'mutex-lock-6))
267 (t (make-thread (lambda ()
270 (condition-variable-signal! c))))
274 (with-exception-handler
275 (lambda (obj) (set! success (abandoned-mutex-exception? obj)))
276 (lambda () (mutex-unlock! m1 c) (mutex-lock! m2)))
279 (with-test-prefix "mutex-unlock!"
281 (pass-if "unlock changes mutex state"
282 (let* ((m (make-mutex 'mutex-unlock-1)))
285 (eq? (mutex-state m) 'not-abandoned)))
287 (pass-if "can unlock from any thread"
288 (let* ((m (make-mutex 'mutex-unlock-2))
289 (t (make-thread (lambda () (mutex-unlock! m)) 'mutex-unlock-2)))
293 (eq? (mutex-state m) 'not-abandoned)))
295 (pass-if "mutex unlock is true when condition is signalled"
296 (let* ((m (make-mutex 'mutex-unlock-3))
297 (c (make-condition-variable 'mutex-unlock-3))
298 (t (make-thread (lambda ()
300 (condition-variable-signal! c)
301 (mutex-unlock! m)))))
304 (mutex-unlock! m c)))
306 (pass-if "mutex unlock is false when condition times out"
307 (let* ((m (make-mutex 'mutex-unlock-4))
308 (c (make-condition-variable 'mutex-unlock-4)))
310 (not (mutex-unlock! m c (+ (time->seconds (current-time)) 1))))))
312 (with-test-prefix "condition-variable?"
314 (pass-if "make-condition-variable creates condition variable"
315 (condition-variable? (make-condition-variable)))
317 (pass-if "symbol not condition variable"
318 (not (condition-variable? 'foo))))
320 (with-test-prefix "condition-variable-name"
322 (pass-if "make-condition-variable with name binds name"
323 (let* ((c (make-condition-variable 'condition-variable-name-1)))
324 (eq? (condition-variable-name c) 'condition-variable-name-1)))
326 (pass-if "make-condition-variable without name does not bind name"
327 (let* ((c (make-condition-variable)))
328 (not (condition-variable-name c)))))
330 (with-test-prefix "condition-variable-specific"
332 (pass-if "condition-variable-specific is initially #f"
333 (let ((c (make-condition-variable 'condition-variable-specific-1)))
334 (not (condition-variable-specific c))))
336 (pass-if "condition-variable-specific-set! can set value"
337 (let ((c (make-condition-variable 'condition-variable-specific-1)))
338 (condition-variable-specific-set! c "hello")
339 (equal? (condition-variable-specific c) "hello"))))
341 (with-test-prefix "condition-variable-signal!"
343 (pass-if "condition-variable-signal! wakes up single thread"
344 (let* ((m (make-mutex 'condition-variable-signal-1))
345 (c (make-condition-variable 'condition-variable-signal-1))
346 (t (make-thread (lambda ()
348 (condition-variable-signal! c)
349 (mutex-unlock! m)))))
352 (mutex-unlock! m c))))
354 (with-test-prefix "condition-variable-broadcast!"
356 (pass-if "condition-variable-broadcast! wakes up multiple threads"
358 (c1 (make-condition-variable 'condition-variable-broadcast-1-a))
359 (m1 (make-mutex 'condition-variable-broadcast-1-a))
360 (c2 (make-condition-variable 'condition-variable-broadcast-1-b))
361 (m2 (make-mutex 'condition-variable-broadcast-1-b))
365 (condition-variable-broadcast! c1)
369 (while (eqv? sem 0) (wait-condition-variable c1 m1))
372 (t1 (make-thread (lambda ()
375 (mutex-unlock! m2 c2)
377 (t2 (make-thread (lambda ()
380 (mutex-unlock! m2 c2)
387 (condition-variable-broadcast! c2)
392 (with-test-prefix "time?"
394 (pass-if "current-time is time" (time? (current-time)))
395 (pass-if "number is not time" (not (time? 123)))
396 (pass-if "symbol not time" (not (time? 'foo))))
398 (with-test-prefix "time->seconds"
400 (pass-if "time->seconds makes time into rational"
401 (rational? (time->seconds (current-time))))
403 (pass-if "time->seconds is reversible"
404 (let ((t (current-time)))
405 (equal? t (seconds->time (time->seconds t))))))
407 (with-test-prefix "seconds->time"
409 (pass-if "seconds->time makes rational into time"
410 (time? (seconds->time 123.456)))
412 (pass-if "seconds->time is reversible"
413 (let ((t (time->seconds (current-time))))
414 (equal? t (time->seconds (seconds->time t))))))
416 (with-test-prefix "current-exception-handler"
418 (pass-if "current handler returned at top level"
419 (procedure? (current-exception-handler)))
421 (pass-if "specified handler set under with-exception-handler"
422 (let ((h (lambda (key . args) 'nothing)))
423 (with-exception-handler h (lambda () (eq? (current-exception-handler)
426 (pass-if "multiple levels of handler nesting"
427 (let ((h (lambda (key . args) 'nothing))
428 (i (current-exception-handler)))
429 (and (with-exception-handler h (lambda ()
430 (eq? (current-exception-handler) h)))
431 (eq? (current-exception-handler) i))))
433 (pass-if "exception handler installation is thread-safe"
434 (let* ((h1 (current-exception-handler))
435 (h2 (lambda (key . args) 'nothing-2))
436 (m (make-mutex 'current-exception-handler-4))
437 (c (make-condition-variable 'current-exception-handler-4))
438 (t (make-thread (lambda ()
439 (with-exception-handler
442 (condition-variable-signal! c)
443 (wait-condition-variable c m)
444 (and (eq? (current-exception-handler) h2)
445 (mutex-unlock! m)))))
446 'current-exception-handler-4)))
449 (wait-condition-variable c m)
450 (and (eq? (current-exception-handler) h1)
451 (condition-variable-signal! c)
455 (with-test-prefix "uncaught-exception-reason"
457 (pass-if "initial handler captures top level exception"
458 (let ((t (make-thread (lambda () (raise 'foo))))
461 (with-exception-handler
463 (and (uncaught-exception? obj)
464 (eq? (uncaught-exception-reason obj) 'foo)
466 (lambda () (thread-join! t)))
469 (pass-if "initial handler captures non-SRFI-18 throw"
470 (let ((t (make-thread (lambda () (throw 'foo))))
473 (with-exception-handler
475 (and (uncaught-exception? obj)
476 (eq? (uncaught-exception-reason obj) 'foo)
478 (lambda () (thread-join! t)))