2008-11-06 20:09:51 -05:00
|
|
|
! Copyright (C) 2005 Chris Double, 2007 Clemens Hofreither, 2008 James Cash.
|
2007-09-20 18:09:08 -04:00
|
|
|
! See http://factorcode.org/license.txt for BSD license.
|
2008-09-10 23:11:40 -04:00
|
|
|
USING: kernel hashtables namespaces make continuations quotations
|
2008-08-31 03:51:43 -04:00
|
|
|
accessors ;
|
2007-09-20 18:09:08 -04:00
|
|
|
IN: coroutines
|
|
|
|
|
|
|
|
SYMBOL: current-coro
|
|
|
|
|
2008-11-06 20:01:31 -05:00
|
|
|
TUPLE: coroutine resumecc exitcc originalcc ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
: cocreate ( quot -- co )
|
2012-09-22 15:57:46 -04:00
|
|
|
coroutine new
|
|
|
|
dup current-coro associate
|
|
|
|
[
|
2015-06-29 19:43:15 -04:00
|
|
|
swapd , , \ with-variables ,
|
2012-09-22 15:57:46 -04:00
|
|
|
"Coroutine has terminated illegally." , \ throw ,
|
|
|
|
] [ ] make
|
|
|
|
[ >>resumecc ] [ >>originalcc ] bi ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
: coresume ( v co -- result )
|
2012-09-22 15:57:46 -04:00
|
|
|
[
|
|
|
|
>>exitcc
|
|
|
|
resumecc>> call( -- )
|
2015-09-08 19:15:10 -04:00
|
|
|
! At this point, the coroutine quotation must have terminated
|
|
|
|
! normally (without calling coyield, coreset, or coterminate).
|
|
|
|
! This shouldn't happen.
|
2012-09-22 15:57:46 -04:00
|
|
|
f over
|
|
|
|
] callcc1 2nip ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
: coresume* ( v co -- ) coresume drop ; inline
|
|
|
|
: *coresume ( co -- result ) f swap coresume ; inline
|
|
|
|
|
|
|
|
: coyield ( v -- result )
|
2012-09-22 15:57:46 -04:00
|
|
|
current-coro get
|
|
|
|
[
|
|
|
|
[ continue-with ] curry
|
|
|
|
>>resumecc
|
|
|
|
exitcc>> continue-with
|
|
|
|
] callcc1 2nip ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
: coyield* ( v -- ) coyield drop ; inline
|
|
|
|
: *coyield ( -- v ) f coyield ; inline
|
|
|
|
|
|
|
|
: coterminate ( v -- )
|
2012-09-22 15:57:46 -04:00
|
|
|
current-coro get
|
|
|
|
[ ] >>resumecc
|
|
|
|
exitcc>> continue-with ;
|
2008-11-06 20:01:31 -05:00
|
|
|
|
|
|
|
: coreset ( v -- )
|
2012-09-22 15:57:46 -04:00
|
|
|
current-coro get dup
|
|
|
|
originalcc>> >>resumecc
|
|
|
|
exitcc>> continue-with ;
|