Split out blocking-box

blocking-box.rkt

@@ -0,0 +1,30 @@
+#lang racket/base
+;; A box whose value can only be set once, that starts life with no
+;; value, and that supports an event waiting for a value to arrive.
+
+(provide make-blocking-box
+	 blocking-box-evt
+	 blocking-box-value
+	 set-blocking-box!)
+
+(struct blocking-box (semaphore ch))
+
+(define (make-blocking-box)
+  (blocking-box (make-semaphore 1) (make-channel)))
+
+(define (blocking-box-evt b)
+  ;; wrap the event to avoid exposing too much authority
+  (wrap-evt (blocking-box-ch b) values))
+
+(define (blocking-box-value b)
+  (sync (blocking-box-evt b)))
+
+(define (set-blocking-box! b v)
+  (define c (blocking-box-ch b))
+  (thread (lambda ()
+	    (when (semaphore-try-wait? (blocking-box-semaphore b))
+	      ;; We are first (and therefore only) claimant of the box.
+	      (let loop ()
+		(channel-put c v)
+		(loop)))))
+  (void))

conversation.rkt

@@ -5,15 +5,11 @@
 (require racket/class)
 
 (require "functional-queue.rkt")
+(require "blocking-box.rkt")
 
 (provide make-room
 	 join-room
 
-	 make-blocking-box
-	 blocking-box-evt
-	 blocking-box-value
-	 set-blocking-box!
-
 	 ;; Management and communication
 	 (struct-out arrived)
 	 (struct-out departed)
@@ -30,7 +26,6 @@
 (struct credit (who amount) #:prefab) ;; give someone an amount of credit
 
 (struct room (ch))
-(struct blocking-box (ch))
 
 (struct room-state (name ch members) #:transparent)
 (struct binding (name in-ch out-ch disconnect-box queue-box thread) #:transparent)
@@ -43,27 +38,6 @@
 (define (join-room room [name (gensym 'peer)])
   (make-object membership% (room-ch room) name))
 
-(define (make-blocking-box)
-  (blocking-box (make-channel)))
-
-(define (blocking-box-evt b)
-  ;; wrap the event to avoid exposing too much authority
-  (wrap-evt (blocking-box-ch b) values))
-
-(define (blocking-box-value b)
-  (sync (blocking-box-evt b)))
-
-(define (set-blocking-box! b v)
-  (define c (blocking-box-ch b))
-  (thread (lambda ()
-	    (let loop ()
-	      ;; Either we get to successfully write, or someone's racing with us
-	      (sync (handle-evt (channel-put-evt c v)
-				(lambda (dummy)
-				  (loop)))
-		    c))))
-  (void))
-
 (define membership%
   (class* object% ()
     (init room-init)