diff --git a/contrib/concurrency/concurrency-examples.factor b/contrib/concurrency/concurrency-examples.factor deleted file mode 100644 index cdffba9cc7..0000000000 --- a/contrib/concurrency/concurrency-examples.factor +++ /dev/null @@ -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 ] swap send-synchronous . - ] curry spawn drop ; - -: test-crash ( process -- ) - [ - "crash" f 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 ( -- ) - dup gadget. [ 15 fib unparse swap fulfill ] curry spawn drop ; diff --git a/contrib/concurrency/concurrency-tests.factor b/contrib/concurrency/concurrency-tests.factor index 487e3a6eb2..a76d49eb48 100644 --- a/contrib/concurrency/concurrency-tests.factor +++ b/contrib/concurrency/concurrency-tests.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2005 Chris Double. All Rights Reserved. ! See http://factorcode.org/license.txt for BSD license. ! -USING: kernel concurrency concurrency-examples threads vectors - sequences namespaces test errors dlists strings math words match ; +USING: kernel concurrency threads vectors arrays sequences namespaces +test errors dlists strings math words match ; IN: temporary [ "junk" ] [ @@ -94,10 +94,6 @@ IN: temporary mailbox-get ] unit-test -[ f ] [ 1 2 gensym gensym tag-match? ] unit-test -[ f ] [ "junk" gensym tag-match? ] unit-test -[ t ] [ 1 2 gensym dup tagged-message-tag tag-match? ] unit-test - [ "test" ] [ [ self ] "test" with-process ] unit-test @@ -105,11 +101,9 @@ IN: temporary [ "received" ] [ [ - receive dup tagged-message? [ - "received" reply - ] [ - drop f - ] if + receive { + { { ?from ?tag _ } [ ?tag "received" 2array ?from send ] } + } match-cond ] spawn "sent" swap send-synchronous ] unit-test @@ -123,19 +117,7 @@ IN: temporary receive ] 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" ] [ [ [ @@ -159,18 +141,16 @@ IN: temporary 50 swap fulfill ] unit-test -SYMBOL: ?value -SYMBOL: ?from -SYMBOL: ?tag +MATCH-VARS: ?value ; SYMBOL: increment SYMBOL: decrement SYMBOL: value : counter ( value -- ) receive { - { { increment ?value } [ ?value get + counter ] } - { { decrement ?value } [ ?value get - counter ] } - { { value ?from } [ dup ?from get send counter ] } + { { increment ?value } [ ?value + counter ] } + { { decrement ?value } [ ?value - counter ] } + { { value ?from } [ dup ?from send counter ] } } match-cond ; [ -5 ] [ diff --git a/contrib/concurrency/load.factor b/contrib/concurrency/load.factor index 7925596177..a552c25d1c 100644 --- a/contrib/concurrency/load.factor +++ b/contrib/concurrency/load.factor @@ -7,6 +7,5 @@ PROVIDE: contrib/concurrency { "concurrency.factor" "concurrency.facts" } { - "concurrency-examples.factor" "concurrency-tests.factor" } ;