Split out blocking-box
This commit is contained in:
parent
0e14f7864e
commit
4b10f3ade1
|
@ -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))
|
|
@ -5,15 +5,11 @@
|
||||||
(require racket/class)
|
(require racket/class)
|
||||||
|
|
||||||
(require "functional-queue.rkt")
|
(require "functional-queue.rkt")
|
||||||
|
(require "blocking-box.rkt")
|
||||||
|
|
||||||
(provide make-room
|
(provide make-room
|
||||||
join-room
|
join-room
|
||||||
|
|
||||||
make-blocking-box
|
|
||||||
blocking-box-evt
|
|
||||||
blocking-box-value
|
|
||||||
set-blocking-box!
|
|
||||||
|
|
||||||
;; Management and communication
|
;; Management and communication
|
||||||
(struct-out arrived)
|
(struct-out arrived)
|
||||||
(struct-out departed)
|
(struct-out departed)
|
||||||
|
@ -30,7 +26,6 @@
|
||||||
(struct credit (who amount) #:prefab) ;; give someone an amount of credit
|
(struct credit (who amount) #:prefab) ;; give someone an amount of credit
|
||||||
|
|
||||||
(struct room (ch))
|
(struct room (ch))
|
||||||
(struct blocking-box (ch))
|
|
||||||
|
|
||||||
(struct room-state (name ch members) #:transparent)
|
(struct room-state (name ch members) #:transparent)
|
||||||
(struct binding (name in-ch out-ch disconnect-box queue-box thread) #: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)])
|
(define (join-room room [name (gensym 'peer)])
|
||||||
(make-object membership% (room-ch room) name))
|
(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%
|
(define membership%
|
||||||
(class* object% ()
|
(class* object% ()
|
||||||
(init room-init)
|
(init room-init)
|
||||||
|
|
Loading…
Reference in New Issue