test-suite/tests/srfi-18.test

   1 ;;;; srfi-18.test --- Test suite for Guile's SRFI-18 functions. -*- scheme -*-
   2 ;;;; Julian Graham, 2007-10-26
   3 ;;;;
   4 ;;;; Copyright (C) 2007, 2008 Free Software Foundation, Inc.
   5 ;;;;
   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.
  10 ;;;;
  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.
  15 ;;;;
  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
  19
  20 (define-module (test-suite test-srfi-18)
  21   #:use-module (test-suite lib))
  22
  23 ;; two expressions so that the srfi-18 import is in effect for expansion
  24 ;; of the rest
  25 (if (provided? 'threads)
  26     (use-modules (srfi srfi-18)))
  27
  28 (and
  29  (provided? 'threads)
  30
  31 (with-test-prefix "current-thread"
  32
  33   (pass-if "current-thread eq current-thread"
  34     (eq? (current-thread) (current-thread))))
  35
  36 (with-test-prefix "thread?"
  37
  38   (pass-if "current-thread is thread"
  39     (thread? (current-thread)))
  40
  41   (pass-if "foo not thread"
  42     (not (thread? 'foo))))
  43
  44 (with-test-prefix "make-thread"
  45
  46   (pass-if "make-thread creates new thread"
  47     (let* ((n (length (all-threads)))
  48            (t (make-thread (lambda () 'foo) 'make-thread-1))
  49            (r (> (length (all-threads)) n)))
  50       (thread-terminate! t) r)))
  51
  52 (with-test-prefix "thread-name"
  53
  54   (pass-if "make-thread with name binds name"
  55     (let* ((t (make-thread (lambda () 'foo) 'thread-name-1))
  56            (r (eq? (thread-name t) 'thread-name-1)))
  57       (thread-terminate! t) r))
  58
  59   (pass-if "make-thread without name does not bind name"
  60     (let* ((t (make-thread (lambda () 'foo)))
  61            (r (not (thread-name t))))
  62       (thread-terminate! t) r)))
  63
  64 (with-test-prefix "thread-specific"
  65
  66   (pass-if "thread-specific is initially #f"
  67     (let* ((t (make-thread (lambda () 'foo) 'thread-specific-1))
  68            (r (not (thread-specific t))))
  69       (thread-terminate! t) r))
  70
  71   (pass-if "thread-specific-set! can set value"
  72     (let ((t (make-thread (lambda () 'foo) 'thread-specific-2)))
  73       (thread-specific-set! t "hello")
  74       (let ((r (equal? (thread-specific t) "hello")))
  75         (thread-terminate! t) r))))
  76
  77 (with-test-prefix "thread-start!"
  78
  79   (pass-if "thread activates only after start"
  80     (let* ((started #f)
  81            (m (make-mutex 'thread-start-mutex))
  82            (t (make-thread (lambda () (set! started #t)) 'thread-start-1)))
  83       (and (not started) (thread-start! t) (thread-join! t) started))))
  84
  85 (with-test-prefix "thread-yield!"
  86
  87   (pass-if "thread yield suceeds"
  88     (thread-yield!) #t))
  89
  90 (with-test-prefix "thread-sleep!"
  91
  92   (pass-if "thread sleep with time"
  93     (let ((future-time (seconds->time (+ (time->seconds (current-time)) 2))))
  94       (unspecified? (thread-sleep! future-time))))
  95
  96   (pass-if "thread sleep with number"
  97     (let ((old-secs (car (current-time))))
  98       (unspecified? (thread-sleep! (+ (time->seconds (current-time)))))))
  99
 100   (pass-if "thread does not sleep on past time"
 101     (let ((past-time (seconds->time (- (time->seconds (current-time)) 2))))
 102       (unspecified? (thread-sleep! past-time)))))
 103
 104 (with-test-prefix "thread-terminate!"
 105
 106   (pass-if "termination destroys non-started thread"
 107     (let ((t (make-thread (lambda () 'nothing) 'thread-terminate-1))
 108           (num-threads (length (all-threads)))
 109           (success #f))
 110       (thread-terminate! t)
 111       (with-exception-handler
 112        (lambda (obj) (set! success (terminated-thread-exception? obj)))
 113        (lambda () (thread-join! t)))
 114       success))
 115
 116   (pass-if "termination destroys started thread"
 117     (let* ((m1 (make-mutex 'thread-terminate-2a))
 118            (m2 (make-mutex 'thread-terminate-2b))
 119            (c (make-condition-variable 'thread-terminate-2))
 120            (t (make-thread (lambda ()
 121                              (mutex-lock! m1)
 122                              (condition-variable-signal! c)
 123                              (mutex-unlock! m1)
 124                              (mutex-lock! m2))
 125                            'thread-terminate-2))
 126            (success #f))
 127       (mutex-lock! m1)
 128       (mutex-lock! m2)
 129       (thread-start! t)
 130       (mutex-unlock! m1 c)
 131       (thread-terminate! t)
 132       (with-exception-handler
 133        (lambda (obj) (set! success (terminated-thread-exception? obj)))
 134        (lambda () (thread-join! t)))
 135       success)))
 136
 137 (with-test-prefix "thread-join!"
 138
 139   (pass-if "join receives result of thread"
 140     (let ((t (make-thread (lambda () 'foo) 'thread-join-1)))
 141       (thread-start! t)
 142       (eq? (thread-join! t) 'foo)))
 143
 144   (pass-if "join receives timeout val if timeout expires"
 145     (let* ((m (make-mutex 'thread-join-2))
 146            (t (make-thread (lambda () (mutex-lock! m)) 'thread-join-2)))
 147       (mutex-lock! m)
 148       (thread-start! t)
 149       (let ((r (thread-join! t (current-time) 'bar)))
 150         (thread-terminate! t)
 151         (eq? r 'bar))))
 152
 153   (pass-if "join throws exception on timeout without timeout val"
 154     (let* ((m (make-mutex 'thread-join-3))
 155            (t (make-thread (lambda () (mutex-lock! m)) 'thread-join-3))
 156            (success #f))
 157       (mutex-lock! m)
 158       (thread-start! t)
 159       (with-exception-handler
 160        (lambda (obj) (set! success (join-timeout-exception? obj)))
 161        (lambda () (thread-join! t (current-time))))
 162       (thread-terminate! t)
 163       success))
 164
 165   (pass-if "join waits on timeout"
 166     (let ((t (make-thread (lambda () (sleep 1) 'foo) 'thread-join-4)))
 167       (thread-start! t)
 168       (eq? (thread-join! t (+ (time->seconds (current-time)) 2)) 'foo))))
 169
 170 (with-test-prefix "mutex?"
 171
 172   (pass-if "make-mutex creates mutex"
 173     (mutex? (make-mutex)))
 174
 175   (pass-if "symbol not mutex"
 176     (not (mutex? 'foo))))
 177
 178 (with-test-prefix "mutex-name"
 179
 180   (pass-if "make-mutex with name binds name"
 181     (let* ((m (make-mutex 'mutex-name-1)))
 182       (eq? (mutex-name m) 'mutex-name-1)))
 183
 184   (pass-if "make-mutex without name does not bind name"
 185     (let* ((m (make-mutex)))
 186       (not (mutex-name m)))))
 187
 188 (with-test-prefix "mutex-specific"
 189
 190   (pass-if "mutex-specific is initially #f"
 191     (let ((m (make-mutex 'mutex-specific-1)))
 192       (not (mutex-specific m))))
 193
 194   (pass-if "mutex-specific-set! can set value"
 195     (let ((m (make-mutex 'mutex-specific-2)))
 196       (mutex-specific-set! m "hello")
 197       (equal? (mutex-specific m) "hello"))))
 198
 199 (with-test-prefix "mutex-state"
 200
 201   (pass-if "mutex state is initially not-abandoned"
 202     (let ((m (make-mutex 'mutex-state-1)))
 203       (eq? (mutex-state m) 'not-abandoned)))
 204
 205   (pass-if "mutex state of locked, owned mutex is owner thread"
 206     (let ((m (make-mutex 'mutex-state-2)))
 207       (mutex-lock! m)
 208       (eq? (mutex-state m) (current-thread))))
 209
 210   (pass-if "mutex state of locked, unowned mutex is not-owned"
 211     (let ((m (make-mutex 'mutex-state-3)))
 212       (mutex-lock! m #f #f)
 213       (eq? (mutex-state m) 'not-owned)))
 214
 215   (pass-if "mutex state of unlocked, abandoned mutex is abandoned"
 216     (let* ((m (make-mutex 'mutex-state-4))
 217            (t (make-thread (lambda () (mutex-lock! m)))))
 218       (thread-start! t)
 219       (thread-join! t)
 220       (eq? (mutex-state m) 'abandoned))))
 221
 222 (with-test-prefix "mutex-lock!"
 223
 224   (pass-if "mutex-lock! returns true on successful lock"
 225     (let* ((m (make-mutex 'mutex-lock-1)))
 226       (mutex-lock! m)))
 227
 228   (pass-if "mutex-lock! returns false on timeout"
 229     (let* ((m (make-mutex 'mutex-lock-2))
 230            (t (make-thread (lambda () (mutex-lock! m (current-time) #f)))))
 231       (mutex-lock! m)
 232       (thread-start! t)
 233       (not (thread-join! t))))
 234
 235   (pass-if "mutex-lock! returns true when lock obtained within timeout"
 236     (let* ((m (make-mutex 'mutex-lock-3))
 237            (t (make-thread (lambda ()
 238                              (mutex-lock! m (+ (time->seconds (current-time))
 239                                                100)
 240                                           #f)))))
 241       (mutex-lock! m)
 242       (thread-start! t)
 243       (mutex-unlock! m)
 244       (thread-join! t)))
 245
 246   (pass-if "can lock mutex for non-current thread"
 247     (let* ((m1 (make-mutex 'mutex-lock-4a))
 248            (m2 (make-mutex 'mutex-lock-4b))
 249            (t (make-thread (lambda () (mutex-lock! m1)) 'mutex-lock-4)))
 250       (mutex-lock! m1)
 251       (thread-start! t)
 252       (mutex-lock! m2 #f t)
 253       (let ((success (eq? (mutex-state m2) t)))
 254         (thread-terminate! t) success)))
 255
 256   (pass-if "locking abandoned mutex throws exception"
 257     (let* ((m (make-mutex 'mutex-lock-5))
 258            (t (make-thread (lambda () (mutex-lock! m)) 'mutex-lock-5))
 259            (success #f))
 260       (thread-start! t)
 261       (thread-join! t)
 262       (with-exception-handler
 263        (lambda (obj) (set! success (abandoned-mutex-exception? obj)))
 264        (lambda () (mutex-lock! m)))
 265       (and success (eq? (mutex-state m) (current-thread)))))
 266
 267   (pass-if "sleeping threads notified of abandonment"
 268     (let* ((m1 (make-mutex 'mutex-lock-6a))
 269            (m2 (make-mutex 'mutex-lock-6b))
 270            (c (make-condition-variable 'mutex-lock-6))
 271            (t (make-thread (lambda ()
 272                              (mutex-lock! m1)
 273                              (mutex-lock! m2)
 274                              (condition-variable-signal! c))))
 275            (success #f))
 276       (mutex-lock! m1)
 277       (thread-start! t)
 278       (with-exception-handler
 279        (lambda (obj) (set! success (abandoned-mutex-exception? obj)))
 280        (lambda () (mutex-unlock! m1 c) (mutex-lock! m2)))
 281       success)))
 282
 283 (with-test-prefix "mutex-unlock!"
 284
 285   (pass-if "unlock changes mutex state"
 286     (let* ((m (make-mutex 'mutex-unlock-1)))
 287       (mutex-lock! m)
 288       (mutex-unlock! m)
 289       (eq? (mutex-state m) 'not-abandoned)))
 290
 291   (pass-if "can unlock from any thread"
 292     (let* ((m (make-mutex 'mutex-unlock-2))
 293            (t (make-thread (lambda () (mutex-unlock! m)) 'mutex-unlock-2)))
 294       (mutex-lock! m)
 295       (thread-start! t)
 296       (thread-join! t)
 297       (eq? (mutex-state m) 'not-abandoned)))
 298
 299   (pass-if "mutex unlock is true when condition is signalled"
 300     (let* ((m (make-mutex 'mutex-unlock-3))
 301            (c (make-condition-variable 'mutex-unlock-3))
 302            (t (make-thread (lambda ()
 303                              (mutex-lock! m)
 304                              (condition-variable-signal! c)
 305                              (mutex-unlock! m)))))
 306       (mutex-lock! m)
 307       (thread-start! t)
 308       (mutex-unlock! m c)))
 309
 310   (pass-if "mutex unlock is false when condition times out"
 311     (let* ((m (make-mutex 'mutex-unlock-4))
 312            (c (make-condition-variable 'mutex-unlock-4)))
 313       (mutex-lock! m)
 314       (not (mutex-unlock! m c (+ (time->seconds (current-time)) 1))))))
 315
 316 (with-test-prefix "condition-variable?"
 317
 318   (pass-if "make-condition-variable creates condition variable"
 319     (condition-variable? (make-condition-variable)))
 320
 321   (pass-if "symbol not condition variable"
 322     (not (condition-variable? 'foo))))
 323
 324 (with-test-prefix "condition-variable-name"
 325
 326   (pass-if "make-condition-variable with name binds name"
 327     (let* ((c (make-condition-variable 'condition-variable-name-1)))
 328       (eq? (condition-variable-name c) 'condition-variable-name-1)))
 329
 330   (pass-if "make-condition-variable without name does not bind name"
 331     (let* ((c (make-condition-variable)))
 332       (not (condition-variable-name c)))))
 333
 334 (with-test-prefix "condition-variable-specific"
 335
 336   (pass-if "condition-variable-specific is initially #f"
 337     (let ((c (make-condition-variable 'condition-variable-specific-1)))
 338       (not (condition-variable-specific c))))
 339
 340   (pass-if "condition-variable-specific-set! can set value"
 341     (let ((c (make-condition-variable 'condition-variable-specific-1)))
 342       (condition-variable-specific-set! c "hello")
 343       (equal? (condition-variable-specific c) "hello"))))
 344
 345 (with-test-prefix "condition-variable-signal!"
 346
 347   (pass-if "condition-variable-signal! wakes up single thread"
 348     (let* ((m (make-mutex 'condition-variable-signal-1))
 349            (c (make-condition-variable 'condition-variable-signal-1))
 350            (t (make-thread (lambda ()
 351                              (mutex-lock! m)
 352                              (condition-variable-signal! c)
 353                              (mutex-unlock! m)))))
 354       (mutex-lock! m)
 355       (thread-start! t)
 356       (mutex-unlock! m c))))
 357
 358 (with-test-prefix "condition-variable-broadcast!"
 359
 360   (pass-if "condition-variable-broadcast! wakes up multiple threads"
 361     (let* ((sem 0)
 362            (c1 (make-condition-variable 'condition-variable-broadcast-1-a))
 363            (m1 (make-mutex 'condition-variable-broadcast-1-a))
 364            (c2 (make-condition-variable 'condition-variable-broadcast-1-b))
 365            (m2 (make-mutex 'condition-variable-broadcast-1-b))
 366            (inc-sem! (lambda ()
 367                        (mutex-lock! m1)
 368                        (set! sem (+ sem 1))
 369                        (condition-variable-broadcast! c1)
 370                        (mutex-unlock! m1)))
 371            (dec-sem! (lambda ()
 372                        (mutex-lock! m1)
 373                        (while (eqv? sem 0) (wait-condition-variable c1 m1))
 374                        (set! sem (- sem 1))
 375                        (mutex-unlock! m1)))
 376            (t1 (make-thread (lambda ()
 377                               (mutex-lock! m2)
 378                               (inc-sem!)
 379                               (mutex-unlock! m2 c2)
 380                               (inc-sem!))))
 381            (t2 (make-thread (lambda ()
 382                               (mutex-lock! m2)
 383                               (inc-sem!)
 384                               (mutex-unlock! m2 c2)
 385                               (inc-sem!)))))
 386       (thread-start! t1)
 387       (thread-start! t2)
 388       (dec-sem!)
 389       (dec-sem!)
 390       (mutex-lock! m2)
 391       (condition-variable-broadcast! c2)
 392       (mutex-unlock! m2)
 393       (dec-sem!)
 394       (dec-sem!))))
 395
 396 (with-test-prefix "time?"
 397
 398   (pass-if "current-time is time" (time? (current-time)))
 399   (pass-if "number is not time" (not (time? 123)))
 400   (pass-if "symbol not time" (not (time? 'foo))))
 401
 402 (with-test-prefix "time->seconds"
 403
 404   (pass-if "time->seconds makes time into rational"
 405     (rational? (time->seconds (current-time))))
 406
 407   (pass-if "time->seconds is reversible"
 408     (let ((t (current-time)))
 409       (equal? t (seconds->time (time->seconds t))))))
 410
 411 (with-test-prefix "seconds->time"
 412
 413   (pass-if "seconds->time makes rational into time"
 414     (time? (seconds->time 123.456)))
 415
 416   (pass-if "seconds->time is reversible"
 417     (let ((t (time->seconds (current-time))))
 418       (equal? t (time->seconds (seconds->time t))))))
 419
 420 (with-test-prefix "current-exception-handler"
 421
 422   (pass-if "current handler returned at top level"
 423     (procedure? (current-exception-handler)))
 424
 425   (pass-if "specified handler set under with-exception-handler"
 426     (let ((h (lambda (key . args) 'nothing)))
 427       (with-exception-handler h (lambda () (eq? (current-exception-handler)
 428                                                 h)))))
 429
 430   (pass-if "multiple levels of handler nesting"
 431     (let ((h (lambda (key . args) 'nothing))
 432           (i (current-exception-handler)))
 433       (and (with-exception-handler h (lambda ()
 434                                        (eq? (current-exception-handler) h)))
 435            (eq? (current-exception-handler) i))))
 436
 437   (pass-if "exception handler installation is thread-safe"
 438     (let* ((h1 (current-exception-handler))
 439            (h2 (lambda (key . args) 'nothing-2))
 440            (m (make-mutex 'current-exception-handler-4))
 441            (c (make-condition-variable 'current-exception-handler-4))
 442            (t (make-thread (lambda ()
 443                              (with-exception-handler
 444                               h2 (lambda ()
 445                                    (mutex-lock! m)
 446                                    (condition-variable-signal! c)
 447                                    (wait-condition-variable c m)
 448                                    (and (eq? (current-exception-handler) h2)
 449                                         (mutex-unlock! m)))))
 450                            'current-exception-handler-4)))
 451       (mutex-lock! m)
 452       (thread-start! t)
 453       (wait-condition-variable c m)
 454       (and (eq? (current-exception-handler) h1)
 455            (condition-variable-signal! c)
 456            (mutex-unlock! m)
 457            (thread-join! t)))))
 458
 459 (with-test-prefix "uncaught-exception-reason"
 460
 461   (pass-if "initial handler captures top level exception"
 462     (let ((t (make-thread (lambda () (raise 'foo))))
 463           (success #f))
 464       (thread-start! t)
 465       (with-exception-handler
 466        (lambda (obj)
 467          (and (uncaught-exception? obj)
 468               (eq? (uncaught-exception-reason obj) 'foo)
 469               (set! success #t)))
 470        (lambda () (thread-join! t)))
 471       success))
 472
 473   (pass-if "initial handler captures non-SRFI-18 throw"
 474     (let ((t (make-thread (lambda () (throw 'foo))))
 475           (success #f))
 476       (thread-start! t)
 477       (with-exception-handler
 478        (lambda (obj)
 479          (and (uncaught-exception? obj)
 480               (eq? (uncaught-exception-reason obj) 'foo)
 481               (set! success #t)))
 482        (lambda () (thread-join! t)))
 483       success)))
 484
 485 )