Another threads fix

db4
Slava Pestov 2008-05-07 01:56:55 -05:00
parent 918418e9e6
commit cbac71c3bf
2 changed files with 17 additions and 11 deletions

View File

@ -12,7 +12,7 @@ SYMBOL: initial-thread
TUPLE: thread
name quot exit-handler
id
continuation state
continuation state runnable
mailbox variables sleep-entry ;
: self ( -- thread ) 40 getenv ; inline
@ -138,8 +138,11 @@ DEFER: next
: (next) ( arg thread -- * )
f >>state
dup set-self
dup continuation>> ?box
[ nip continue-with ] [ drop start ] if ;
dup runnable>> [
continuation>> box> continue-with
] [
t >>runnable start
] if ;
: next ( -- * )
expire-sleep-loop

View File

@ -6,12 +6,12 @@ models namespaces parser prettyprint quotations sequences
strings threads listener classes.tuple ui.commands ui.gadgets
ui.gadgets.editors ui.gadgets.presentations ui.gadgets.worlds
ui.gestures definitions calendar concurrency.flags
ui.tools.workspace accessors ;
concurrency.mailboxes ui.tools.workspace accessors ;
IN: ui.tools.interactor
! If waiting is t, we're waiting for user input, and invoking
! evaluate-input resumes the thread.
TUPLE: interactor output history flag thread waiting help ;
TUPLE: interactor output history flag mailbox thread waiting help ;
: register-self ( interactor -- )
self >>thread drop ;
@ -40,6 +40,7 @@ TUPLE: interactor output history flag thread waiting help ;
interactor construct-editor
V{ } clone >>history
<flag> >>flag
<mailbox> >>mailbox
dup <help-model> >>help
swap >>output ;
@ -77,7 +78,7 @@ M: interactor model-changed
over empty? [ 2drop ] [ interactor-history push-new ] if ;
: interactor-continue ( obj interactor -- )
thread>> resume-with ;
mailbox>> mailbox-put ;
: clear-input ( interactor -- ) gadget-model clear-doc ;
@ -100,14 +101,16 @@ M: interactor model-changed
: interactor-yield ( interactor -- obj )
dup thread>> self eq? [
t >>waiting
[ [ flag>> raise-flag ] curry "input" suspend ] keep
f >>waiting
drop
{
[ t >>waiting drop ]
[ flag>> raise-flag ]
[ mailbox>> mailbox-get ]
[ f >>waiting drop ]
} cleave
] [ drop f ] if ;
M: interactor stream-readln
[ interactor-yield ] keep interactor-finish
[ interactor-yield ] [ interactor-finish ] bi
dup [ first ] when ;
: interactor-call ( quot interactor -- )