sync tested.
This commit is contained in:
@@ -7,15 +7,8 @@
|
||||
(provide uni-channel?
|
||||
uni-channel-kind
|
||||
uni-channel-direction
|
||||
uni-channel-name
|
||||
uni-channel-impl
|
||||
|
||||
make-uni-channel
|
||||
make-uni-async-channel
|
||||
make-uni-async-channel-pair
|
||||
make-uni-place-channel
|
||||
make-uni-place-channel-pair
|
||||
make-uni-port-channel
|
||||
|
||||
uni-channel-put
|
||||
uni-channel-get
|
||||
@@ -32,50 +25,31 @@
|
||||
uni-channel-error-evt)
|
||||
|
||||
(struct uni-channel
|
||||
(kind impl direction name get-proc put-proc try-get-proc get-evt-proc put-evt-proc
|
||||
(kind impl direction get-proc put-proc try-get-proc get-evt-proc put-evt-proc
|
||||
close-proc closed-box error-get-proc error-try-get-proc error-evt-proc)
|
||||
#:property prop:evt
|
||||
(lambda (ch)
|
||||
(cond
|
||||
[(and (can-get? ch) (uni-channel-get-proc ch))
|
||||
((uni-channel-get-evt-proc ch) ch)]
|
||||
[else never-evt])))
|
||||
(if (can-get? ch) ((uni-channel-get-evt-proc ch) ch) never-evt)))
|
||||
|
||||
(define (check-direction who v)
|
||||
(case v
|
||||
[(input output bidirectional) v]
|
||||
[else (raise-argument-error who "(or/c 'input 'output 'bidirectional)" v)]))
|
||||
|
||||
(define (check-kind who v)
|
||||
(case v
|
||||
[(async place port custom) v]
|
||||
[else (raise-argument-error who "(or/c 'async 'place 'port 'custom)" v)]))
|
||||
|
||||
(define (can-get? ch)
|
||||
(not (eq? (uni-channel-direction ch) 'output)))
|
||||
|
||||
(define (can-put? ch)
|
||||
(not (eq? (uni-channel-direction ch) 'input)))
|
||||
(define (can-get? ch) (not (eq? (uni-channel-direction ch) 'output)))
|
||||
(define (can-put? ch) (not (eq? (uni-channel-direction ch) 'input)))
|
||||
|
||||
(define (raise-no-get who ch)
|
||||
(raise-arguments-error who "uni-channel does not support receiving"
|
||||
"name" (uni-channel-name ch)
|
||||
"kind" (uni-channel-kind ch)
|
||||
"direction" (uni-channel-direction ch)))
|
||||
|
||||
(define (raise-no-put who ch)
|
||||
(raise-arguments-error who "uni-channel does not support sending"
|
||||
"name" (uni-channel-name ch)
|
||||
"kind" (uni-channel-kind ch)
|
||||
"direction" (uni-channel-direction ch)))
|
||||
|
||||
(define (raise-closed who ch)
|
||||
(raise-arguments-error who "uni-channel is closed"
|
||||
"name" (uni-channel-name ch)
|
||||
"kind" (uni-channel-kind ch)))
|
||||
"kind" (uni-channel-kind ch)
|
||||
"direction" (uni-channel-direction ch)))
|
||||
|
||||
(define (closed-box) (box #f))
|
||||
|
||||
(define (mark-closed! ch)
|
||||
(set-box! (uni-channel-closed-box ch) #t))
|
||||
(define (mark-closed! ch) (set-box! (uni-channel-closed-box ch) #t))
|
||||
|
||||
(define (default-close ch)
|
||||
(mark-closed! ch)
|
||||
@@ -83,16 +57,14 @@
|
||||
|
||||
(define (no-error-get ch)
|
||||
(raise-arguments-error 'uni-channel-error-get "uni-channel has no error channel"
|
||||
"name" (uni-channel-name ch)
|
||||
"kind" (uni-channel-kind ch)))
|
||||
|
||||
(define (no-error-try-get ch) #f)
|
||||
(define (no-error-evt ch) never-evt)
|
||||
|
||||
(define (make-oc #:kind kind
|
||||
#:backend backend
|
||||
(define (make-uc #:kind kind
|
||||
#:impl impl
|
||||
#:direction direction
|
||||
#:name name
|
||||
#:get get-proc
|
||||
#:put put-proc
|
||||
#:try-get try-get-proc
|
||||
@@ -102,234 +74,94 @@
|
||||
#:error-get error-get-proc
|
||||
#:error-try-get error-try-get-proc
|
||||
#:error-evt error-evt-proc)
|
||||
(uni-channel kind backend direction name get-proc put-proc try-get-proc get-evt-proc put-evt-proc
|
||||
close-proc (closed-box) error-get-proc error-try-get-proc error-evt-proc))
|
||||
(uni-channel kind impl direction get-proc put-proc try-get-proc get-evt-proc put-evt-proc
|
||||
close-proc (box #f) error-get-proc error-try-get-proc error-evt-proc))
|
||||
|
||||
(define (make-uni-channel backend
|
||||
#:kind [kind 'auto]
|
||||
#:direction [direction 'auto]
|
||||
#:name [name #f])
|
||||
(define detected-kind
|
||||
(case kind
|
||||
[(auto)
|
||||
(cond
|
||||
[(async-channel? backend) 'async]
|
||||
[(place-channel? backend) 'place]
|
||||
[(port-channel? backend) 'port]
|
||||
[else (raise-argument-error 'make-uni-channel
|
||||
"(or/c async-channel? place-channel? port-channel?)"
|
||||
backend)])]
|
||||
[else (check-kind 'make-uni-channel kind)]))
|
||||
(case detected-kind
|
||||
[(async)
|
||||
(unless (async-channel? backend)
|
||||
(raise-argument-error 'make-uni-channel "async-channel?" backend))
|
||||
(make-uni-async-channel backend #:direction direction #:name (or name 'async-channel))]
|
||||
[(place)
|
||||
(unless (place-channel? backend)
|
||||
(raise-argument-error 'make-uni-channel "place-channel?" backend))
|
||||
(make-uni-place-channel backend #:direction direction #:name (or name 'place-channel))]
|
||||
[(port)
|
||||
(unless (port-channel? backend)
|
||||
(raise-argument-error 'make-uni-channel "port-channel?" backend))
|
||||
(define pc-dir (port-channel-direction backend))
|
||||
(define dir (if (eq? direction 'auto) pc-dir (check-direction 'make-uni-channel direction)))
|
||||
(unless (eq? pc-dir dir)
|
||||
(raise-arguments-error 'make-uni-channel "direction does not match port-channel direction"
|
||||
"requested direction" dir
|
||||
"port-channel direction" pc-dir))
|
||||
(make-port-oc (and (eq? pc-dir 'input) backend)
|
||||
(and (eq? pc-dir 'output) backend)
|
||||
#:direction pc-dir
|
||||
#:name (or name 'port-channel))]
|
||||
[else
|
||||
(raise-argument-error 'make-uni-channel "(or/c 'auto 'async 'place 'port)" kind)]))
|
||||
(define (make-uni-channel channel)
|
||||
(cond
|
||||
[(async-channel? channel) (make-async-uc channel)]
|
||||
[(place-channel? channel) (make-place-uc channel)]
|
||||
[(port-channel? channel) (make-port-uc channel)]
|
||||
[else (raise-argument-error 'make-uni-channel
|
||||
"(or/c async-channel? place-channel? port-channel?)"
|
||||
channel)]))
|
||||
|
||||
(define (make-uni-async-channel [ch (make-async-channel)]
|
||||
#:direction [direction 'bidirectional]
|
||||
#:name [name 'async-channel])
|
||||
(define dir (if (eq? direction 'auto) 'bidirectional (check-direction 'make-uni-async-channel direction)))
|
||||
(define backend ch)
|
||||
(make-oc #:kind 'async
|
||||
#:backend backend
|
||||
#:direction dir
|
||||
#:name name
|
||||
#:get (lambda (_ch) (async-channel-get backend))
|
||||
#:put (lambda (_ch v) (async-channel-put backend v))
|
||||
#:try-get (lambda (_ch) (async-channel-try-get backend))
|
||||
#:get-evt (lambda (_ch) backend)
|
||||
#:put-evt (lambda (_ch v) (async-channel-put-evt backend v))
|
||||
(define (make-async-uc ch)
|
||||
(make-uc #:kind 'async
|
||||
#:impl ch
|
||||
#:direction 'bidirectional
|
||||
#:get (lambda (_ch) (async-channel-get ch))
|
||||
#:put (lambda (_ch v) (async-channel-put ch v))
|
||||
#:try-get (lambda (_ch) (async-channel-try-get ch))
|
||||
#:get-evt (lambda (_ch) ch)
|
||||
#:put-evt (lambda (_ch v) (async-channel-put-evt ch v))
|
||||
#:close default-close
|
||||
#:error-get no-error-get
|
||||
#:error-try-get no-error-try-get
|
||||
#:error-evt no-error-evt))
|
||||
|
||||
(define (make-uni-async-channel-pair #:name-a [name-a 'async-channel-a]
|
||||
#:name-b [name-b 'async-channel-b])
|
||||
(define a-in (make-async-channel))
|
||||
(define b-in (make-async-channel))
|
||||
(define (endpoint name incoming outgoing)
|
||||
(make-oc #:kind 'async
|
||||
#:backend (vector 'async-channel-pair incoming outgoing)
|
||||
#:direction 'bidirectional
|
||||
#:name name
|
||||
#:get (lambda (_ch) (async-channel-get incoming))
|
||||
#:put (lambda (_ch v) (async-channel-put outgoing v))
|
||||
#:try-get (lambda (_ch) (async-channel-try-get incoming))
|
||||
#:get-evt (lambda (_ch) incoming)
|
||||
#:put-evt (lambda (_ch v) (async-channel-put-evt outgoing v))
|
||||
#:close default-close
|
||||
#:error-get no-error-get
|
||||
#:error-try-get no-error-try-get
|
||||
#:error-evt no-error-evt))
|
||||
(values (endpoint name-a a-in b-in) (endpoint name-b b-in a-in)))
|
||||
|
||||
(define (make-uni-place-channel ch
|
||||
#:direction [direction 'bidirectional]
|
||||
#:name [name 'place-channel])
|
||||
(define dir (if (eq? direction 'auto) 'bidirectional (check-direction 'make-uni-place-channel direction)))
|
||||
(define backend ch)
|
||||
(make-oc #:kind 'place
|
||||
#:backend backend
|
||||
#:direction dir
|
||||
#:name name
|
||||
#:get (lambda (_ch) (place-channel-get backend))
|
||||
#:put (lambda (_ch v) (place-channel-put backend v))
|
||||
#:try-get (lambda (_ch) (sync/timeout 0 backend))
|
||||
#:get-evt (lambda (_ch) backend)
|
||||
#:put-evt (lambda (_ch v) (handle-evt always-evt (lambda (_) (place-channel-put backend v))))
|
||||
(define (make-place-uc ch)
|
||||
(make-uc #:kind 'place
|
||||
#:impl ch
|
||||
#:direction 'bidirectional
|
||||
#:get (lambda (_ch) (place-channel-get ch))
|
||||
#:put (lambda (_ch v) (place-channel-put ch v))
|
||||
#:try-get (lambda (_ch) (sync/timeout 0 ch))
|
||||
#:get-evt (lambda (_ch) ch)
|
||||
#:put-evt (lambda (_ch v) (handle-evt always-evt (lambda (_) (place-channel-put ch v))))
|
||||
#:close default-close
|
||||
#:error-get no-error-get
|
||||
#:error-try-get no-error-try-get
|
||||
#:error-evt no-error-evt))
|
||||
|
||||
(define (make-uni-place-channel-pair #:name-a [name-a 'place-channel-a]
|
||||
#:name-b [name-b 'place-channel-b])
|
||||
(define-values (a b) (place-channel))
|
||||
(values (make-uni-place-channel a #:name name-a)
|
||||
(make-uni-place-channel b #:name name-b)))
|
||||
|
||||
(define (make-port-oc in-pc out-pc #:direction direction #:name name)
|
||||
(define backend
|
||||
(cond
|
||||
[(and in-pc out-pc) (vector 'port-channel-pair in-pc out-pc)]
|
||||
[in-pc in-pc]
|
||||
[out-pc out-pc]
|
||||
[else (error 'make-port-oc "internal error: no port-channel backend")]))
|
||||
(define (get* _ch) (port-channel-get in-pc))
|
||||
(define (put* _ch v) (port-channel-put out-pc v))
|
||||
(define (try-get* _ch) (port-channel-try-get in-pc))
|
||||
(define (get-evt* _ch) (port-channel-evt in-pc))
|
||||
(define (put-evt* _ch v) (handle-evt always-evt (lambda (_) (port-channel-put out-pc v))))
|
||||
(define (close* ch)
|
||||
(mark-closed! ch)
|
||||
(cond
|
||||
[(and in-pc out-pc) (close-port-channel out-pc)]
|
||||
[in-pc (close-port-channel in-pc)]
|
||||
[out-pc (close-port-channel out-pc)])
|
||||
(void))
|
||||
(define (error-get* _ch)
|
||||
(cond
|
||||
[in-pc (port-channel-error-get in-pc)]
|
||||
[out-pc (port-channel-error-get out-pc)]))
|
||||
(define (error-try-get* _ch)
|
||||
(or (and in-pc (port-channel-error-try-get in-pc))
|
||||
(and out-pc (port-channel-error-try-get out-pc))))
|
||||
(define (error-evt* _ch)
|
||||
(cond
|
||||
[(and in-pc out-pc) (choice-evt (port-channel-error-evt in-pc) (port-channel-error-evt out-pc))]
|
||||
[in-pc (port-channel-error-evt in-pc)]
|
||||
[out-pc (port-channel-error-evt out-pc)]))
|
||||
(make-oc #:kind 'port
|
||||
#:backend backend
|
||||
#:direction direction
|
||||
#:name name
|
||||
#:get (and in-pc get*)
|
||||
#:put (and out-pc put*)
|
||||
#:try-get (and in-pc try-get*)
|
||||
#:get-evt (and in-pc get-evt*)
|
||||
#:put-evt (and out-pc put-evt*)
|
||||
#:close close*
|
||||
#:error-get error-get*
|
||||
#:error-try-get error-try-get*
|
||||
#:error-evt error-evt*))
|
||||
|
||||
(define (make-uni-port-channel #:input [in #f]
|
||||
#:output [out #f]
|
||||
#:source [source 'port-channel]
|
||||
#:close? [close? #t]
|
||||
#:name [name 'port-channel])
|
||||
(unless (or in out)
|
||||
(raise-arguments-error 'make-uni-port-channel
|
||||
"expected at least one of #:input or #:output"))
|
||||
(when (and in (not (input-port? in)))
|
||||
(raise-argument-error 'make-uni-port-channel "input-port?" in))
|
||||
(when (and out (not (output-port? out)))
|
||||
(raise-argument-error 'make-uni-port-channel "output-port?" out))
|
||||
(define in-pc (and in (make-port-channel in #:direction 'input #:source source #:close? close?)))
|
||||
(define out-pc (and out (make-port-channel out #:direction 'output #:source source #:close? close?)))
|
||||
(define direction
|
||||
(cond
|
||||
[(and in-pc out-pc) 'bidirectional]
|
||||
[in-pc 'input]
|
||||
[else 'output]))
|
||||
(make-port-oc in-pc out-pc #:direction direction #:name name))
|
||||
|
||||
(define (uni-channel-closed? ch)
|
||||
(unbox (uni-channel-closed-box ch)))
|
||||
(define (make-port-uc pc)
|
||||
(define dir (port-channel-direction pc))
|
||||
(make-uc #:kind 'port
|
||||
#:impl pc
|
||||
#:direction dir
|
||||
#:get (lambda (_ch) (port-channel-get pc))
|
||||
#:put (lambda (_ch v) (port-channel-put pc v))
|
||||
#:try-get (lambda (_ch) (port-channel-try-get pc))
|
||||
#:get-evt (lambda (_ch) (port-channel-evt pc))
|
||||
#:put-evt (lambda (_ch v) (handle-evt always-evt (lambda (_) (port-channel-put pc v))))
|
||||
#:close (lambda (ch) (mark-closed! ch) (close-port-channel pc))
|
||||
#:error-get (lambda (_ch) (port-channel-error-get pc))
|
||||
#:error-try-get (lambda (_ch) (port-channel-error-try-get pc))
|
||||
#:error-evt (lambda (_ch) (port-channel-error-evt pc))))
|
||||
|
||||
(define (uni-channel-put ch v)
|
||||
(unless (uni-channel? ch) (raise-argument-error 'uni-channel-put "uni-channel?" ch))
|
||||
(unless (can-put? ch) (raise-no-put 'uni-channel-put ch))
|
||||
(when (uni-channel-closed? ch) (raise-closed 'uni-channel-put ch))
|
||||
(define put-proc (uni-channel-put-proc ch))
|
||||
(unless put-proc (raise-no-put 'uni-channel-put ch))
|
||||
(put-proc ch v))
|
||||
(unless (can-put? ch) (raise-no-put 'uni-channel-put ch))
|
||||
((uni-channel-put-proc ch) ch v))
|
||||
|
||||
(define (uni-channel-get ch)
|
||||
(unless (uni-channel? ch) (raise-argument-error 'uni-channel-get "uni-channel?" ch))
|
||||
(when (uni-channel-closed? ch) (raise-closed 'uni-channel-get ch))
|
||||
(unless (can-get? ch) (raise-no-get 'uni-channel-get ch))
|
||||
(define get-proc (uni-channel-get-proc ch))
|
||||
(unless get-proc (raise-no-get 'uni-channel-get ch))
|
||||
(get-proc ch))
|
||||
((uni-channel-get-proc ch) ch))
|
||||
|
||||
(define uni-channel-send uni-channel-put)
|
||||
(define uni-channel-recv uni-channel-get)
|
||||
(define (uni-channel-send ch v) (uni-channel-put ch v))
|
||||
(define (uni-channel-recv ch) (uni-channel-get ch))
|
||||
|
||||
(define (uni-channel-try-get ch)
|
||||
(unless (uni-channel? ch) (raise-argument-error 'uni-channel-try-get "uni-channel?" ch))
|
||||
(when (uni-channel-closed? ch) (raise-closed 'uni-channel-try-get ch))
|
||||
(unless (can-get? ch) (raise-no-get 'uni-channel-try-get ch))
|
||||
(define try-get-proc (uni-channel-try-get-proc ch))
|
||||
(unless try-get-proc (raise-no-get 'uni-channel-try-get ch))
|
||||
(try-get-proc ch))
|
||||
((uni-channel-try-get-proc ch) ch))
|
||||
|
||||
(define (uni-channel-get-evt ch)
|
||||
(unless (uni-channel? ch) (raise-argument-error 'uni-channel-get-evt "uni-channel?" ch))
|
||||
(unless (can-get? ch) (raise-no-get 'uni-channel-get-evt ch))
|
||||
(define get-evt-proc (uni-channel-get-evt-proc ch))
|
||||
(unless get-evt-proc (raise-no-get 'uni-channel-get-evt ch))
|
||||
(get-evt-proc ch))
|
||||
(when (uni-channel-closed? ch) (raise-closed 'uni-channel-get-evt ch))
|
||||
(if (can-get? ch) ((uni-channel-get-evt-proc ch) ch) never-evt))
|
||||
|
||||
(define (uni-channel-put-evt ch v)
|
||||
(unless (uni-channel? ch) (raise-argument-error 'uni-channel-put-evt "uni-channel?" ch))
|
||||
(unless (can-put? ch) (raise-no-put 'uni-channel-put-evt ch))
|
||||
(when (uni-channel-closed? ch) (raise-closed 'uni-channel-put-evt ch))
|
||||
(define put-evt-proc (uni-channel-put-evt-proc ch))
|
||||
(unless put-evt-proc (raise-no-put 'uni-channel-put-evt ch))
|
||||
(put-evt-proc ch v))
|
||||
(unless (can-put? ch) (raise-no-put 'uni-channel-put-evt ch))
|
||||
((uni-channel-put-evt-proc ch) ch v))
|
||||
|
||||
(define (uni-channel-close ch)
|
||||
(unless (uni-channel? ch) (raise-argument-error 'uni-channel-close "uni-channel?" ch))
|
||||
((uni-channel-close-proc ch) ch))
|
||||
(unless (uni-channel-closed? ch) ((uni-channel-close-proc ch) ch))
|
||||
(void))
|
||||
|
||||
(define (uni-channel-error-get ch)
|
||||
(unless (uni-channel? ch) (raise-argument-error 'uni-channel-error-get "uni-channel?" ch))
|
||||
((uni-channel-error-get-proc ch) ch))
|
||||
(define (uni-channel-closed? ch) (unbox (uni-channel-closed-box ch)))
|
||||
|
||||
(define (uni-channel-error-try-get ch)
|
||||
(unless (uni-channel? ch) (raise-argument-error 'uni-channel-error-try-get "uni-channel?" ch))
|
||||
((uni-channel-error-try-get-proc ch) ch))
|
||||
|
||||
(define (uni-channel-error-evt ch)
|
||||
(unless (uni-channel? ch) (raise-argument-error 'uni-channel-error-evt "uni-channel?" ch))
|
||||
((uni-channel-error-evt-proc ch) ch))
|
||||
(define (uni-channel-error-get ch) ((uni-channel-error-get-proc ch) ch))
|
||||
(define (uni-channel-error-try-get ch) ((uni-channel-error-try-get-proc ch) ch))
|
||||
(define (uni-channel-error-evt ch) ((uni-channel-error-evt-proc ch) ch))
|
||||
|
||||
Reference in New Issue
Block a user