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