(import test)

(include-relative "test-gloss.incl")

;;

(test-begin "Thread Utils")

(import thread-utils srfi-18)

(test-group "thread-timeout"
  (test-assert "timeout? #f" (thread-timeout? #f))
  (test-assert "timeout? time" (thread-timeout? (current-time)))
  (test-assert "timeout? #" (thread-timeout? 5))
  (test-assert "timeout? X" (not (thread-timeout? 'X)))
  (test #f (make-thread-timeout #f))
  (let ((t (current-time)))
    (test "time (base ignored)" t (make-thread-timeout t 27)) )
  (let* ((b (current-time))
         (t (make-thread-timeout 5 b)) )
    (test "# w/ time base" (+ 5 (time->seconds b)) (time->seconds t)) )
  (let* ((b 5)
         (t (make-thread-timeout 5 b)) )
    (test "# w/ # base" (+ 5 b) (inexact->exact (time->seconds t))) )
  (test-error "bad offset" (make-thread-timeout ""))
  (test-error "bad base" (make-thread-timeout 5 ""))
)

;;

(test-group "thread-... access"
  (let (
      (thgs (list
        thread-thunk
        thread-result-list
        thread-block-timeout
        thread-state-buffer
        ;thread-name
        ;thread-end-exception
        thread-owned-mutexes
        ;thread-quantum
        ;thread-specific
        thread-block-object
        thread-recipients
        thread-dynamic-winds
        thread-standard-input
        thread-standard-output
        thread-standard-error
        thread-default-exception-handler
        thread-current-parameter-vector
        thread-block-object-of-recipient?) )
      (th
        (make-thread (lambda () (void))) ) )
    (for-each
      (lambda (x)
        (test-assert (not (eq? (void) (x th)))) )
      thgs)
    (test-assert (thread-end-exception th))
  )
)

(test-end "Thread Utils")

;;

(test-begin "Thread Reaper")

(import thread-reaper)

(test-group "thread reaping"
  ;immediately stops , so can be reaped
  ;FIXME need test that has loop-time & wait-time before shutdown
  (let ((th (thread-start! (lambda () (begin)))))
    (test-assert (not (thread-reaper-shutdown?)))
    (test-assert (thread-reap! th)) )
  (thread-reaper-stop!)
  (test-assert "shutdown after stop" (thread-reaper-shutdown?))
  (test "no zombies" '() (zombie-threads))
)

(test-group "thread-reaper access"

  (test #f (thread-reaper-greedy))
  (thread-reaper-greedy-set! #t)
  (test #t (thread-reaper-greedy))

  (test 1.0 (thread-reaper-wait-seconds))
  (thread-reaper-wait-seconds-set! 2.0)
  (test 2.0 (thread-reaper-wait-seconds))

  (test #f (thread-reaper-timeout))
  (thread-reaper-timeout-set! 2.0)
  (test 2.0 (thread-reaper-timeout))

  (test 1 (thread-reaper-retries))
  (thread-reaper-retries-set! 2)
  (test 2 (thread-reaper-retries))
)

(test-end "Thread Reaper")

;;

(test-begin "SRFI 18 Barrier")

(import (srfi-18 barrier) (srfi 1))

(define-syntax start-thread!
  (syntax-rules ()
    ((start-thread! body0 ...)
      (thread-start! (make-thread (lambda () body0 ...) ) ) ) ) )

(test-group "basic barrier access"
  (test-assert (make-barrier))
  (test-error (make-barrier #t)) ;NOTE compiler warning
  (test-assert (make-barrier 2))
  (test-assert (barrier? (make-barrier 2)))
  (test 0 (barrier-count (make-barrier)))
  (test 2 (barrier-limit (make-barrier 2)))
  (let ((bar (make-barrier 2 'bar-none))
        (unq (gensym)) )
    (test 'bar-none (barrier-name bar))
    (test 'not-abandoned (barrier-state bar))
    (test-assert (barrier-specific-set! bar unq))
    (test unq (barrier-specific bar)) )
)

;????
;deadlock where BARRIER-LIMIT is "close to" WORKER-COUNT,
;except 1,2 (2,3 & 3,4 deadlock)

(define-constant BARRIER-LIMIT 3)
(define-constant WORKER-COUNT 4)
(define-constant WORK-AMNT 3)
;FIXNE test timeout
(define-constant WORKER-TIMEOUT 0.0001)

;#;
(define (timenow)
  (import (chicken time))
  (current-process-milliseconds) )

(define (after-seconds n)
  (and n (seconds->time (+ n (time->seconds (current-time))))) )

(test-group "barrier wait"
  (let ((bar (make-barrier BARRIER-LIMIT))
        (work (make-vector WORKER-COUNT 0)) )
    (define (worker i)
      (start-thread!
        (let loop ((n (sub1 WORK-AMNT)))
          (gloss "waiting... " i " " (timenow))
          (let ((res (barrier-wait bar (after-seconds WORKER-TIMEOUT))))
            (gloss "running... (" res ") "  i " " (timenow)) )
          (when (even? i)
            (gloss "sleeping... " i " " (timenow))
            (thread-sleep! 4)
            (gloss "running...  (sleep) "  i " " (timenow) ) )
          (vector-set! work i (add1 (vector-ref work i)))
          (unless (zero? n) (loop (sub1 n)) ) ) ) )
    (let ((ths (map worker (iota WORKER-COUNT))))
      (for-each thread-join! ths)
      (test work (make-vector WORKER-COUNT WORK-AMNT)) ) )
)

(test-end "SRFI 18 Barrier")

;;;

(test-exit)