;;;; mailbox tests/reader-writer-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

(let ((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 (makmsg cnt))
          (if (= MESSAGE-LIMIT cnt) (mailbox-send! mailbox-one (makmsg '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 ((rcv@sec (current-seconds)))
            (condition-case
                (begin
                  (thread-labeled-print "Receiving at " rcv@sec  " sec")
                  (let ((msg (mailbox-receive! mailbox-one TIMEOUT)))
                    (thread-labeled-print "Message From " (msgfrm msg) " Is " (msgval msg))
                    (unless (eq? 'quit (msgval msg))
                      (loop) ) ) )
              ((exn mailbox timeout)
                (thread-labeled-print "Timedout after " (- (current-seconds) rcv@sec) " 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) )