;; Asynchrones Message-Passing

(define-record-type :async-channel
  (really-make-async-channel lock messages receive-waiting)
  async-channel?
  (lock async-channel-lock)
  (messages async-channel-messages)
  (receive-waiting async-channel-receive-waiting))

(define (make-async-channel)
  (let ((lock (make-lock)))
    (really-make-async-channel lock
			       (make-queue)
			       (make-queue))))

(define (send-async channel message)
  (let ((lock (async-channel-lock channel)))
    (obtain-lock lock)
    (if (queue-empty? (async-channel-receive-waiting channel))
	(begin
	  (enqueue! (async-channel-messages channel) message)
	  (release-lock lock)
	  (relinquish-timeslice))
	(let* ((pair (dequeue! (async-channel-receive-waiting channel)))
	       (waiting-lock (car pair))
	       (cell (cdr pair)))
	  (cell-set! cell message)
	  (release-lock waiting-lock)
	  (release-lock lock)))))

(define (receive-async channel)
  (let ((lock (async-channel-lock channel)))
    (obtain-lock lock)
    (if (queue-empty? (async-channel-messages channel))
	(let ((waiting-lock (make-lock))
	      (cell (make-cell #f)))
	  (obtain-lock waiting-lock)
	  (enqueue! (async-channel-receive-waiting channel)
		    (cons waiting-lock cell))
	  (release-lock lock)
	  (obtain-lock waiting-lock)
	  (cell-ref cell))
	(let ((message (dequeue! (async-channel-messages channel))))
	  (release-lock lock)
	  message))))