;;;; 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* (make-mutex (gensym 'critical-section)))

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

(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])
        (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)]) ) ) )
		'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-one
	(make-thread
		(lambda ()
			(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))) ) )
		'writer-one) )

(define writer-thread-two
	(make-thread
		(lambda ()
			(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))) ) )
		'writer-two) )

(define reader-thread-one
	(make-thread
		(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 (and (even? (cdr msg)) (not (zero? (modulo (cdr msg) MESSAGE-LIMIT))))
							(thread-labeled-print "Removing Message " msg)
							(mailbox-cursor-extract-and-rewind! mbc) )
						(loop (mailbox-cursor-next mbc)) ) ) ) )
		'reader-one) )

(define reader-thread-two
	(make-thread
		(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 (odd? (cdr msg))
							(thread-labeled-print "Removing Message " msg)
							(mailbox-cursor-extract-and-rewind! mbc) )
						(loop (mailbox-cursor-next mbc)) ) ) ) )
		'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)