mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

Scheme SRFI-18 implementation and tests file

Browse source
This commit is contained in:
Julian Graham 2008-05-15 00:50:50 -04:00 • committed by Neil Jerram
parent 241d9cea20
commit b046219e51
4 changed files with 864 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

4
srfi/ChangeLog
View file

@ -1,3 +1,7 @@
2008-05-15 Julian Graham <joolean@gmail.com>
* srfi-18.scm: New file.
2008-04-28 Ludovic Courtès <ludo@gnu.org>
* srfi-1.c (scm_srfi1_partition): Properly type-check LIST.

379
srfi/srfi-18.scm Normal file
View file

@ -0,0 +1,379 @@
;;; srfi-18.scm --- Multithreading support
;; Copyright (C) 2008 Free Software Foundation, Inc.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 2.1 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Author: Julian Graham <julian.graham@aya.yale.edu>
;;; Date: 2008-04-11
;;; Commentary:
;; This is an implementation of SRFI-18 (Multithreading support).
;;
;; All procedures defined in SRFI-18, which are not already defined in
;; the Guile core library, are exported.
;;
;; This module is fully documented in the Guile Reference Manual.
;;; Code:
(define-module (srfi srfi-18)
:use-module (srfi srfi-34)
:export (
;;; Threads
;; current-thread <= in the core
;; thread? <= in the core
make-thread
thread-name
thread-specific
thread-specific-set!
thread-start!
thread-yield!
thread-sleep!
thread-terminate!
thread-join!
;;; Mutexes
;; mutex? <= in the core
make-mutex
mutex-name
mutex-specific
mutex-specific-set!
mutex-state
mutex-lock!
mutex-unlock!
;;; Condition variables
;; condition-variable? <= in the core
make-condition-variable
condition-variable-name
condition-variable-specific
condition-variable-specific-set!
condition-variable-signal!
condition-variable-broadcast!
condition-variable-wait!
;;; Time
current-time
time?
time->seconds
seconds->time
current-exception-handler
with-exception-handler
raise
join-timeout-exception?
abandoned-mutex-exception?
terminated-thread-exception?
uncaught-exception?
uncaught-exception-reason
)
:re-export (thread? mutex? condition-variable?)
:replace (current-time
make-thread
make-mutex
make-condition-variable
raise))
(cond-expand-provide (current-module) '(srfi-18))
(define (check-arg-type pred arg caller)
(if (pred arg)
arg
(scm-error 'wrong-type-arg caller
"Wrong type argument: ~S" (list arg) '())))
(define abandoned-mutex-exception (list 'abandoned-mutex-exception))
(define join-timeout-exception (list 'join-timeout-exception))
(define terminated-thread-exception (list 'terminated-thread-exception))
(define uncaught-exception (list 'uncaught-exception))
(define mutex-owners (make-weak-key-hash-table))
(define object-names (make-weak-key-hash-table))
(define object-specifics (make-weak-key-hash-table))
(define thread-start-conds (make-weak-key-hash-table))
(define thread-exception-handlers (make-weak-key-hash-table))
;; EXCEPTIONS
(define raise (@ (srfi srfi-34) raise))
(define (initial-handler obj)
(srfi-18-exception-preserver (cons uncaught-exception obj)))
(define thread->exception (make-object-property))
(define (srfi-18-exception-preserver obj)
(if (or (terminated-thread-exception? obj)
(uncaught-exception? obj))
(set! (thread->exception (current-thread)) obj)))
(define (srfi-18-exception-handler key . args)
;; SRFI 34 exceptions continue to bubble up no matter who handles them, so
;; if one is caught at this level, it has already been taken care of by
;; `initial-handler'.
(and (not (eq? key 'srfi-34))
(srfi-18-exception-preserver (if (null? args)
(cons uncaught-exception key)
(cons* uncaught-exception key args)))))
(define (current-handler-stack)
(let ((ct (current-thread)))
(or (hashq-ref thread-exception-handlers ct)
(hashq-set! thread-exception-handlers ct (list initial-handler)))))
(define (with-exception-handler handler thunk)
(let ((ct (current-thread))
(hl (current-handler-stack)))
(check-arg-type procedure? handler "with-exception-handler")
(check-arg-type thunk? thunk "with-exception-handler")
(hashq-set! thread-exception-handlers ct (cons handler hl))
(apply (@ (srfi srfi-34) with-exception-handler)
(list (lambda (obj)
(hashq-set! thread-exception-handlers ct hl)
(handler obj))
(lambda ()
(let ((r (thunk)))
(hashq-set! thread-exception-handlers ct hl) r))))))
(define (current-exception-handler)
(car (current-handler-stack)))
(define (join-timeout-exception? obj) (eq? obj join-timeout-exception))
(define (abandoned-mutex-exception? obj) (eq? obj abandoned-mutex-exception))
(define (uncaught-exception? obj)
(and (pair? obj) (eq? (car obj) uncaught-exception)))
(define (uncaught-exception-reason exc)
(cdr (check-arg-type uncaught-exception? exc "uncaught-exception-reason")))
(define (terminated-thread-exception? obj)
(eq? obj terminated-thread-exception))
;; THREADS
;; Create a new thread and prevent it from starting using a condition variable.
;; Once started, install a top-level exception handler that rethrows any
;; exceptions wrapped in an uncaught-exception wrapper.
(define make-thread
(let ((make-cond-wrapper (lambda (thunk lcond lmutex scond smutex)
(lambda ()
(lock-mutex lmutex)
(signal-condition-variable lcond)
(lock-mutex smutex)
(unlock-mutex lmutex)
(wait-condition-variable scond smutex)
(unlock-mutex smutex)
(with-exception-handler initial-handler
thunk)))))
(lambda (thunk . name)
(let ((n (and (pair? name) (car name)))
(lm (make-mutex 'launch-mutex))
(lc (make-condition-variable 'launch-condition-variable))
(sm (make-mutex 'start-mutex))
(sc (make-condition-variable 'start-condition-variable)))
(lock-mutex lm)
(let ((t (call-with-new-thread (make-cond-wrapper thunk lc lm sc sm)
srfi-18-exception-handler)))
(hashq-set! thread-start-conds t (cons sm sc))
(and n (hashq-set! object-names t n))
(wait-condition-variable lc lm)
(unlock-mutex lm)
t)))))
(define (thread-name thread)
(hashq-ref object-names (check-arg-type thread? thread "thread-name")))
(define (thread-specific thread)
(hashq-ref object-specifics
(check-arg-type thread? thread "thread-specific")))
(define (thread-specific-set! thread obj)
(hashq-set! object-specifics
(check-arg-type thread? thread "thread-specific-set!")
obj)
*unspecified*)
(define (thread-start! thread)
(let ((x (hashq-ref thread-start-conds
(check-arg-type thread? thread "thread-start!"))))
(and x (let ((smutex (car x))
(scond (cdr x)))
(hashq-remove! thread-start-conds thread)
(lock-mutex smutex)
(signal-condition-variable scond)
(unlock-mutex smutex)))
thread))
(define (thread-yield!) (yield) *unspecified*)
(define (thread-sleep! timeout)
(let* ((ct (time->seconds (current-time)))
(t (cond ((time? timeout) (- (time->seconds timeout) ct))
((number? timeout) (- timeout ct))
(else (scm-error 'wrong-type-arg caller
"Wrong type argument: ~S"
(list timeout)
'()))))
(secs (inexact->exact (truncate t)))
(usecs (inexact->exact (truncate (* (- t secs) 1000)))))
(and (> secs 0) (sleep secs))
(and (> usecs 0) (usleep usecs))
*unspecified*))
;; A convenience function for installing exception handlers on SRFI-18
;; primitives that resume the calling continuation after the handler is
;; invoked -- this resolves a behavioral incompatibility with Guile's
;; implementation of SRFI-34, which uses lazy-catch and rethrows handled
;; exceptions. (SRFI-18, "Primitives and exceptions")
(define (wrap thunk)
(lambda (continuation)
(with-exception-handler (lambda (obj)
(apply (current-exception-handler) (list obj))
(apply continuation (list)))
thunk)))
;; A pass-thru to cancel-thread that first installs a handler that throws
;; terminated-thread exception, as per SRFI-18,
(define (thread-terminate! thread)
(define (thread-terminate-inner!)
(let ((current-handler (thread-cleanup thread)))
(if (thunk? current-handler)
(set-thread-cleanup! thread
(lambda ()
(with-exception-handler initial-handler
current-handler)
(srfi-18-exception-preserver
terminated-thread-exception)))
(set-thread-cleanup! thread
(lambda () (srfi-18-exception-preserver
terminated-thread-exception))))
(cancel-thread thread)
*unspecified*))
(thread-terminate-inner!))
(define (thread-join! thread . args)
(define thread-join-inner!
(wrap (lambda ()
(let ((v (apply join-thread (cons thread args)))
(e (thread->exception thread)))
(if (and (= (length args) 1) (not v))
(raise join-timeout-exception))
(if e (raise e))
v))))
(call/cc thread-join-inner!))
;; MUTEXES
;; These functions are all pass-thrus to the existing Guile implementations.
(define make-mutex
(lambda name
(let ((n (and (pair? name) (car name)))
(m ((@ (guile) make-mutex)
'unchecked-unlock
'allow-external-unlock
'recursive)))
(and n (hashq-set! object-names m n)) m)))
(define (mutex-name mutex)
(hashq-ref object-names (check-arg-type mutex? mutex "mutex-name")))
(define (mutex-specific mutex)
(hashq-ref object-specifics
(check-arg-type mutex? mutex "mutex-specific")))
(define (mutex-specific-set! mutex obj)
(hashq-set! object-specifics
(check-arg-type mutex? mutex "mutex-specific-set!")
obj)
*unspecified*)
(define (mutex-state mutex)
(let ((owner (mutex-owner mutex)))
(if owner
(if (thread-exited? owner) 'abandoned owner)
(if (> (mutex-level mutex) 0) 'not-owned 'not-abandoned))))
(define (mutex-lock! mutex . args)
(define mutex-lock-inner!
(wrap (lambda ()
(catch 'abandoned-mutex-error
(lambda () (apply lock-mutex (cons mutex args)))
(lambda (key . args) (raise abandoned-mutex-exception))))))
(call/cc mutex-lock-inner!))
(define (mutex-unlock! mutex . args)
(apply unlock-mutex (cons mutex args)))
;; CONDITION VARIABLES
;; These functions are all pass-thrus to the existing Guile implementations.
(define make-condition-variable
(lambda name
(let ((n (and (pair? name) (car name)))
(m ((@ (guile) make-condition-variable))))
(and n (hashq-set! object-names m n)) m)))
(define (condition-variable-name condition-variable)
(hashq-ref object-names (check-arg-type condition-variable?
condition-variable
"condition-variable-name")))
(define (condition-variable-specific condition-variable)
(hashq-ref object-specifics (check-arg-type condition-variable?
condition-variable
"condition-variable-specific")))
(define (condition-variable-specific-set! condition-variable obj)
(hashq-set! object-specifics
(check-arg-type condition-variable?
condition-variable
"condition-variable-specific-set!")
obj)
*unspecified*)
(define (condition-variable-signal! cond)
(signal-condition-variable cond)
*unspecified*)
(define (condition-variable-broadcast! cond)
(broadcast-condition-variable cond)
*unspecified*)
;; TIME
(define current-time gettimeofday)
(define (time? obj)
(and (pair? obj)
(let ((co (car obj))) (and (integer? co) (>= co 0)))
(let ((co (cdr obj))) (and (integer? co) (>= co 0)))))
(define (time->seconds time)
(and (check-arg-type time? time "time->seconds")
(+ (car time) (/ (cdr time) 1000000))))
(define (seconds->time x)
(and (check-arg-type number? x "seconds->time")
(let ((fx (truncate x)))
(cons (inexact->exact fx)
(inexact->exact (truncate (* (- x fx) 1000000)))))))
;; srfi-18.scm ends here

4
test-suite/ChangeLog
View file

@ -1,3 +1,7 @@
2008-05-15 Julian Graham <joolean@gmail.com>
* tests/srfi-18.test: New file.
2008-05-14 Julian Graham <joolean@gmail.com>
* tests/threads.test (mutex-ownership, mutex-lock-levels): New

477
test-suite/tests/srfi-18.test Normal file
View file

@ -0,0 +1,477 @@
;;;; srfi-18.test --- Test suite for Guile's SRFI-18 functions. -*- scheme -*-
;;;; Julian Graham, 2007-10-26
;;;;
;;;; Copyright (C) 2007 Free Software Foundation, Inc.
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2, or (at your option)
;;;; any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING. If not, write to
;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA
(define-module (test-suite test-srfi-18)
#:use-module (test-suite lib)
#:use-module (srfi srfi-18))
(with-test-prefix "current-thread"
(pass-if "current-thread eq current-thread"
(eq? (current-thread) (current-thread))))
(with-test-prefix "thread?"
(pass-if "current-thread is thread"
(thread? (current-thread)))
(pass-if "foo not thread"
(not (thread? 'foo))))
(with-test-prefix "make-thread"
(pass-if "make-thread creates new thread"
(let* ((n (length (all-threads)))
(t (make-thread (lambda () 'foo) 'make-thread-1))
(r (> (length (all-threads)) n)))
(thread-terminate! t) r)))
(with-test-prefix "thread-name"
(pass-if "make-thread with name binds name"
(let* ((t (make-thread (lambda () 'foo) 'thread-name-1))
(r (eq? (thread-name t) 'thread-name-1)))
(thread-terminate! t) r))
(pass-if "make-thread without name does not bind name"
(let* ((t (make-thread (lambda () 'foo)))
(r (not (thread-name t))))
(thread-terminate! t) r)))
(with-test-prefix "thread-specific"
(pass-if "thread-specific is initially #f"
(let* ((t (make-thread (lambda () 'foo) 'thread-specific-1))
(r (not (thread-specific t))))
(thread-terminate! t) r))
(pass-if "thread-specific-set! can set value"
(let ((t (make-thread (lambda () 'foo) 'thread-specific-2)))
(thread-specific-set! t "hello")
(let ((r (equal? (thread-specific t) "hello")))
(thread-terminate! t) r))))
(with-test-prefix "thread-start!"
(pass-if "thread activates only after start"
(let* ((started #f)
(m (make-mutex 'thread-start-mutex))
(t (make-thread (lambda () (set! started #t)) 'thread-start-1)))
(and (not started) (thread-start! t) (thread-join! t) started))))
(with-test-prefix "thread-yield!"
(pass-if "thread yield suceeds"
(thread-yield!) #t))
(with-test-prefix "thread-sleep!"
(pass-if "thread sleep with time"
(let ((future-time (seconds->time (+ (time->seconds (current-time)) 2))))
(unspecified? (thread-sleep! future-time))))
(pass-if "thread sleep with number"
(let ((old-secs (car (current-time))))
(unspecified? (thread-sleep! (+ (time->seconds (current-time)))))))
(pass-if "thread does not sleep on past time"
(let ((past-time (seconds->time (- (time->seconds (current-time)) 2))))
(unspecified? (thread-sleep! past-time)))))
(with-test-prefix "thread-terminate!"
(pass-if "termination destroys non-started thread"
(let ((t (make-thread (lambda () 'nothing) 'thread-terminate-1))
(num-threads (length (all-threads)))
(success #f))
(thread-terminate! t)
(with-exception-handler
(lambda (obj) (set! success (terminated-thread-exception? obj)))
(lambda () (thread-join! t)))
success))
(pass-if "termination destroys started thread"
(let* ((m1 (make-mutex 'thread-terminate-2a))
(m2 (make-mutex 'thread-terminate-2b))
(c (make-condition-variable 'thread-terminate-2))
(t (make-thread (lambda ()
(mutex-lock! m1)
(condition-variable-signal! c)
(mutex-unlock! m1)
(mutex-lock! m2))
'thread-terminate-2))
(success #f))
(mutex-lock! m1)
(mutex-lock! m2)
(thread-start! t)
(mutex-unlock! m1 c)
(thread-terminate! t)
(with-exception-handler
(lambda (obj) (set! success (terminated-thread-exception? obj)))
(lambda () (thread-join! t)))
success)))
(with-test-prefix "thread-join!"
(pass-if "join receives result of thread"
(let ((t (make-thread (lambda () 'foo) 'thread-join-1)))
(thread-start! t)
(eq? (thread-join! t) 'foo)))
(pass-if "join receives timeout val if timeout expires"
(let* ((m (make-mutex 'thread-join-2))
(t (make-thread (lambda () (mutex-lock! m)) 'thread-join-2)))
(mutex-lock! m)
(thread-start! t)
(let ((r (thread-join! t (current-time) 'bar)))
(thread-terminate! t)
(eq? r 'bar))))
(pass-if "join throws exception on timeout without timeout val"
(let* ((m (make-mutex 'thread-join-3))
(t (make-thread (lambda () (mutex-lock! m)) 'thread-join-3))
(success #f))
(mutex-lock! m)
(thread-start! t)
(with-exception-handler
(lambda (obj) (set! success (join-timeout-exception? obj)))
(lambda () (thread-join! t (current-time))))
(thread-terminate! t)
success))
(pass-if "join waits on timeout"
(let ((t (make-thread (lambda () (sleep 1) 'foo) 'thread-join-4)))
(thread-start! t)
(eq? (thread-join! t (+ (time->seconds (current-time)) 2)) 'foo))))
(with-test-prefix "mutex?"
(pass-if "make-mutex creates mutex"
(mutex? (make-mutex)))
(pass-if "symbol not mutex"
(not (mutex? 'foo))))
(with-test-prefix "mutex-name"
(pass-if "make-mutex with name binds name"
(let* ((m (make-mutex 'mutex-name-1)))
(eq? (mutex-name m) 'mutex-name-1)))
(pass-if "make-mutex without name does not bind name"
(let* ((m (make-mutex)))
(not (mutex-name m)))))
(with-test-prefix "mutex-specific"
(pass-if "mutex-specific is initially #f"
(let ((m (make-mutex 'mutex-specific-1)))
(not (mutex-specific m))))
(pass-if "mutex-specific-set! can set value"
(let ((m (make-mutex 'mutex-specific-2)))
(mutex-specific-set! m "hello")
(equal? (mutex-specific m) "hello"))))
(with-test-prefix "mutex-state"
(pass-if "mutex state is initially not-abandoned"
(let ((m (make-mutex 'mutex-state-1)))
(eq? (mutex-state m) 'not-abandoned)))
(pass-if "mutex state of locked, owned mutex is owner thread"
(let ((m (make-mutex 'mutex-state-2)))
(mutex-lock! m)
(eq? (mutex-state m) (current-thread))))
(pass-if "mutex state of locked, unowned mutex is not-owned"
(let ((m (make-mutex 'mutex-state-3)))
(mutex-lock! m #f #f)
(eq? (mutex-state m) 'not-owned)))
(pass-if "mutex state of unlocked, abandoned mutex is abandoned"
(let* ((m (make-mutex 'mutex-state-4))
(t (make-thread (lambda () (mutex-lock! m)))))
(thread-start! t)
(thread-join! t)
(eq? (mutex-state m) 'abandoned))))
(with-test-prefix "mutex-lock!"
(pass-if "mutex-lock! returns true on successful lock"
(let* ((m (make-mutex 'mutex-lock-1)))
(mutex-lock! m)))
(pass-if "mutex-lock! returns false on timeout"
(let* ((m (make-mutex 'mutex-lock-2))
(t (make-thread (lambda () (mutex-lock! m (current-time) #f)))))
(mutex-lock! m)
(thread-start! t)
(not (thread-join! t))))
(pass-if "mutex-lock! returns true when lock obtained within timeout"
(let* ((m (make-mutex 'mutex-lock-3))
(t (make-thread (lambda ()
(mutex-lock! m (+ (time->seconds (current-time))
100)
#f)))))
(mutex-lock! m)
(thread-start! t)
(mutex-unlock! m)
(thread-join! t)))
(pass-if "can lock mutex for non-current thread"
(let* ((m1 (make-mutex 'mutex-lock-4a))
(m2 (make-mutex 'mutex-lock-4b))
(t (make-thread (lambda () (mutex-lock! m1)) 'mutex-lock-4)))
(mutex-lock! m1)
(thread-start! t)
(mutex-lock! m2 #f t)
(let ((success (eq? (mutex-state m2) t)))
(thread-terminate! t) success)))
(pass-if "locking abandoned mutex throws exception"
(let* ((m (make-mutex 'mutex-lock-5))
(t (make-thread (lambda () (mutex-lock! m)) 'mutex-lock-5))
(success #f))
(thread-start! t)
(thread-join! t)
(with-exception-handler
(lambda (obj) (set! success (abandoned-mutex-exception? obj)))
(lambda () (mutex-lock! m)))
(and success (eq? (mutex-state m) (current-thread)))))
(pass-if "sleeping threads notified of abandonment"
(let* ((m1 (make-mutex 'mutex-lock-6a))
(m2 (make-mutex 'mutex-lock-6b))
(c (make-condition-variable 'mutex-lock-6))
(t (make-thread (lambda ()
(mutex-lock! m1)
(mutex-lock! m2)
(condition-variable-signal! c))))
(success #f))
(mutex-lock! m1)
(thread-start! t)
(with-exception-handler
(lambda (obj) (set! success (abandoned-mutex-exception? obj)))
(lambda () (mutex-unlock! m1 c) (mutex-lock! m2)))
success)))
(with-test-prefix "mutex-unlock!"
(pass-if "unlock changes mutex state"
(let* ((m (make-mutex 'mutex-unlock-1)))
(mutex-lock! m)
(mutex-unlock! m)
(eq? (mutex-state m) 'not-abandoned)))
(pass-if "can unlock from any thread"
(let* ((m (make-mutex 'mutex-unlock-2))
(t (make-thread (lambda () (mutex-unlock! m)) 'mutex-unlock-2)))
(mutex-lock! m)
(thread-start! t)
(thread-join! t)
(eq? (mutex-state m) 'not-abandoned)))
(pass-if "mutex unlock is true when condition is signalled"
(let* ((m (make-mutex 'mutex-unlock-3))
(c (make-condition-variable 'mutex-unlock-3))
(t (make-thread (lambda ()
(mutex-lock! m)
(condition-variable-signal! c)
(mutex-unlock! m)))))
(mutex-lock! m)
(thread-start! t)
(mutex-unlock! m c)))
(pass-if "mutex unlock is false when condition times out"
(let* ((m (make-mutex 'mutex-unlock-4))
(c (make-condition-variable 'mutex-unlock-4)))
(mutex-lock! m)
(not (mutex-unlock! m c (+ (time->seconds (current-time)) 1))))))
(with-test-prefix "condition-variable?"
(pass-if "make-condition-variable creates condition variable"
(condition-variable? (make-condition-variable)))
(pass-if "symbol not condition variable"
(not (condition-variable? 'foo))))
(with-test-prefix "condition-variable-name"
(pass-if "make-condition-variable with name binds name"
(let* ((c (make-condition-variable 'condition-variable-name-1)))
(eq? (condition-variable-name c) 'condition-variable-name-1)))
(pass-if "make-condition-variable without name does not bind name"
(let* ((c (make-condition-variable)))
(not (condition-variable-name c)))))
(with-test-prefix "condition-variable-specific"
(pass-if "condition-variable-specific is initially #f"
(let ((c (make-condition-variable 'condition-variable-specific-1)))
(not (condition-variable-specific c))))
(pass-if "condition-variable-specific-set! can set value"
(let ((c (make-condition-variable 'condition-variable-specific-1)))
(condition-variable-specific-set! c "hello")
(equal? (condition-variable-specific c) "hello"))))
(with-test-prefix "condition-variable-signal!"
(pass-if "condition-variable-signal! wakes up single thread"
(let* ((m (make-mutex 'condition-variable-signal-1))
(c (make-condition-variable 'condition-variable-signal-1))
(t (make-thread (lambda ()
(mutex-lock! m)
(condition-variable-signal! c)
(mutex-unlock! m)))))
(mutex-lock! m)
(thread-start! t)
(mutex-unlock! m c))))
(with-test-prefix "condition-variable-broadcast!"
(pass-if "condition-variable-broadcast! wakes up multiple threads"
(let* ((sem 0)
(c1 (make-condition-variable 'condition-variable-broadcast-1-a))
(m1 (make-mutex 'condition-variable-broadcast-1-a))
(c2 (make-condition-variable 'condition-variable-broadcast-1-b))
(m2 (make-mutex 'condition-variable-broadcast-1-b))
(inc-sem! (lambda ()
(mutex-lock! m1)
(set! sem (+ sem 1))
(condition-variable-broadcast! c1)
(mutex-unlock! m1)))
(dec-sem! (lambda ()
(mutex-lock! m1)
(while (eqv? sem 0) (wait-condition-variable c1 m1))
(set! sem (- sem 1))
(mutex-unlock! m1)))
(t1 (make-thread (lambda ()
(mutex-lock! m2)
(inc-sem!)
(mutex-unlock! m2 c2)
(inc-sem!))))
(t2 (make-thread (lambda ()
(mutex-lock! m2)
(inc-sem!)
(mutex-unlock! m2 c2)
(inc-sem!)))))
(thread-start! t1)
(thread-start! t2)
(dec-sem!)
(dec-sem!)
(mutex-lock! m2)
(condition-variable-broadcast! c2)
(mutex-unlock! m2)
(dec-sem!)
(dec-sem!))))
(with-test-prefix "time?"
(pass-if "current-time is time" (time? (current-time)))
(pass-if "number is not time" (not (time? 123)))
(pass-if "symbol not time" (not (time? 'foo))))
(with-test-prefix "time->seconds"
(pass-if "time->seconds makes time into rational"
(rational? (time->seconds (current-time))))
(pass-if "time->seconds is reversible"
(let ((t (current-time)))
(equal? t (seconds->time (time->seconds t))))))
(with-test-prefix "seconds->time"
(pass-if "seconds->time makes rational into time"
(time? (seconds->time 123.456)))
(pass-if "seconds->time is reversible"
(let ((t (time->seconds (current-time))))
(equal? t (time->seconds (seconds->time t))))))
(with-test-prefix "current-exception-handler"
(pass-if "current handler returned at top level"
(procedure? (current-exception-handler)))
(pass-if "specified handler set under with-exception-handler"
(let ((h (lambda (key . args) 'nothing)))
(with-exception-handler h (lambda () (eq? (current-exception-handler)
h)))))
(pass-if "multiple levels of handler nesting"
(let ((h (lambda (key . args) 'nothing))
(i (current-exception-handler)))
(and (with-exception-handler h (lambda ()
(eq? (current-exception-handler) h)))
(eq? (current-exception-handler) i))))
(pass-if "exception handler installation is thread-safe"
(let* ((h1 (current-exception-handler))
(h2 (lambda (key . args) 'nothing-2))
(m (make-mutex 'current-exception-handler-4))
(c (make-condition-variable 'current-exception-handler-4))
(t (make-thread (lambda ()
(with-exception-handler
h2 (lambda ()
(mutex-lock! m)
(condition-variable-signal! c)
(wait-condition-variable c m)
(and (eq? (current-exception-handler) h2)
(mutex-unlock! m)))))
'current-exception-handler-4)))
(mutex-lock! m)
(thread-start! t)
(wait-condition-variable c m)
(and (eq? (current-exception-handler) h1)
(condition-variable-signal! c)
(mutex-unlock! m)
(thread-join! t)))))
(with-test-prefix "uncaught-exception-reason"
(pass-if "initial handler captures top level exception"
(let ((t (make-thread (lambda () (raise 'foo))))
(success #f))
(thread-start! t)
(with-exception-handler
(lambda (obj)
(and (uncaught-exception? obj)
(eq? (uncaught-exception-reason obj) 'foo)
(set! success #t)))
(lambda () (thread-join! t)))
success))
(pass-if "initial handler captures non-SRFI-18 throw"
(let ((t (make-thread (lambda () (throw 'foo))))
(success #f))
(thread-start! t)
(with-exception-handler
(lambda (obj)
(and (uncaught-exception? obj)
(eq? (uncaught-exception-reason obj) 'foo)
(set! success #t)))
(lambda () (thread-join! t)))
success)))