[bpt/guile.git] / test-suite / tests / srfi-18.test

;;;; srfi-18.test --- Test suite for Guile's SRFI-18 functions. -*- scheme -*-
;;;; Julian Graham, 2007-10-26
;;;;
;;;; Copyright (C) 2007, 2008 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))

(and (provided? 'threads)

(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)))

)
Commit	Line	Data
b046219e JG	1	;;;; srfi-18.test --- Test suite for Guile's SRFI-18 functions. -- scheme --
	2	;;;; Julian Graham, 2007-10-26
	3	;;;;
70eca635	4	;;;; Copyright (C) 2007, 2008 Free Software Foundation, Inc.
b046219e JG	5	;;;;
	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.
	10	;;;;
	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.
	15	;;;;
	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
	20
	21	(define-module (test-suite test-srfi-18)
	22	#:use-module (test-suite lib)
	23	#:use-module (srfi srfi-18))
	24
70eca635 LC	25	(and (provided? 'threads)
70eca635 LC	26
b046219e JG	27	(with-test-prefix "current-thread"
	28
	29	(pass-if "current-thread eq current-thread"
	30	(eq? (current-thread) (current-thread))))
	31
	32	(with-test-prefix "thread?"
	33
	34	(pass-if "current-thread is thread"
	35	(thread? (current-thread)))
	36
	37	(pass-if "foo not thread"
	38	(not (thread? 'foo))))
	39
	40	(with-test-prefix "make-thread"
	41
	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)))
	47
	48	(with-test-prefix "thread-name"
	49
	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))
	54
	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)))
	59
	60	(with-test-prefix "thread-specific"
	61
	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))
	66
	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))))
	72
	73	(with-test-prefix "thread-start!"
	74
	75	(pass-if "thread activates only after start"
	76	(let* ((started #f)
	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))))
	80
	81	(with-test-prefix "thread-yield!"
	82
	83	(pass-if "thread yield suceeds"
	84	(thread-yield!) #t))
	85
	86	(with-test-prefix "thread-sleep!"
	87
	88	(pass-if "thread sleep with time"
	89	(let ((future-time (seconds->time (+ (time->seconds (current-time)) 2))))
	90	(unspecified? (thread-sleep! future-time))))
91
92	(pass-if "thread sleep with number"
93	(let ((old-secs (car (current-time))))
94	(unspecified? (thread-sleep! (+ (time->seconds (current-time)))))))
95
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)))))
99
100	(with-test-prefix "thread-terminate!"
101
102	(pass-if "termination destroys non-started thread"
103	(let ((t (make-thread (lambda () 'nothing) 'thread-terminate-1))
104	(num-threads (length (all-threads)))
105	(success #f))
106	(thread-terminate! t)
107	(with-exception-handler
108	(lambda (obj) (set! success (terminated-thread-exception? obj)))
109	(lambda () (thread-join! t)))
110	success))
111
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 ()
117	(mutex-lock! m1)
118	(condition-variable-signal! c)
119	(mutex-unlock! m1)
120	(mutex-lock! m2))
121	'thread-terminate-2))
122	(success #f))
123	(mutex-lock! m1)
124	(mutex-lock! m2)
125	(thread-start! t)
126	(mutex-unlock! m1 c)
127	(thread-terminate! t)
128	(with-exception-handler
129	(lambda (obj) (set! success (terminated-thread-exception? obj)))
130	(lambda () (thread-join! t)))
131	success)))
132
133	(with-test-prefix "thread-join!"
134
135	(pass-if "join receives result of thread"
136	(let ((t (make-thread (lambda () 'foo) 'thread-join-1)))
137	(thread-start! t)
138	(eq? (thread-join! t) 'foo)))
139
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)))
143	(mutex-lock! m)
144	(thread-start! t)
145	(let ((r (thread-join! t (current-time) 'bar)))
146	(thread-terminate! t)
147	(eq? r 'bar))))
148
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))
152	(success #f))
153	(mutex-lock! m)
154	(thread-start! t)
155	(with-exception-handler
156	(lambda (obj) (set! success (join-timeout-exception? obj)))
157	(lambda () (thread-join! t (current-time))))
158	(thread-terminate! t)
159	success))
160
161	(pass-if "join waits on timeout"
162	(let ((t (make-thread (lambda () (sleep 1) 'foo) 'thread-join-4)))
163	(thread-start! t)
164	(eq? (thread-join! t (+ (time->seconds (current-time)) 2)) 'foo))))
165
166	(with-test-prefix "mutex?"
167
168	(pass-if "make-mutex creates mutex"
169	(mutex? (make-mutex)))
170
171	(pass-if "symbol not mutex"
172	(not (mutex? 'foo))))
173
174	(with-test-prefix "mutex-name"
175
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)))
179
180	(pass-if "make-mutex without name does not bind name"
181	(let* ((m (make-mutex)))
182	(not (mutex-name m)))))
183
184	(with-test-prefix "mutex-specific"
185
186	(pass-if "mutex-specific is initially #f"
187	(let ((m (make-mutex 'mutex-specific-1)))
188	(not (mutex-specific m))))
189
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"))))
194
195	(with-test-prefix "mutex-state"
196
197	(pass-if "mutex state is initially not-abandoned"
198	(let ((m (make-mutex 'mutex-state-1)))
199	(eq? (mutex-state m) 'not-abandoned)))
200
201	(pass-if "mutex state of locked, owned mutex is owner thread"
202	(let ((m (make-mutex 'mutex-state-2)))
203	(mutex-lock! m)
204	(eq? (mutex-state m) (current-thread))))
205
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)))
210
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)))))
214	(thread-start! t)
215	(thread-join! t)
216	(eq? (mutex-state m) 'abandoned))))
217
218	(with-test-prefix "mutex-lock!"
219
220	(pass-if "mutex-lock! returns true on successful lock"
221	(let* ((m (make-mutex 'mutex-lock-1)))
222	(mutex-lock! m)))
223
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)))))
227	(mutex-lock! m)
228	(thread-start! t)
229	(not (thread-join! t))))
230
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))
235	100)
236	#f)))))
237	(mutex-lock! m)
238	(thread-start! t)
239	(mutex-unlock! m)
240	(thread-join! t)))
241
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)))
246	(mutex-lock! m1)
247	(thread-start! t)
248	(mutex-lock! m2 #f t)
249	(let ((success (eq? (mutex-state m2) t)))
250	(thread-terminate! t) success)))
251
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))
255	(success #f))
256	(thread-start! t)
257	(thread-join! t)
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)))))
262
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 ()
268	(mutex-lock! m1)
269	(mutex-lock! m2)
270	(condition-variable-signal! c))))
271	(success #f))
272	(mutex-lock! m1)
273	(thread-start! t)
274	(with-exception-handler
275	(lambda (obj) (set! success (abandoned-mutex-exception? obj)))
276	(lambda () (mutex-unlock! m1 c) (mutex-lock! m2)))
277	success)))
278
279	(with-test-prefix "mutex-unlock!"
280
281	(pass-if "unlock changes mutex state"
282	(let* ((m (make-mutex 'mutex-unlock-1)))
283	(mutex-lock! m)
284	(mutex-unlock! m)
285	(eq? (mutex-state m) 'not-abandoned)))
286
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)))
290	(mutex-lock! m)
291	(thread-start! t)
292	(thread-join! t)
293	(eq? (mutex-state m) 'not-abandoned)))
294
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 ()
299	(mutex-lock! m)
300	(condition-variable-signal! c)
301	(mutex-unlock! m)))))
302	(mutex-lock! m)
303	(thread-start! t)
304	(mutex-unlock! m c)))
305
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)))
309	(mutex-lock! m)
310	(not (mutex-unlock! m c (+ (time->seconds (current-time)) 1))))))
311
312	(with-test-prefix "condition-variable?"
313
314	(pass-if "make-condition-variable creates condition variable"
315	(condition-variable? (make-condition-variable)))
316
317	(pass-if "symbol not condition variable"
318	(not (condition-variable? 'foo))))
319
320	(with-test-prefix "condition-variable-name"
321
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)))
325
326	(pass-if "make-condition-variable without name does not bind name"
327	(let* ((c (make-condition-variable)))
328	(not (condition-variable-name c)))))
329
330	(with-test-prefix "condition-variable-specific"
331
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))))
335
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"))))
340
341	(with-test-prefix "condition-variable-signal!"
342
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 ()
347	(mutex-lock! m)
348	(condition-variable-signal! c)
349	(mutex-unlock! m)))))
350	(mutex-lock! m)
351	(thread-start! t)
352	(mutex-unlock! m c))))
353
354	(with-test-prefix "condition-variable-broadcast!"
355
356	(pass-if "condition-variable-broadcast! wakes up multiple threads"
357	(let* ((sem 0)
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))
362	(inc-sem! (lambda ()
363	(mutex-lock! m1)
364	(set! sem (+ sem 1))
365	(condition-variable-broadcast! c1)
366	(mutex-unlock! m1)))
367	(dec-sem! (lambda ()
368	(mutex-lock! m1)
369	(while (eqv? sem 0) (wait-condition-variable c1 m1))
370	(set! sem (- sem 1))
371	(mutex-unlock! m1)))
372	(t1 (make-thread (lambda ()
373	(mutex-lock! m2)
374	(inc-sem!)
375	(mutex-unlock! m2 c2)
376	(inc-sem!))))
377	(t2 (make-thread (lambda ()
378	(mutex-lock! m2)
379	(inc-sem!)
380	(mutex-unlock! m2 c2)
381	(inc-sem!)))))
382	(thread-start! t1)
383	(thread-start! t2)
384	(dec-sem!)
385	(dec-sem!)
386	(mutex-lock! m2)
387	(condition-variable-broadcast! c2)
388	(mutex-unlock! m2)
389	(dec-sem!)
390	(dec-sem!))))
391
392	(with-test-prefix "time?"
393
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))))
397
398	(with-test-prefix "time->seconds"
399
400	(pass-if "time->seconds makes time into rational"
401	(rational? (time->seconds (current-time))))
402
403	(pass-if "time->seconds is reversible"
404	(let ((t (current-time)))
405	(equal? t (seconds->time (time->seconds t))))))
406
407	(with-test-prefix "seconds->time"
408
409	(pass-if "seconds->time makes rational into time"
410	(time? (seconds->time 123.456)))
411
412	(pass-if "seconds->time is reversible"
413	(let ((t (time->seconds (current-time))))
414	(equal? t (time->seconds (seconds->time t))))))
415
416	(with-test-prefix "current-exception-handler"
417
418	(pass-if "current handler returned at top level"
419	(procedure? (current-exception-handler)))
420
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)
424	h)))))
425
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))))
432
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
440	h2 (lambda ()
441	(mutex-lock! m)
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)))
447	(mutex-lock! m)
448	(thread-start! t)
449	(wait-condition-variable c m)
450	(and (eq? (current-exception-handler) h1)
451	(condition-variable-signal! c)
452	(mutex-unlock! m)
453	(thread-join! t)))))
454
455	(with-test-prefix "uncaught-exception-reason"
456
457	(pass-if "initial handler captures top level exception"
458	(let ((t (make-thread (lambda () (raise 'foo))))
459	(success #f))
460	(thread-start! t)
461	(with-exception-handler
462	(lambda (obj)
463	(and (uncaught-exception? obj)
464	(eq? (uncaught-exception-reason obj) 'foo)
465	(set! success #t)))
466	(lambda () (thread-join! t)))
467	success))
468
469	(pass-if "initial handler captures non-SRFI-18 throw"
470	(let ((t (make-thread (lambda () (throw 'foo))))
471	(success #f))
472	(thread-start! t)
473	(with-exception-handler
474	(lambda (obj)
475	(and (uncaught-exception? obj)
476	(eq? (uncaught-exception-reason obj) 'foo)
477	(set! success #t)))
478	(lambda () (thread-join! t)))
479	success)))
70eca635 LC	480
70eca635 LC	481	)