dialer/iter.jrt
2023-11-05 00:30:34 -04:00

295 lines
9.1 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, which we call the "next" stack. Typically the top of the next
stack would contain an "iterator" that knows how to advance to the next
value and how to be cancelled, depending on the needs of the calling code.
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
SHL CX 1 #
ADD BX CX
MOV @[ SS: <r @] BX
NEXT ; }
itop :drop idrop
itop :ndrop n-idrop
nexttop :drop nextdrop
nexttop :ndrop n-nextdrop
: iterdrop ( n-next -- ) n-nextdrop idrop ;
: 1-iterdrop nextdrop idrop ;
{ : :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| )
MOV AX SS
MOV ES AX
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... )
MOV AX SS
MOV ES AX
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
( iterators are pointers to an array containing two function pointers:
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. "n-nextdrop" and "iterdrop" are useful
words 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! )
: iterate 0 nextpeek @ execute ;
: cancel 0 nextpeek cell + @ execute ;
: finished ( -- 0 ) cancel 0 ;
: finish? ( f -- f ) if 1 else finished then ;
: 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 ;
: blankiter, t' finished w>t t' 1-iterdrop w>t ; }
{ : defiter CREATE blankiter, DOES} >next ;
{ : :iter CREATE blankiter, startcolon DOES}
>r r@ [ 2 cells lit ] + execute <r >next ;
{ : iter! ( val off -- ) cells latest entry>tcp + !t ;
: next! 2 iter! ; : cancel! 3 iter! ;
: :next target next! startcolon ; : :cancel target cancel! startcolon ; }
defiter >cancel
:cancel nextdrop cancel ;
{ : break ' >cancel , ['] continue ; immediate
:timm break t, >cancel CONTINUE ; }
defiter nothing
' nextdrop cancel!
defiter >single-done
:iter single >i ;
:next nextdrop 1 >single-done ;
:iter times ( n -- ) >i ;
:next <i dup 1- >i finish? ;
defiter >links
:next <i @ dup >i finish? ;
: links ( p -- ) dup if >i >links else nothing then ;
: +for? ( n -- f ) <i + dup >i 1 nextpeek != finish? ;
:iter for ( start lim -- ) >next 1- >i ;
:next 1 +for? ;
:cancel 2 iterdrop ;
:iter for+ ( start lim inc -- ) >next >next 1 nextpeek - >i ;
:next 2 nextpeek +for? ;
:cancel 3 iterdrop ;
:iter pchars ( st -- ) 1- >i ;
:next <i 1+ dup >i b@ finish? ;
: nth ( i -- v ) 0 each 2dup = if drop i break then 1+ next swap drop ;
: count 0 each 1+ next ;
:asm _suspend>args
( iter |r| yieldpoint -- argcount |r| yieldpoint iter )
MOV DI @[ -2 @+ BP]
POP @[ BP]
INC BP INC BP
XOR AH AH
MOV AL @[ DS: DI]
PUSH AX
NEXT
:asm 2r>next
MOV BX @[ SS: nexttop @]
( bp grows up. top: BP-2, second: BP-4
nexttop grows down. top: nexttop, second: nexttop+2 )
SUB BX 4 # ( make room for 2 more items on next stack )
MOV AX @[ -4 @+ BP]
MOV @[ SS: 2 @+ BX] AX
MOV AX @[ -2 @+ BP]
MOV @[ SS: BX] AX
SUB BP 4 # ( pop two off return stack )
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 @[ BP] DI
INC BP INC BP
NEXT
: _resume _resume>args n-<next rswap ;
: _suspend
( args... iter |r| yieldpoint ret -- 1 |r| ret |n| args... yieldpoint iter )
rswap _suspend>args n->next 2r>next 1 ;
: _cancel _resume>args n-nextdrop rdrop ;
defiter >genstart
:next _resume>args n-<next ;
' _cancel cancel!
: GENSTART_ <r >next >genstart ;
( yielding from a generator has three moving parts:
suspend: run immediately when the generator yields. takes care of updating
the i-stack appropriately, as well as potentially saving any
yield-specific state to the next-stack. After this runs, the
generator's extra parameters are pushed to the next-stack, along
with the generator's "resume" pointer and the yielder's iterator.
resume: run when the generator is resumed by iterating. Before this runs,
the yielder will take care of placing the "resume" pointer back
on the stack and restoring the generator's arguments, so the
stack environments should match what they were when the suspension
happened. This deals with cleaning up after the yielder so the
rest of the generator can run.
cancel: run when the generator is aborted. Before this runs, the next-stack
is cleared of the "resume" pointer and all of the generator's
arguments. This should remove any yield-specific data from the
iteration stacks, and potentially call "cancel" to clean up the
iterator underneath if the yielder is intended to map or filter
another iterator. )
{ var gen-arg-count
:timm (( t:| t, GENSTART_ gen-arg-count @ >t ;
:timm )) t, 0 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 ;
: colonpair ( xt-first xt-second -- xt )
target <rot gencolon w>t swap w>t t, return ;
: :yield ( xt-suspend xt-resume xt-cancel -- )
} t' _cancel swap colonpair swap t' _resume swap colonpair
target >r w>t w>t gencolon w>t r@ compilenum t, _suspend t, return
create immediate <r 2 cells + , does> @ w>t gen-arg-count @ >t ; }
: shadow-i <i >next >i ; : 2>i >i >i ; : 2idrop idrop idrop ;
: unmap idrop <next >i ; : mapcancel unmap cancel ;
: unsuspend rdrop 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
' shadow-i ' 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 ;