dialer/iter.jrt
Jeremy Penner 6c31f368c3 refactor iterators to supply an explicit cancel xt, rather than mixing
refactor yielders to be defined with explicit suspend, resume, and cancel xts,
and not require explicit calls to _resume / _suspend
2023-10-18 19:39:36 -04:00

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 ;