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
This commit is contained in:
parent
6c97377f2f
commit
6c31f368c3
274
iter.jrt
274
iter.jrt
|
|
@ -39,10 +39,23 @@ nexttop :peek nextpeek
|
|||
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
|
||||
|
|
@ -57,60 +70,66 @@ nexttop :drop nextdrop
|
|||
itop :push >i
|
||||
nexttop :push >next
|
||||
|
||||
:asm r>next
|
||||
MOV BX @[ SS: nexttop @]
|
||||
DEC BX DEC BX
|
||||
DEC BP DEC BP
|
||||
MOV AX @[ BP]
|
||||
MOV @[ SS: nexttop @] BX
|
||||
MOV @[ SS: BX] AX
|
||||
NEXT
|
||||
|
||||
:asm next>r
|
||||
MOV BX @[ SS: nexttop @]
|
||||
MOV AX @[ SS: BX]
|
||||
INC BX INC BX
|
||||
MOV @[ SS: nexttop @] BX
|
||||
MOV @[ BP] AX
|
||||
INC BP INC BP
|
||||
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: )
|
||||
( -- more nextcount )
|
||||
( It must take care of updating the i-stack directly. if there are
|
||||
no more values, it must remove the values from the i-stack and return
|
||||
0 in the "more" place.
|
||||
( -- 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.
|
||||
|
||||
"nextcount" must be the number of items that are being taken up on the next
|
||||
stack by this word. For simple iterators this will be 1, for the space
|
||||
the iterator word takes. If "more" is 0, this number of items will be
|
||||
dropped. This is always returned even if there are more items to iterate
|
||||
over, in order to support efficient cancellation. ">cancel" will push a word
|
||||
onto the next-stack that will query the iterator below it to determine how
|
||||
many items need to be dropped. It will drop one item from the i-stack if the
|
||||
iterator indicates that there are more items.
|
||||
|
||||
If an iterator requires any more complex cleanup to happen as the result
|
||||
of a cancellation, such as dropping multiple items off the i-stack, or
|
||||
aborting a task, it should check the "cancelled" flag to determine whether
|
||||
to perform it. An iterator that returns 0 0 will not cause any further
|
||||
changes to occur to the iteration stacks, which allows it to be in complete
|
||||
control of this scenario if needed.
|
||||
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! )
|
||||
|
||||
( get-next returns the result of the iterator in swapped order - it is usually
|
||||
more convenient to specify the count last when writing iterators, but it's
|
||||
always more convenient to check the flag first when consuming the result. )
|
||||
: get-next ( -- c f ) 0 nextpeek execute swap ;
|
||||
: n-nextdrop ( c -- ) dup if begin nextdrop 1- dup not until then drop ;
|
||||
: iterate get-next if drop 1 else n-nextdrop 0 then ;
|
||||
: 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
|
||||
|
|
@ -124,138 +143,85 @@ nexttop :push >next
|
|||
:timm continue CONTINUE ;
|
||||
:timm next CONTINUE <i patch!t ; }
|
||||
|
||||
0 var, cancelled
|
||||
: >cancel :| 1 cancelled ! nextdrop get-next if idrop then
|
||||
0 cancelled ! 0 swap |; >next ;
|
||||
{ : break ' >cancel , ['] continue ; immediate
|
||||
: >cancel :| ' finished :| nextdrop cancel |; |; >next ;
|
||||
{ : break ' >cancel , ['] continue ; immediate
|
||||
:timm break t, >cancel CONTINUE ; }
|
||||
: cancel >cancel iterate drop ;
|
||||
|
||||
: nothing :| 0 1 |; >next ;
|
||||
: single >i :| nextdrop :| idrop 0 1 |; >next 1 1 |; >next ;
|
||||
: times ( n -- ) >i :| <i dup if 1- >i 1 then 1 |; >next ;
|
||||
: links ( p -- )
|
||||
dup if >i :| <i @ dup if >i 1 then 1 |; >next else nothing then ;
|
||||
: +for? ( n -- f ) <i + dup 1 nextpeek = if drop 0 else >i 1 then ;
|
||||
: for ( start lim -- ) >next 1- >i :| 1 +for? 2 |; >next ;
|
||||
: 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? 3 |; >next ;
|
||||
: pchars ( st -- ) 1- >i :| <i 1+ dup b@ if >i 1 else drop 0 then 1 |; >next ;
|
||||
>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 _resume ( cpcancel -- 0 0 args... )
|
||||
POP DX
|
||||
MOV AX SS
|
||||
MOV ES AX
|
||||
PUSH FALSE
|
||||
PUSH FALSE
|
||||
MOV DI @[ SS: nexttop @]
|
||||
|
||||
( make SP affect the nextstack and DI affect the data stack. )
|
||||
STD ( data stack grows down )
|
||||
XCHG DI SP
|
||||
|
||||
POP BX ( points to xt of the girl calling this, discard )
|
||||
POP BX ( points to the following the yield )
|
||||
XOR CX CX
|
||||
MOV CL @[ BX]
|
||||
CMP @[ cancelled @] 0 #
|
||||
JNZ 0 @>
|
||||
( not cancelled; move CX values from next-stack to data-stack )
|
||||
( PUSH decrements and then stores; STOSW stores then decrements. )
|
||||
SCASW ( pre-decrement )
|
||||
|
||||
JCXZ 2 @>
|
||||
1 :>
|
||||
POP AX
|
||||
STOSW
|
||||
LOOP 1 <@
|
||||
2 <:
|
||||
( fix return stack to return to the yielded code )
|
||||
INC BX
|
||||
MOV @[ BP] BX
|
||||
INC BP INC BP
|
||||
( fix SP - DI is one word past the end of the stack )
|
||||
CLD SCASW XCHG SP DI
|
||||
( fix nexttop )
|
||||
MOV @[ SS: nexttop @] DI
|
||||
NEXT
|
||||
0 <:
|
||||
( cancelled! )
|
||||
( fix SP )
|
||||
CLD XCHG SP DI
|
||||
|
||||
( throw away next values )
|
||||
SHL CX 1 #
|
||||
ADD DI CX
|
||||
|
||||
( update nexttop )
|
||||
MOV @[ SS: nexttop @] DI
|
||||
|
||||
( abort the current word )
|
||||
:asm _suspend>args ( |n| |r| yieldpoint -- argcount |n| yieldpoint |r| )
|
||||
DEC BP DEC BP
|
||||
MOV SI @[ BP]
|
||||
|
||||
( run the "cancel" xt in DX )
|
||||
MOV BX DX
|
||||
JMP @[ BX]
|
||||
|
||||
:asm _suspend ( 0 0 cpresume -- 1 n )
|
||||
POP DX
|
||||
MOV AX SS
|
||||
MOV ES AX
|
||||
MOV DI @[ SS: nexttop @]
|
||||
DEC BP DEC BP ( top of return stack points to arg count )
|
||||
MOV BX @[ BP]
|
||||
XOR CX CX
|
||||
MOV CL @[ BX]
|
||||
STD ( next-stack grows down )
|
||||
SCASW ( pre-decrement )
|
||||
JCXZ 1 @>
|
||||
0 :>
|
||||
POP AX
|
||||
STOSW
|
||||
LOOP 0 <@
|
||||
1 <:
|
||||
MOV AX BX
|
||||
STOSW
|
||||
MOV AX DX
|
||||
STOSW
|
||||
CLD SCASW
|
||||
MOV @[ SS: nexttop @] DI
|
||||
( data stack contains 0 0, must become 1 argcount+2 )
|
||||
POP AX
|
||||
POP AX
|
||||
MOV AX 1 #
|
||||
MOV DI @[ BP]
|
||||
XOR AH AH
|
||||
MOV AL @[ SS: DI]
|
||||
PUSH AX
|
||||
MOV CL @[ BX]
|
||||
INC CX INC CX
|
||||
PUSH CX
|
||||
MOV BX @[ SS: nexttop @]
|
||||
DEC BX DEC BX
|
||||
MOV @[ SS: BX] DI
|
||||
MOV @[ SS: nexttop @] BX
|
||||
NEXT
|
||||
|
||||
: GENSTART_ r>next :| ' noop _resume |; >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 ; }
|
||||
|
||||
:yield yield0 :| ' noop _resume |; _suspend ;
|
||||
:yield yield >i :| ' idrop _resume idrop |; _suspend ;
|
||||
:yield yield> >i :| ' idrop _resume <i |; _suspend ;
|
||||
:yield yield2 >i >i :| idrop idrop ' noop _resume |; _suspend ;
|
||||
:yield map <i >next >i :| :| idrop <next >i cancel |;
|
||||
_resume idrop <next >i |; _suspend 1+ ;
|
||||
: _pass-suspend rdrop :| ' cancel _resume |; _suspend ;
|
||||
: _return rdrop <r 1+ >r ; ( don't yield at all, skip past the yielder )
|
||||
:yield pass _pass-suspend ;
|
||||
:yield filter if _pass-suspend then _return ;
|
||||
: 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 )) ;
|
||||
|
|
|
|||
Loading…
Reference in a new issue