;;;; mailbox tests/mailbox-cursor-test.scm

;;;

(use mailbox)
(use 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 (current-thread-name) " - " args) ) )

(define (makmsg x) (cons (current-thread-name) x))
(define (msgfrm x) (car x))
(define (msgval x) (cdr x))


;;; Test mailbox-cursor

;;

(let ((mailbox-one (make-mailbox 'one)))

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

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

  ;;

  (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) (even? (msgval msg))))
      'Reader-One) )

  (define reader-thread-two
    (make-thread
      (make-reader-thread-body
        (lambda (msg) (odd? (msgval msg))))
      'Reader-Two) )

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

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

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