Fixes for linked error change
parent
ed4506c0b0
commit
cfa7c3771c
|
@ -11,7 +11,7 @@ concurrency.mailboxes threads sequences ;
|
||||||
[ { 1 4 9 } ] [ { 1 2 3 } [ 1000 random sleep sq ] parallel-map ] unit-test
|
[ { 1 4 9 } ] [ { 1 2 3 } [ 1000 random sleep sq ] parallel-map ] unit-test
|
||||||
|
|
||||||
[ { 1 2 3 } [ dup 2 mod 0 = [ "Even" throw ] when ] parallel-map ]
|
[ { 1 2 3 } [ dup 2 mod 0 = [ "Even" throw ] when ] parallel-map ]
|
||||||
[ linked-error "Even" = ] must-fail-with
|
[ delegate "Even" = ] must-fail-with
|
||||||
|
|
||||||
[ V{ 0 3 6 9 } ]
|
[ V{ 0 3 6 9 } ]
|
||||||
[ 10 [ 3 mod zero? ] parallel-subset ] unit-test
|
[ 10 [ 3 mod zero? ] parallel-subset ] unit-test
|
||||||
|
|
|
@ -174,5 +174,5 @@ threads sequences calendar ;
|
||||||
] ;
|
] ;
|
||||||
|
|
||||||
[ lock-timeout-test ] [
|
[ lock-timeout-test ] [
|
||||||
linked-thread thread-name "Lock timeout-er" =
|
linked-error-thread thread-name "Lock timeout-er" =
|
||||||
] must-fail-with
|
] must-fail-with
|
||||||
|
|
|
@ -65,12 +65,23 @@ TUPLE: mailbox threads data ;
|
||||||
: mailbox-get? ( pred mailbox -- obj )
|
: mailbox-get? ( pred mailbox -- obj )
|
||||||
f mailbox-get-timeout? ; inline
|
f mailbox-get-timeout? ; inline
|
||||||
|
|
||||||
TUPLE: linked error thread ;
|
TUPLE: linked-error thread ;
|
||||||
|
|
||||||
C: <linked> linked
|
: <linked-error> ( error thread -- linked )
|
||||||
|
{ set-delegate set-linked-error-thread }
|
||||||
|
linked-error construct ;
|
||||||
|
|
||||||
: ?linked dup linked? [ rethrow ] when ;
|
: ?linked dup linked-error? [ rethrow ] when ;
|
||||||
|
|
||||||
|
TUPLE: linked-thread supervisor ;
|
||||||
|
|
||||||
|
M: linked-thread error-in-thread
|
||||||
|
[ <linked-error> ] keep
|
||||||
|
linked-thread-supervisor mailbox-put ;
|
||||||
|
|
||||||
|
: <linked-thread> ( quot name mailbox -- thread' )
|
||||||
|
>r <thread> linked-thread construct-delegate r>
|
||||||
|
over set-linked-thread-supervisor ;
|
||||||
|
|
||||||
: spawn-linked-to ( quot name mailbox -- thread )
|
: spawn-linked-to ( quot name mailbox -- thread )
|
||||||
[ >r <linked> r> mailbox-put ] curry <thread>
|
<linked-thread> [ (spawn) ] keep ;
|
||||||
[ (spawn) ] keep ;
|
|
||||||
|
|
|
@ -29,7 +29,7 @@ IN: temporary
|
||||||
"crash" throw
|
"crash" throw
|
||||||
] "Linked test" spawn-linked drop
|
] "Linked test" spawn-linked drop
|
||||||
receive
|
receive
|
||||||
] [ linked-error "crash" = ] must-fail-with
|
] [ delegate "crash" = ] must-fail-with
|
||||||
|
|
||||||
MATCH-VARS: ?from ?to ?value ;
|
MATCH-VARS: ?from ?to ?value ;
|
||||||
SYMBOL: increment
|
SYMBOL: increment
|
||||||
|
|
Loading…
Reference in New Issue