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