! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-IN: concurrency.mailboxes\r
-USING: dlists dequeues threads sequences continuations\r
-destructors namespaces random math quotations words kernel\r
+USING: dlists deques threads sequences continuations\r
+destructors namespaces math quotations words kernel\r
arrays assocs init system concurrency.conditions accessors\r
-debugger ;\r
+debugger debugger.threads locals fry ;\r
+IN: concurrency.mailboxes\r
\r
TUPLE: mailbox threads data disposed ;\r
\r
<dlist> <dlist> f mailbox boa ;\r
\r
: mailbox-empty? ( mailbox -- bool )\r
- data>> dequeue-empty? ;\r
+ data>> deque-empty? ;\r
\r
: mailbox-put ( obj mailbox -- )\r
[ data>> push-front ]\r
[ threads>> notify-all ] bi yield ;\r
\r
: wait-for-mailbox ( mailbox timeout -- )\r
- >r threads>> r> "mailbox" wait ;\r
+ [ threads>> ] dip "mailbox" wait ;\r
\r
-: block-unless-pred ( mailbox timeout pred: ( message -- ? ) -- )\r
- pick check-disposed\r
- pick data>> over dlist-contains? [\r
- 3drop\r
- ] [\r
- >r 2dup wait-for-mailbox r> block-unless-pred\r
- ] if ; inline recursive\r
+:: block-unless-pred ( mailbox timeout pred: ( message -- ? ) -- )\r
+ mailbox check-disposed\r
+ mailbox data>> pred dlist-any? [\r
+ mailbox timeout wait-for-mailbox\r
+ mailbox timeout pred block-unless-pred\r
+ ] unless ; inline recursive\r
\r
: block-if-empty ( mailbox timeout -- mailbox )\r
over check-disposed\r
\r
: mailbox-get-all-timeout ( mailbox timeout -- array )\r
block-if-empty\r
- [ dup mailbox-empty? ]\r
+ [ dup mailbox-empty? not ]\r
[ dup data>> pop-back ]\r
- [ ] produce nip ;\r
+ produce nip ;\r
\r
: mailbox-get-all ( mailbox -- array )\r
f mailbox-get-all-timeout ;\r
\r
: while-mailbox-empty ( mailbox quot -- )\r
- [ [ mailbox-empty? ] curry ] dip [ ] while ; inline\r
+ [ '[ _ mailbox-empty? ] ] dip while ; inline\r
\r
: mailbox-get-timeout? ( mailbox timeout pred -- obj )\r
- 3dup block-unless-pred\r
- nip >r data>> r> delete-node-if ; inline\r
+ [ block-unless-pred ]\r
+ [ [ drop data>> ] dip delete-node-if ]\r
+ 3bi ; inline\r
\r
: mailbox-get? ( mailbox pred -- obj )\r
f swap mailbox-get-timeout? ; inline\r
[ <linked-error> ] [ supervisor>> ] bi mailbox-put ;\r
\r
: <linked-thread> ( quot name mailbox -- thread' )\r
- >r linked-thread new-thread r> >>supervisor ;\r
+ [ linked-thread new-thread ] dip >>supervisor ;\r
\r
: spawn-linked-to ( quot name mailbox -- thread )\r
<linked-thread> [ (spawn) ] keep ;\r