-! Copyright (C) 2005, 2010 Chris Double, Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel kernel.private threads concurrency.mailboxes\r
-continuations namespaces assocs accessors summary fry ;\r
-IN: concurrency.messaging\r
-\r
-GENERIC: send ( message thread -- )\r
-\r
-GENERIC: mailbox-of ( thread -- mailbox )\r
-\r
-M: thread mailbox-of\r
- dup mailbox>>\r
- [ { mailbox } declare ]\r
- [ <mailbox> [ >>mailbox drop ] keep ] ?if ; inline\r
-\r
-M: thread send ( message thread -- )\r
- mailbox-of mailbox-put ;\r
-\r
-: my-mailbox ( -- mailbox ) self mailbox-of ; inline\r
-\r
-: receive ( -- message )\r
- my-mailbox mailbox-get ?linked ;\r
-\r
-: receive-timeout ( timeout -- message )\r
- [ my-mailbox ] dip mailbox-get-timeout ?linked ;\r
-\r
-: receive-if ( pred -- message )\r
- [ my-mailbox ] dip mailbox-get? ?linked ; inline\r
-\r
-: receive-if-timeout ( timeout pred -- message )\r
- [ my-mailbox ] 2dip mailbox-get-timeout? ?linked ; inline\r
-\r
-: rethrow-linked ( error process supervisor -- )\r
- [ <linked-error> ] dip send ;\r
-\r
-: spawn-linked ( quot name -- thread )\r
- my-mailbox spawn-linked-to ;\r
-\r
-TUPLE: synchronous data sender tag ;\r
-\r
-: <synchronous> ( data -- sync )\r
- self synchronous counter synchronous boa ;\r
-\r
-TUPLE: reply data tag ;\r
-\r
-: <reply> ( data synchronous -- reply )\r
- tag>> \ reply boa ;\r
-\r
-: synchronous-reply? ( response synchronous -- ? )\r
- over reply? [ [ tag>> ] same? ] [ 2drop f ] if ;\r
-\r
-ERROR: cannot-send-synchronous-to-self message thread ;\r
-\r
-M: cannot-send-synchronous-to-self summary\r
- drop "Cannot synchronous send to myself" ;\r
-\r
-: send-synchronous ( message thread -- reply )\r
- dup self eq? [\r
- cannot-send-synchronous-to-self\r
- ] [\r
- [ <synchronous> dup ] dip send\r
- '[ _ synchronous-reply? ] receive-if\r
- data>>\r
- ] if ;\r
-\r
-: reply-synchronous ( message synchronous -- )\r
- [ <reply> ] keep sender>> send ;\r
-\r
-: handle-synchronous ( quot -- )\r
- receive [\r
- data>> swap call\r
- ] keep reply-synchronous ; inline\r
+! Copyright (C) 2005, 2010 Chris Double, Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel kernel.private threads concurrency.mailboxes
+continuations namespaces assocs accessors summary fry ;
+IN: concurrency.messaging
+
+GENERIC: send ( message thread -- )
+
+GENERIC: mailbox-of ( thread -- mailbox )
+
+M: thread mailbox-of
+ dup mailbox>>
+ [ { mailbox } declare ]
+ [ <mailbox> [ >>mailbox drop ] keep ] ?if ; inline
+
+M: thread send ( message thread -- )
+ mailbox-of mailbox-put ;
+
+: my-mailbox ( -- mailbox ) self mailbox-of ; inline
+
+: receive ( -- message )
+ my-mailbox mailbox-get ?linked ;
+
+: receive-timeout ( timeout -- message )
+ [ my-mailbox ] dip mailbox-get-timeout ?linked ;
+
+: receive-if ( pred -- message )
+ [ my-mailbox ] dip mailbox-get? ?linked ; inline
+
+: receive-if-timeout ( timeout pred -- message )
+ [ my-mailbox ] 2dip mailbox-get-timeout? ?linked ; inline
+
+: rethrow-linked ( error process supervisor -- )
+ [ <linked-error> ] dip send ;
+
+: spawn-linked ( quot name -- thread )
+ my-mailbox spawn-linked-to ;
+
+TUPLE: synchronous data sender tag ;
+
+: <synchronous> ( data -- sync )
+ self synchronous counter synchronous boa ;
+
+TUPLE: reply data tag ;
+
+: <reply> ( data synchronous -- reply )
+ tag>> \ reply boa ;
+
+: synchronous-reply? ( response synchronous -- ? )
+ over reply? [ [ tag>> ] same? ] [ 2drop f ] if ;
+
+ERROR: cannot-send-synchronous-to-self message thread ;
+
+M: cannot-send-synchronous-to-self summary
+ drop "Cannot synchronous send to myself" ;
+
+: send-synchronous ( message thread -- reply )
+ dup self eq? [
+ cannot-send-synchronous-to-self
+ ] [
+ [ <synchronous> dup ] dip send
+ '[ _ synchronous-reply? ] receive-if
+ data>>
+ ] if ;
+
+: reply-synchronous ( message synchronous -- )
+ [ <reply> ] keep sender>> send ;
+
+: handle-synchronous ( quot -- )
+ receive [
+ data>> swap call
+ ] keep reply-synchronous ; inline