fix concurrency tests for removal of reply word
chris.double
parent
e331379a5f
commit
a5644bb083
|
|
@ -1,195 +0,0 @@
|
||||||
! Copyright (C) 2005 Chris Double. All Rights Reserved.
|
|
||||||
!
|
|
||||||
! Redistribution and use in source and binary forms, with or without
|
|
||||||
! modification, are permitted provided that the following conditions are met:
|
|
||||||
!
|
|
||||||
! 1. Redistributions of source code must retain the above copyright notice,
|
|
||||||
! this list of conditions and the following disclaimer.
|
|
||||||
!
|
|
||||||
! 2. Redistributions in binary form must reproduce the above copyright notice,
|
|
||||||
! this list of conditions and the following disclaimer in the documentation
|
|
||||||
! and/or other materials provided with the distribution.
|
|
||||||
!
|
|
||||||
! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
|
|
||||||
! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
|
|
||||||
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
|
|
||||||
! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
|
|
||||||
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
|
|
||||||
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
|
|
||||||
! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
|
|
||||||
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
|
|
||||||
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
|
|
||||||
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
|
||||||
!
|
|
||||||
! Examples of using the concurrency library.
|
|
||||||
IN: concurrency-examples
|
|
||||||
USING: concurrency dlists errors gadgets gadgets-labels
|
|
||||||
gadgets-panes gadgets-theme io kernel math namespaces opengl
|
|
||||||
prettyprint sequences threads ;
|
|
||||||
|
|
||||||
: (logger) ( mailbox -- )
|
|
||||||
#! Using the given mailbox, start a thread which
|
|
||||||
#! logs messages put into the box.
|
|
||||||
dup mailbox-get print (logger) ;
|
|
||||||
|
|
||||||
: logger ( -- mailbox )
|
|
||||||
#! Start a logging thread, which will log messages to the
|
|
||||||
#! console that are put in the returned mailbox.
|
|
||||||
make-mailbox dup [ (logger) ] curry in-thread ;
|
|
||||||
|
|
||||||
: (pong-server0) ( -- )
|
|
||||||
receive second "ping" = [
|
|
||||||
"pong" swap send (pong-server0)
|
|
||||||
] [
|
|
||||||
"Pong server shutting down" swap send
|
|
||||||
] if ;
|
|
||||||
|
|
||||||
: pong-server0 ( -- process )
|
|
||||||
[ (pong-server0) ] spawn ;
|
|
||||||
|
|
||||||
TUPLE: ping-message from ;
|
|
||||||
TUPLE: shutdown-message from ;
|
|
||||||
|
|
||||||
GENERIC: handle-message
|
|
||||||
|
|
||||||
M: ping-message handle-message ( message -- bool )
|
|
||||||
ping-message-from "pong" swap send t ;
|
|
||||||
|
|
||||||
M: shutdown-message handle-message ( message -- bool )
|
|
||||||
shutdown-message-from "Pong server shutdown commenced" swap send f ;
|
|
||||||
|
|
||||||
: (pong-server1) ( -- )
|
|
||||||
"pong-server1 waiting for message..." print
|
|
||||||
receive handle-message [ (pong-server1) ] when ;
|
|
||||||
|
|
||||||
: pong-server1 ( -- process )
|
|
||||||
[
|
|
||||||
(pong-server1)
|
|
||||||
"pong-server1 exiting..." print
|
|
||||||
] spawn ;
|
|
||||||
|
|
||||||
TUPLE: echo-message from text ;
|
|
||||||
|
|
||||||
M: echo-message handle-message ( message -- bool )
|
|
||||||
dup echo-message-text swap echo-message-from send t ;
|
|
||||||
|
|
||||||
GENERIC: handle-message2
|
|
||||||
PREDICATE: tagged-message ping-message2 ( obj -- ? ) tagged-message-data "ping" = ;
|
|
||||||
PREDICATE: tagged-message shutdown-message2 ( obj -- ? ) tagged-message-data "shutdown" = ;
|
|
||||||
|
|
||||||
M: ping-message2 handle-message2 ( message -- bool )
|
|
||||||
"pong" reply t ;
|
|
||||||
|
|
||||||
M: shutdown-message2 handle-message2 ( message -- bool )
|
|
||||||
"Pong server shutdown commenced" reply f ;
|
|
||||||
|
|
||||||
: (pong-server2) ( -- )
|
|
||||||
"pong-server2 waiting for message..." print
|
|
||||||
receive handle-message2 [ (pong-server2) ] when ;
|
|
||||||
|
|
||||||
: pong-server2 ( -- process )
|
|
||||||
[
|
|
||||||
(pong-server2)
|
|
||||||
"pong-server2 exiting..." print
|
|
||||||
] spawn ;
|
|
||||||
|
|
||||||
: pong-server3 ( -- process )
|
|
||||||
[ handle-message2 ] spawn-server ;
|
|
||||||
|
|
||||||
GENERIC: handle-rpc-message
|
|
||||||
GENERIC: run-rpc-command
|
|
||||||
|
|
||||||
TUPLE: rpc-command op args ;
|
|
||||||
PREDICATE: rpc-command add-command ( msg -- bool )
|
|
||||||
rpc-command-op "add" = ;
|
|
||||||
PREDICATE: rpc-command product-command ( msg -- bool )
|
|
||||||
rpc-command-op "product" = ;
|
|
||||||
PREDICATE: rpc-command shutdown-command ( msg -- bool )
|
|
||||||
rpc-command-op "shutdown" = ;
|
|
||||||
PREDICATE: rpc-command crash-command ( msg -- bool )
|
|
||||||
rpc-command-op "crash" = ;
|
|
||||||
|
|
||||||
M: tagged-message handle-rpc-message ( message -- bool )
|
|
||||||
dup tagged-message-data run-rpc-command -rot reply not ;
|
|
||||||
|
|
||||||
M: add-command run-rpc-command ( command -- shutdown? result )
|
|
||||||
rpc-command-args sum f ;
|
|
||||||
|
|
||||||
M: product-command run-rpc-command ( command -- shutdown? result )
|
|
||||||
rpc-command-args product f ;
|
|
||||||
|
|
||||||
M: shutdown-command run-rpc-command ( command -- shutdown? result )
|
|
||||||
drop t t ;
|
|
||||||
|
|
||||||
M: crash-command run-rpc-command ( command -- shutdown? result )
|
|
||||||
drop 1 0 / f ;
|
|
||||||
|
|
||||||
: fragile-rpc-server ( -- process )
|
|
||||||
[ handle-rpc-message ] spawn-server ;
|
|
||||||
|
|
||||||
: (robust-rpc-server) ( worker -- )
|
|
||||||
[
|
|
||||||
receive over send
|
|
||||||
]
|
|
||||||
catch
|
|
||||||
[
|
|
||||||
"Worker died, Starting a new worker" print
|
|
||||||
drop [ handle-rpc-message ] spawn-linked-server
|
|
||||||
] when
|
|
||||||
(robust-rpc-server) ;
|
|
||||||
|
|
||||||
: robust-rpc-server ( -- process )
|
|
||||||
[
|
|
||||||
[ handle-rpc-message ] spawn-linked-server
|
|
||||||
(robust-rpc-server)
|
|
||||||
] spawn ;
|
|
||||||
|
|
||||||
: test-add ( process -- )
|
|
||||||
[
|
|
||||||
"add" [ 1 2 3 ] <rpc-command> swap send-synchronous .
|
|
||||||
] curry spawn drop ;
|
|
||||||
|
|
||||||
: test-crash ( process -- )
|
|
||||||
[
|
|
||||||
"crash" f <rpc-command> swap send-synchronous .
|
|
||||||
] curry spawn drop ;
|
|
||||||
|
|
||||||
! ******************************
|
|
||||||
! Experimental code below
|
|
||||||
! ******************************
|
|
||||||
|
|
||||||
TUPLE: promised-label promise font color ;
|
|
||||||
|
|
||||||
C: promised-label ( promise -- promised-label )
|
|
||||||
dup delegate>gadget dup label-theme
|
|
||||||
[ set-promised-label-promise ] keep
|
|
||||||
[ [ dup promised-label-promise ?promise drop relayout ] curry spawn drop ] keep ;
|
|
||||||
|
|
||||||
: promised-label-text ( promised-label -- text )
|
|
||||||
promised-label-promise dup promise-fulfilled? [
|
|
||||||
?promise
|
|
||||||
] [
|
|
||||||
drop "Unfulfilled Promise"
|
|
||||||
] if ;
|
|
||||||
|
|
||||||
M: promised-label pref-dim* ( promised-label - dim )
|
|
||||||
label-size ;
|
|
||||||
|
|
||||||
M: promised-label draw-gadget* ( promised-label -- )
|
|
||||||
draw-label ;
|
|
||||||
|
|
||||||
M: promised-label label-text promised-label-text ;
|
|
||||||
|
|
||||||
M: promised-label label-color promised-label-color ;
|
|
||||||
|
|
||||||
M: promised-label label-font promised-label-font ;
|
|
||||||
|
|
||||||
M: promised-label set-label-color set-promised-label-color ;
|
|
||||||
|
|
||||||
M: promised-label set-label-font set-promised-label-font ;
|
|
||||||
|
|
||||||
: fib ( n -- n )
|
|
||||||
1 sleep dup 2 < [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] if ;
|
|
||||||
|
|
||||||
: test-promise-ui ( -- )
|
|
||||||
<promise> dup <promised-label> gadget. [ 15 fib unparse swap fulfill ] curry spawn drop ;
|
|
||||||
|
|
@ -1,8 +1,8 @@
|
||||||
! Copyright (C) 2005 Chris Double. All Rights Reserved.
|
! Copyright (C) 2005 Chris Double. All Rights Reserved.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
!
|
!
|
||||||
USING: kernel concurrency concurrency-examples threads vectors
|
USING: kernel concurrency threads vectors arrays sequences namespaces
|
||||||
sequences namespaces test errors dlists strings math words match ;
|
test errors dlists strings math words match ;
|
||||||
IN: temporary
|
IN: temporary
|
||||||
|
|
||||||
[ "junk" ] [
|
[ "junk" ] [
|
||||||
|
|
@ -94,10 +94,6 @@ IN: temporary
|
||||||
mailbox-get
|
mailbox-get
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ f ] [ 1 2 gensym <tagged-message> gensym tag-match? ] unit-test
|
|
||||||
[ f ] [ "junk" gensym tag-match? ] unit-test
|
|
||||||
[ t ] [ 1 2 gensym <tagged-message> dup tagged-message-tag tag-match? ] unit-test
|
|
||||||
|
|
||||||
[ "test" ] [
|
[ "test" ] [
|
||||||
[ self ] "test" with-process
|
[ self ] "test" with-process
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
@ -105,11 +101,9 @@ IN: temporary
|
||||||
|
|
||||||
[ "received" ] [
|
[ "received" ] [
|
||||||
[
|
[
|
||||||
receive dup tagged-message? [
|
receive {
|
||||||
"received" reply
|
{ { ?from ?tag _ } [ ?tag "received" 2array ?from send ] }
|
||||||
] [
|
} match-cond
|
||||||
drop f
|
|
||||||
] if
|
|
||||||
] spawn
|
] spawn
|
||||||
"sent" swap send-synchronous
|
"sent" swap send-synchronous
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
@ -123,19 +117,7 @@ IN: temporary
|
||||||
receive
|
receive
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ "pong" "Pong server shutdown commenced" ] [
|
|
||||||
pong-server3 "ping" over send-synchronous
|
|
||||||
swap "shutdown" swap send-synchronous
|
|
||||||
] unit-test
|
|
||||||
|
|
||||||
[ t 60 120 ] [
|
|
||||||
fragile-rpc-server
|
|
||||||
T{ rpc-command f "product" [ 4 5 6 ] } over send-synchronous >r
|
|
||||||
T{ rpc-command f "add" [ 10 20 30 ] } over send-synchronous >r
|
|
||||||
T{ rpc-command f "shutdown" [ ] } swap send-synchronous
|
|
||||||
r> r>
|
|
||||||
] unit-test
|
|
||||||
|
|
||||||
[ "crash" ] [
|
[ "crash" ] [
|
||||||
[
|
[
|
||||||
[
|
[
|
||||||
|
|
@ -159,18 +141,16 @@ IN: temporary
|
||||||
50 swap fulfill
|
50 swap fulfill
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
SYMBOL: ?value
|
MATCH-VARS: ?value ;
|
||||||
SYMBOL: ?from
|
|
||||||
SYMBOL: ?tag
|
|
||||||
SYMBOL: increment
|
SYMBOL: increment
|
||||||
SYMBOL: decrement
|
SYMBOL: decrement
|
||||||
SYMBOL: value
|
SYMBOL: value
|
||||||
|
|
||||||
: counter ( value -- )
|
: counter ( value -- )
|
||||||
receive {
|
receive {
|
||||||
{ { increment ?value } [ ?value get + counter ] }
|
{ { increment ?value } [ ?value + counter ] }
|
||||||
{ { decrement ?value } [ ?value get - counter ] }
|
{ { decrement ?value } [ ?value - counter ] }
|
||||||
{ { value ?from } [ dup ?from get send counter ] }
|
{ { value ?from } [ dup ?from send counter ] }
|
||||||
} match-cond ;
|
} match-cond ;
|
||||||
|
|
||||||
[ -5 ] [
|
[ -5 ] [
|
||||||
|
|
|
||||||
|
|
@ -7,6 +7,5 @@ PROVIDE: contrib/concurrency {
|
||||||
"concurrency.factor"
|
"concurrency.factor"
|
||||||
"concurrency.facts"
|
"concurrency.facts"
|
||||||
} {
|
} {
|
||||||
"concurrency-examples.factor"
|
|
||||||
"concurrency-tests.factor"
|
"concurrency-tests.factor"
|
||||||
} ;
|
} ;
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue