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