Jeremy Penner
6c31f368c3
refactor yielders to be defined with explicit suspend, resume, and cancel xts, and not require explicit calls to _resume / _suspend
229 lines
6.8 KiB
Plaintext
Executable file
229 lines
6.8 KiB
Plaintext
Executable file
( iteration control stacks
|
|
We create two new stacks - a small stack to hold the "current" value
|
|
of the loop, or the "i" stack, and a larger stack to hold any extra
|
|
state, as well as the cp of a word that moves to the next value, which
|
|
we call the "next" stack.
|
|
With these two new stacks, we can create a generic loop construct for
|
|
iterating over streaming values. Not only that, but those values can be
|
|
arbitrarily filtered and transformed simply by pushing a new value onto
|
|
the iter-next stack which calls out to the previous one. )
|
|
|
|
uservar itop
|
|
8 cells userallot
|
|
{ userhere @ } const itop-init
|
|
uservar nexttop
|
|
24 cells userallot
|
|
{ userhere @ } const nexttop-init
|
|
|
|
' task-init :chain
|
|
>r itop-init itop r@ !far
|
|
nexttop-init nexttop r@ !far <r ;
|
|
|
|
taskseg task-init drop
|
|
|
|
{ : :peek
|
|
:ASM ( pixp -- ) >r
|
|
( i -- v )
|
|
POP AX
|
|
SHL AX 1 #
|
|
MOV BX @[ SS: <r @]
|
|
ADD BX AX
|
|
PUSH @[ SS: BX]
|
|
NEXT ; }
|
|
|
|
itop :peek ipeek
|
|
nexttop :peek nextpeek
|
|
|
|
{ : :drop ( pixp -- )
|
|
:ASM >r
|
|
MOV BX @[ SS: r@ @]
|
|
INC BX INC BX
|
|
MOV @[ SS: <r @] BX
|
|
NEXT ;
|
|
: :ndrop ( pixp -- )
|
|
:ASM >r ( c -- )
|
|
MOV BX @[ SS: r@ @]
|
|
POP CX
|
|
ADD BX CX
|
|
MOV @[ SS: <r @] BX
|
|
NEXT ; }
|
|
|
|
itop :drop idrop
|
|
itop :ndrop n-idrop
|
|
nexttop :drop nextdrop
|
|
nexttop :ndrop n-nextdrop
|
|
|
|
: iterdrop ( ci cnext -- ) n-nextdrop n-idrop ;
|
|
: finished ( -- 0 ) cancel 0 ;
|
|
: finish? ( f -- f ) if 1 else finished then ;
|
|
|
|
{ : :push ( pixp -- )
|
|
:ASM >r
|
|
( v -- )
|
|
POP AX
|
|
MOV BX @[ SS: r@ @]
|
|
DEC BX DEC BX
|
|
MOV @[ SS: <r @] BX
|
|
MOV @[ SS: BX] AX
|
|
NEXT ; }
|
|
|
|
itop :push >i
|
|
nexttop :push >next
|
|
|
|
: <i 0 ipeek idrop ;
|
|
: <next 0 nextpeek nextdrop ;
|
|
: i 0 ipeek ; : j 1 ipeek ;
|
|
|
|
:asm n-<next ( n |n| args... -- args... |n| )
|
|
POP CX
|
|
JCXZ 2 @>
|
|
MOV DI @[ SS: nexttop @]
|
|
( make SP affect the nextstack and DI affect the data stack. )
|
|
STD ( data stack grows down )
|
|
XCHG DI SP
|
|
( PUSH decrements and then stores; STOSW stores then decrements. )
|
|
SCASW ( pre-decrement )
|
|
1 :>
|
|
POP AX
|
|
STOSW
|
|
LOOP 1 <@
|
|
( fix SP - DI is one word past the end of the stack )
|
|
CLD SCASW XCHG SP DI
|
|
( update nexttop )
|
|
MOV @[ SS: nexttop @] DI
|
|
2 <:
|
|
NEXT
|
|
|
|
:asm n->next ( args... n |n| -- |n| args... )
|
|
POP CX
|
|
JCXZ 1 @>
|
|
MOV DI @[ SS: nexttop @]
|
|
STD ( next-stack grows down )
|
|
SCASW ( pre-decrement )
|
|
0 :>
|
|
POP AX
|
|
STOSW
|
|
LOOP 0 <@
|
|
CLD SCASW ( correct DI - off by one word )
|
|
MOV @[ SS: nexttop @] DI
|
|
1 <:
|
|
NEXT
|
|
|
|
( iterator words must have the following shape: )
|
|
( -- xt-iter xt-cancel )
|
|
( The xt-iter word must take care of updating the stacks directly. If
|
|
there are no more values, it must remove the values from the i-stack,
|
|
drop itself from the next-stack, and return 0. "finished" and "finish?"
|
|
are useful words to help with this.
|
|
|
|
The xt-cancel word should remove all of the iterator's state from the
|
|
iteration stacks and return nothing. "iterdrop" is a useful word to help
|
|
with this. If the iterator is itself making use of an iterator below it
|
|
on the stack, the xt-cancel word should call "cancel" to recursively clean
|
|
that up once it's done.
|
|
|
|
Note that all "next" words _must_ be defined in the target Forth!
|
|
This means that any iterator that dereferences near memory, such as "links",
|
|
WILL NOT WORK on the host Forth! )
|
|
|
|
: call-next ( -- xt-iter xt-cancel ) 0 nextpeek execute ;
|
|
: iterate call-next drop execute ;
|
|
: cancel call-next swap drop execute ;
|
|
|
|
: EACH_ <r iterate if cell + else @ then >r ;
|
|
|
|
{ ( Because we dereference pointers on the return stack, we must run this
|
|
from the caller's segment. Copy the definition into the host segment. )
|
|
: EACH_ <r iterate if cell + else @ then >r ;
|
|
: each ' EACH_ , here >i 0 , ; immediate
|
|
: continue ' GOTO_ , i cell - , ; immediate
|
|
: next ['] continue here <i ! ; immediate
|
|
:timm each t, EACH_ patchpt >i ;
|
|
: CONTINUE t, GOTO_ i cell - w>t ;
|
|
:timm continue CONTINUE ;
|
|
:timm next CONTINUE <i patch!t ; }
|
|
|
|
: >cancel :| ' finished :| nextdrop cancel |; |; >next ;
|
|
{ : break ' >cancel , ['] continue ; immediate
|
|
:timm break t, >cancel CONTINUE ; }
|
|
|
|
: nothing :| ' 0 ' nextdrop |; >next ;
|
|
: 1cancel 1 1 iterdrop ;
|
|
: single >i :| nextdrop :| ' finished ' 1cancel |; >next 1 |;
|
|
' 1cancel |; >next ;
|
|
: times ( n -- ) >i :| :| <i dup 1- >i finish? |; ' 1cancel |; >next ;
|
|
: links ( p -- ) dup
|
|
if >i :| :| <i @ dup >i finish? |; ' 1cancel |; >next else nothing then ;
|
|
: +for? ( n -- f ) <i + dup >i 1 nextpeek = finish? ;
|
|
: for ( start lim -- )
|
|
>next 1- >i :| :| 1 +for? |; :| 1 2 iterdrop |; |; >next ;
|
|
: for+ ( start lim inc -- )
|
|
>next >next 1 nextpeek - >i
|
|
:| :| 2 nextpeek +for? |; :| 1 3 iterdrop |; |; >next ;
|
|
: pchars ( st -- ) 1- >i
|
|
:| :| <i 1+ dup >i b@ finished? |; ' 1cancel |; >next ;
|
|
|
|
: nth ( i -- v ) 0 each 2dup = if drop i break then 1+ next swap drop ;
|
|
: count 0 each 1+ next ;
|
|
|
|
:asm _suspend>args ( |n| |r| yieldpoint -- argcount |n| yieldpoint |r| )
|
|
DEC BP DEC BP
|
|
MOV DI @[ BP]
|
|
XOR AH AH
|
|
MOV AL @[ SS: DI]
|
|
PUSH AX
|
|
MOV BX @[ SS: nexttop @]
|
|
DEC BX DEC BX
|
|
MOV @[ SS: BX] DI
|
|
MOV @[ SS: nexttop @] BX
|
|
NEXT
|
|
|
|
:asm _resume>args ( |n| yieldpoint xt-next -- argcount |n| |r| resumepoint )
|
|
MOV BX @[ SS: nexttop @]
|
|
MOV DI @[ SS: 2 @+ BX]
|
|
ADD BX 4 #
|
|
MOV @[ SS: nexttop @] BX
|
|
XOR AH AH
|
|
MOV AL @[ DS: DI]
|
|
INC DI
|
|
PUSH AX ( argcount )
|
|
MOV DI @[ BP]
|
|
INC BP INC BP
|
|
NEXT
|
|
|
|
: _resume _resume>args n-<next rswap ;
|
|
: _suspend rswap _suspend>args swap >r n->next <r >next ;
|
|
: _cancel _resume>args n-nextdrop rdrop ;
|
|
|
|
: GENSTART_ <r >next :| :| _resume |; ' _cancel |; >next ;
|
|
|
|
( yielding from a generator has three moving parts:
|
|
)
|
|
{ var gen-arg-count
|
|
:timm (( t:| t, GENSTART_ gen-arg-count @ >t ;
|
|
:timm )) t|; t, execute 0 gen-arg-count ! ;
|
|
: +arg 1 gen-arg-count !+ ; :timm +arg +arg ;
|
|
: -arg -1 gen-arg-count !+ ; :timm -arg -arg ;
|
|
:timm >arg t, >next +arg ;
|
|
( TODO: totally wrong now )
|
|
: :yield } create immediate target , startcolon
|
|
does> @ w>t gen-arg-count @ >t ; }
|
|
|
|
: i>next <i >next >i ; : 2>i >i >i ; : 2idrop idrop idrop ;
|
|
: unmap idrop <next >i ; : mapcancel unmap cancel ;
|
|
: unsuspend rdrop <r 1+ >r ; ( don't yield at all, skip past the yielder )
|
|
: suspend? not if unsuspend then ;
|
|
|
|
( suspend resume cancel )
|
|
' noop ' noop ' noop :yield yield0
|
|
' >i ' idrop ' idrop :yield yield
|
|
' >i ' <i ' idrop :yield yield>
|
|
' 2>i ' 2idrop dup :yield yield2
|
|
' i>next ' unmap ' mapcancel :yield map
|
|
' noop ' noop ' cancel :yield pass
|
|
' suspend? ' noop ' cancel :yield filter
|
|
|
|
: take ( n -- ) >arg (( each dup if pass else break then 1- next drop )) ;
|
|
: readbytes ( -- ) (( each i b@ map next )) ;
|
|
: chars ( p -- ) pchars readbytes ;
|