(import scheme (srfi 18) test)

;;

(cond-expand
  (chicken-5
    (import
      (chicken type)
      (only (chicken fixnum) fx= fx+ fx- fxmod)
      (only (chicken bitwise) integer-length)
      (only (chicken random) pseudo-random-integer) )
    (define platform-random pseudo-random-integer) )
  (chicken-4
    (use
      (only chicken arithmetic-shift fx= fx+ fx- fxmod)
      (only extras random))
    (define platform-random random)
    (define (integer-length n)
      (if (negative? n)
        (add1 (integer-length (abs n)))
        (do (
              (i 1 (add1 i))
              (n (arithmetic-shift n -1) (arithmetic-shift n -1)) )
            ((zero? n) i) ) ) ) ) )

(: vector-shuffle! ((vector-of *) #!optional (procedure (fixnum) fixnum) -> void))
;
(define (vector-shuffle! vec #!optional (rnd platform-random))
  (let (
    (len (vector-length vec)) )
    (define (swap-adj! i)
      (let (
        (i+1 (fxmod (fx+ i 1) len))
        (tmp (vector-ref vec i)) )
        (vector-set! vec i (vector-ref vec i+1))
        (vector-set! vec i+1 tmp) ) )
    (do ((n (integer-length len) (fx- n 1)))
        ((fx= n 0))
      (swap-adj! (rnd len)) ) ) )

(: shuffle ((list-of *) #!optional (procedure (fixnum) fixnum) -> (list-of *)))
;
(define (shuffle ls #!optional (rnd platform-random))
  (let (
    (vec (list->vector ls)) )
    (vector-shuffle! vec rnd)
    (vector->list vec) ) )

;;

(define (eof-object) #!eof)

;; SRFI 121

(define (make-coroutine-generator proc)
  (define return #f)
  (define resume #f)
  (define yield (lambda (v) (call/cc (lambda (r) (set! resume r) (return v)))))
  (lambda () (call/cc (lambda (cc) (set! return cc)
                        (if resume
                          (resume (if #f #f))  ; void? or yield again?
                          (begin (proc yield)
                                 (set! resume (lambda (v) (return (eof-object))))
                                 (return (eof-object))))))))

;; srfi-154

(define (current-dynamic-extent)
  (call-with-current-continuation
   (lambda (return)
     (call-with-values
        (lambda ()
           (call-with-current-continuation
            (lambda (c)
              (return
               (lambda (thunk)
                 (call-with-current-continuation
                  (lambda (k)
                    (c k thunk))))))))
        (lambda (k thunk)
           (call-with-values thunk k))))))

(define-syntax dynamic-lambda
  (syntax-rules ()
    ((dynamic-lambda formals body ...)
     (let ((dynamic-extent (current-dynamic-extent)))
       (lambda formals
         (dynamic-extent (lambda () body ...)))))))

;;

(define (count-to-coroutine lim #!optional (initial 0))
  (make-coroutine-generator (lambda (yield)
    (let loop ((state initial))
      (when (< state lim)
        (let ((value state))
          (yield value)
          (loop (add1 state)) ) ) ) ) ) )

;lambda vs dynamic-lambda
(define (count-to-iteration lim #!optional (initial 0))
  (dynamic-lambda (proc)
    (let loop ((state initial))
      (when (< state lim)
        (let ((value state))
          (proc value)
          (loop (add1 state)) ) ) ) ) )

;;

(define *run-in-threads* '())

(define-syntax run-in-thread
  (syntax-rules ()
    ((run-in-thread body ...)
      (let ((th (make-thread (lambda () body ...))))
        (set! *run-in-threads* (cons th *run-in-threads*)) ) ) ) )

(define (start-run-in-threads) (for-each thread-start! *run-in-threads*))
(define (join-run-in-threads) (for-each thread-join! *run-in-threads*))

(define (randomize-run-in-threads) (set! *run-in-threads* (shuffle *run-in-threads*)))

(define (run-in-threads)
  (randomize-run-in-threads)
  (start-run-in-threads)
  ;(thread-yield!)
  (randomize-run-in-threads)
  (join-run-in-threads) )

;; Test

(define *statement* #<<EOS
*** Tests Will Fail ***
Which depends on how threads are scheduled.

Shows a reasonable use of an exit continuation
breaks the implied "isolation".

Need to know what is being synch'ed.
Coroutine Generators OK, Dynamic-Lambda, not OK.
EOS
)

;

(test-begin "Synch Examples")

;#;
(let ((genny (count-to-coroutine 5)) (end-state #f))
(run-in-thread
  (test-group "Genny"
    ;(let ((genny (count-to-coroutine 5)) (end-state #f))
      (let loop ((i (genny)))
        (unless (eof-object? i)
          (set! end-state i)
          (thread-yield!)
          (loop (genny)) ) )
      (test "ran to end" 4 end-state) )
  )
)

;#;
(let ((iter (count-to-iteration 5)) (end-state #f))
(run-in-thread
  (test-group "Dynamic Context"
    ;(let ((iter (count-to-iteration 5)) (end-state #f))
      (iter (lambda (state)
        (thread-yield!)
        (set! end-state state)))
      (test "ran to end" 4 end-state) )
  )
)

;

(import synch-dynexn)

(define mx1 (make-mutex 'mx1))

;#;
(let ((genny (count-to-coroutine 5)) (end-state #f))
(run-in-thread
  (test-group "Synch Genny"
    ;(let ((genny (count-to-coroutine 5)) (end-state #f))
      (synch mx1
        (let loop ((i (genny)))
          (test-assert "locked" (not (eq? 'not-abandoned (mutex-state mx1))))
          (unless (eof-object? i)
            (set! end-state i)
            (thread-yield!)
            (loop (genny)) ) ) )
      (test "ran to end" 4 end-state)
      (test "unlocked" 'not-abandoned (mutex-state mx1)) )
  )
)

;#;
(let ((iter (count-to-iteration 5)) (end-state #f))
(run-in-thread
  (test-group "Synch Dynamic Context (Early Exit Handler Call)"
    ;(let ((iter (count-to-iteration 5)) (end-state #f))
      (synch mx1
        (iter (lambda (state)
          (test-assert "unlocked (Way Too Early)" (eq? 'not-abandoned (mutex-state mx1)))
          (thread-yield!)
          (set! end-state state) ) ) )
      (test "ran to end" 4 end-state)
      (test "unlocked" 'not-abandoned (mutex-state mx1)) )
  )
)

;

;(test-begin "Synch Examples") ;interesting: test impl artifact?

(run-in-threads)

(test-end "Synch Examples")

(print *statement*)

(test-exit)