! 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 deques threads sequences continuations\r
destructors namespaces math quotations words kernel\r
arrays assocs init system concurrency.conditions accessors\r
-debugger debugger.threads locals ;\r
+debugger debugger.threads locals fry ;\r
+IN: concurrency.mailboxes\r
\r
TUPLE: mailbox threads data disposed ;\r
\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
mailbox check-disposed\r
- mailbox data>> pred dlist-contains? [\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
: 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
[ block-unless-pred ]\r
- [ nip >r data>> r> delete-node-if ]\r
+ [ [ drop data>> ] dip delete-node-if ]\r
3bi ; inline\r
\r
: mailbox-get? ( mailbox pred -- obj )\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