dialer/iter.jrt

( 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 ; }

itop    :drop idrop
nexttop :drop nextdrop

{ : :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

: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 ;

( 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.

  "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.

  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 ;
: 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 ; }

0 var, cancelled
: >cancel :| 1 cancelled ! nextdrop get-next if idrop then 
             0 cancelled ! 0 swap |; >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 ;
: 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 ;

: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 )
  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 #
  PUSH AX
  MOV CL @[ BX]
  INC CX INC CX
  PUSH CX
  NEXT

: GENSTART_ r>next :| ' noop _resume |; >next ;

{ 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 ;
  : :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 ;

: take ( n -- ) >arg (( each dup if pass else break then 1- next drop )) ;
: readbytes ( -- ) (( each i b@ map next )) ;
: chars ( p -- ) pchars readbytes ;