;;;; mailbox tests/run.scm

;;;

(require-extension mailbox)
(import mailbox)

(require-library srfi-18)
(import srfi-18)


;;; Test support

(define-constant MESSAGE-LIMIT 5)

(define-constant TIMEOUT #;0.5 0.25)

(define (current-thread-name) (thread-name (current-thread)))

(define (current-seconds) (time->seconds (current-time)))

(define *critical-section-mutex* (make-mutex (gensym 'critical-section)))

(define-syntax critical-section
  (syntax-rules (*critical-section-mutex*)
    ((_ ?body ...)
      (dynamic-wind
        (lambda () (mutex-lock! *critical-section-mutex*))
        (lambda () ?body ...)
        (lambda () (mutex-unlock! *critical-section-mutex*)) ) ) ) )

(define (thread-labeled-print . args)
	(critical-section (apply print "Thread " (current-thread-name) " - " args) ) )


;;; Test mailbox

(define mailbox-one (make-mailbox 'one))

(define writer-thread-one
	(make-thread
		(lambda ()
			(thread-labeled-print "Started!")
			(let loop ((cnt 0))
        (thread-labeled-print "Sending at " (current-seconds) " sec")
        (mailbox-send! mailbox-one (cons (current-thread-name) cnt))
        (if (= MESSAGE-LIMIT cnt) (mailbox-send! mailbox-one 'quit)
            (let ((sleep@seconds (current-seconds)))
              (thread-labeled-print "Sleep at " sleep@seconds " sec")
              (thread-sleep! TIMEOUT)
              (thread-labeled-print "Awake after " (- (current-seconds) sleep@seconds) " sec")
              (loop (add1 cnt)) ) ) ) )
		'writer-one) )

(define reader-thread-one
	(make-thread
		(lambda ()
			(thread-labeled-print "Started!")
			(let loop ()
			  (let ((receive@seconds (current-seconds)))
          (condition-case
              (begin
                (thread-labeled-print "Receiving at " receive@seconds  " sec")
                (let ((msg (mailbox-receive! mailbox-one TIMEOUT)))
                  (thread-labeled-print "Message " msg)
                  (unless (eq? 'quit msg) (loop) ) ) )
            ((exn mailbox timeout)
              (thread-labeled-print "Timedout after " (- (current-seconds) receive@seconds) " sec")
              (loop))
            (exp ()
              (thread-labeled-print
                "Exception: " exp
                "; " ((condition-property-accessor 'exn 'location) exp)
                ": " ((condition-property-accessor 'exn 'message) exp)
                " - " ((condition-property-accessor 'exn 'arguments) exp)) ) ) ) ) )
		'reader-one) )

(newline)
(print "** Test mailbox **")
(print "Message Limit = " MESSAGE-LIMIT " Timeout = " TIMEOUT " seconds")
(newline)

(thread-start! writer-thread-one)
(thread-start! reader-thread-one)

(thread-join! writer-thread-one)
(thread-join! reader-thread-one)


;;; Test mailbox-cursor

;;

(define mailbox-one (make-mailbox 'one))

(define (writer-thread-body)
  (thread-labeled-print "Started!")
  (let loop ((cnt 0))
    (thread-sleep! TIMEOUT)
    (mailbox-send! mailbox-one (cons (current-thread-name) cnt))
    (if (= MESSAGE-LIMIT cnt) (mailbox-send! mailbox-one 'quit)
        (loop (add1 cnt))) ) )

(define (make-reader-thread-body test)
  (lambda ()
    (thread-labeled-print "Started!")
    (let ((mbc (make-mailbox-cursor mailbox-one)))
      (let loop ((msg (mailbox-cursor-next mbc)))
        (thread-labeled-print "Message " msg)
        (unless (eq? 'quit msg)
          (when (test msg)
            (thread-labeled-print "Removing Message " msg)
            (mailbox-cursor-extract-and-rewind! mbc) )
          (loop (mailbox-cursor-next mbc)) ) ) ) ) )

;;

(define writer-thread-one (make-thread writer-thread-body 'writer-one))

(define writer-thread-two (make-thread writer-thread-body 'writer-two))

(define reader-thread-one
	(make-thread
		(make-reader-thread-body
		  (lambda (msg) (and (even? (cdr msg)) (not (zero? (modulo (cdr msg) MESSAGE-LIMIT))))))
		'reader-one) )

(define reader-thread-two
	(make-thread
		(make-reader-thread-body (lambda (msg) (odd? (cdr msg))))
		'reader-two) )

(newline)
(print "** Test mailbox-cursor **")
(print "Message Limit = " MESSAGE-LIMIT " Timeout = " TIMEOUT " seconds")
(newline)

(thread-start! writer-thread-one)
(thread-start! writer-thread-two)
(thread-start! reader-thread-one)
(thread-start! reader-thread-two)

(thread-join! writer-thread-one)
(thread-join! writer-thread-two)
(thread-join! reader-thread-one)
(thread-join! reader-thread-two)