added send-synchronous-timeout word and tests
parent
d9377625c5
commit
3351391e50
|
@ -3,7 +3,7 @@
|
||||||
USING: kernel threads vectors arrays sequences namespaces make
|
USING: kernel threads vectors arrays sequences namespaces make
|
||||||
tools.test continuations deques strings math words match
|
tools.test continuations deques strings math words match
|
||||||
quotations concurrency.messaging concurrency.mailboxes
|
quotations concurrency.messaging concurrency.mailboxes
|
||||||
concurrency.count-downs accessors ;
|
concurrency.count-downs concurrency.conditions accessors calendar ;
|
||||||
IN: concurrency.messaging.tests
|
IN: concurrency.messaging.tests
|
||||||
|
|
||||||
[ ] [ my-mailbox data>> clear-deque ] unit-test
|
[ ] [ my-mailbox data>> clear-deque ] unit-test
|
||||||
|
@ -15,6 +15,19 @@ IN: concurrency.messaging.tests
|
||||||
"sent" swap send-synchronous
|
"sent" swap send-synchronous
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
[ "received" ] [
|
||||||
|
[
|
||||||
|
receive "received" swap reply-synchronous
|
||||||
|
] "Synchronous test" spawn
|
||||||
|
[ 100 milliseconds "sent" ] dip send-synchronous-timeout
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ [ 100 milliseconds sleep
|
||||||
|
receive "received" swap reply-synchronous ] "Synchronous test" spawn
|
||||||
|
[ 50 milliseconds "sent" ] dip send-synchronous-timeout
|
||||||
|
] [ wait-timeout? ] must-fail-with
|
||||||
|
|
||||||
|
|
||||||
[ 1 3 2 ] [
|
[ 1 3 2 ] [
|
||||||
1 self send
|
1 self send
|
||||||
2 self send
|
2 self send
|
||||||
|
|
|
@ -61,6 +61,15 @@ M: cannot-send-synchronous-to-self summary
|
||||||
data>>
|
data>>
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
|
: send-synchronous-timeout ( timeout message thread -- reply )
|
||||||
|
dup self eq? [
|
||||||
|
cannot-send-synchronous-to-self
|
||||||
|
] [
|
||||||
|
[ <synchronous> dup ] dip send
|
||||||
|
'[ _ synchronous-reply? ] receive-if-timeout
|
||||||
|
data>>
|
||||||
|
] if ;
|
||||||
|
|
||||||
: reply-synchronous ( message synchronous -- )
|
: reply-synchronous ( message synchronous -- )
|
||||||
[ <reply> ] keep sender>> send ;
|
[ <reply> ] keep sender>> send ;
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue