1 ! Copyright (C) 2005, 2010 Chris Double, Slava Pestov.
2 ! See https://factorcode.org/license.txt for BSD license.
3 USING: accessors concurrency.mailboxes kernel kernel.private
4 namespaces summary threads ;
5 IN: concurrency.messaging
7 GENERIC: send ( message thread -- )
9 GENERIC: mailbox-of ( thread -- mailbox )
13 [ { mailbox } declare ]
14 [ <mailbox> [ >>mailbox drop ] keep ] ?if-old ; inline
17 mailbox-of mailbox-put ;
19 : my-mailbox ( -- mailbox ) self mailbox-of ; inline
21 : receive ( -- message )
22 my-mailbox mailbox-get ?linked ;
24 : receive-timeout ( timeout -- message )
25 [ my-mailbox ] dip mailbox-get-timeout ?linked ;
27 : receive-if ( pred -- message )
28 [ my-mailbox ] dip mailbox-get? ?linked ; inline
30 : receive-if-timeout ( timeout pred -- message )
31 [ my-mailbox ] 2dip mailbox-get-timeout? ?linked ; inline
33 : rethrow-linked ( error process supervisor -- )
34 [ <linked-error> ] dip send ;
36 : spawn-linked ( quot name -- thread )
37 my-mailbox spawn-linked-to ;
39 TUPLE: synchronous data sender tag ;
41 : <synchronous> ( data -- sync )
42 self synchronous counter synchronous boa ;
44 TUPLE: reply data tag ;
46 : <reply> ( data synchronous -- reply )
49 : synchronous-reply? ( response synchronous -- ? )
50 over reply? [ [ tag>> ] same? ] [ 2drop f ] if ;
52 ERROR: cannot-send-synchronous-to-self message thread ;
54 M: cannot-send-synchronous-to-self summary
55 drop "Cannot synchronous send to myself" ;
57 : send-synchronous ( message thread -- reply )
59 cannot-send-synchronous-to-self
61 [ <synchronous> dup ] dip send
62 '[ _ synchronous-reply? ] receive-if
66 : reply-synchronous ( message synchronous -- )
67 [ <reply> ] keep sender>> send ;
69 : handle-synchronous ( quot: ( ... message -- ... reply ) -- )
72 ] keep reply-synchronous ; inline