;;; -*- mode: scheme; scheme48-package: rendezvous-mailboxes -*-

;;;; Rendezvous Concurrency Abstraction
;;;; Mailboxes: Asynchronous Channels

;;; This code is written by Taylor Campbell and placed in the Public
;;; Domain.  All warranties are disclaimed.

(define-synchronized-record-type mailbox :mailbox
  (%make-mailbox priority queue)
  (priority)    ; Only the priority field is synchronized.
  mailbox?
  ;; The priority may be #F, in which case the queue is a queue of
  ;; waiting readers' suspensions, or an integer, the number of
  ;; messages in the queue.
  (priority mailbox-priority set-mailbox-priority!)
  (queue mailbox-queue))

(define (make-mailbox) (%make-mailbox #f (make-queue)))

(define (mailbox-send mailbox message)
  (enter-critical-region
   (lambda (critical-token)
     (mailbox-send/critical mailbox message critical-token))))

(define (mailbox-send/critical mailbox message critical-token)
  (let ((queue (mailbox-queue mailbox)))
    (cond ((mailbox-priority mailbox)
           => (lambda (priority)
                (set-mailbox-priority! mailbox (+ priority 1))
                (enqueue! queue message)
                (exit-critical-region critical-token values)))
          (else
           (let loop ()
             (cond ((queue-empty? queue)
                    (set-mailbox-priority! mailbox 1)
                    (enqueue! queue message)
                    (exit-critical-region critical-token values))
                   (else
                    (revive (dequeue! queue)
                            critical-token
                            (lambda (revived?)
                              (if (not revived?)
                                  (loop)))
                            message))))))))

(define (mailbox-receive mailbox)
  (synchronize (mailbox-receptor-rendezvous mailbox)))

(define (mailbox-receptor-rendezvous mailbox)
  (polling-rendezvous
   (lambda ()
     (let ((queue (mailbox-queue mailbox)))
       (cond ((mailbox-priority mailbox)
              => (lambda (priority)
                   (set-mailbox-priority! mailbox (+ priority 1))
                   (values priority
                           (lambda (prepare-revival)
                             (let ((message (dequeue! queue)))
                               (set-mailbox-priority!
                                mailbox
                                (if (queue-empty? queue) #f 1))
                               message)))))
             (else
              (values #f (lambda (suspension)
                           (enqueue! queue suspension)))))))))