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, which we call the "next" stack. Typically the top of the next
  stack would contain a pointer to the next instruction in a "generator"
  function, which would decide whether to continue iterating or cancel 
  based on a flag on the top of the 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 ;

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

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

( When a generator suspends, it pushes the instruction pointer of the
  resumption point onto the next stack, and pushes 1 onto the data stack
  before returning to its caller.

  When a generator completes, it pushes 0 onto the data stack before 
  returning to its caller.  

  When a generator resumes, it should consume a flag from the data stack
  which tells it whether it should attempt to produce a new value, or 
  cancel itself. If it is told to cancel it should clean up the iteration
  stacks and return with nothing on the data stack.
  
  Generally, when a generator is producing a new value, all data will be
  removed from the iteration stacks; this allows generators to nest.

  Generators are always defined in the target segment. Not sure it's worth
  tryint to make host-defined generators work. )

dbg" iteration"
: iterate <next >r 1 ;
: cancel <next >r 0 ;

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

: _nargs@ ( resumepoint -- n ) [ cell 1 + lit ] - b@ ;
: gen-suspend <r >next ;      : gen-resume not if rdrop then ;
: gen-suspend_ <r 1+ >next ;  : gen-_resume r@ _nargs@ swap if n-<next else n-nextdrop rdrop then ;
 { var gen-arg-count 
  :timm ;(( gen-arg-count @ if t, gen-suspend_ gen-arg-count @ >t t, gen-_resume else
                               t, gen-suspend t, gen-resume then ; 
  :timm )); t, 0 t, return 0 gen-arg-count ! ['] [ ; 
  :timm (( t:| ['] ;(( ;
  :timm )) ['] )); patch!t t, execute ;
  :timm +arg 1 gen-arg-count !+ ;
  :timm -arg -1 gen-arg-count !+ ;
  :timm >arg t, >next ['] +arg ; }

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

( :yield defines a single word which compiles to multiple words, with an optional argument count between them. )
{ target const DOES-SUSPEND } ] @ execute <r >next 1 ;
{ target const DOES-SUSPEND_ } ] @ execute r@ b@ n->next <r 1+ >next 1 ;
{ target const DOES-_RESUME } ] r@ _nargs@ >rot >r dup swap >r if n-<next else n-nextdrop then <r <r [
{ target const DOES-RESUME } ] swap if @ execute else cell + @ execute rdrop then ;
{ : :yield ( cancel resume suspend -- ) create immediate target , target 6 cells + , 
     t& $DOCREATE w>t DOES-SUSPEND w>t dup w>t t& $DOCREATE w>t DOES-SUSPEND_ w>t w>t
     t& $DOCREATE w>t DOES-RESUME w>t dup w>t over w>t t& $DOCREATE w>t DOES-_RESUME w>t w>t w>t 
     does> gen-arg-count @ if   dup @ [ 3 cells lit ] + w>t gen-arg-count @ >t cell + @ [ 4 cells lit ] + w>t 
                           else dup @ w>t cell + @ w>t then ; }
: shadow-i <i >next >i ; : 2>i >i >i ; : 2idrop idrop idrop ;
: unmap idrop <next >i ; : mapcancel unmap cancel ;

dbg" yields"
(     cancel       resume     suspend )
      ' noop       ' noop      ' noop :yield yield0
     ' idrop      ' idrop        ' >i :yield yield
     ' idrop         ' <i        ' >i :yield yield>
     ' idrop       ' noop        ' >i :yield >yield
    ' 2idrop     ' 2idrop       ' 2>i :yield yield2
 ' mapcancel      ' unmap  ' shadow-i :yield map
    ' cancel      ' noop       ' noop :yield pass

{ :timm filter T] if T] pass T] then ; }

: >cancel ;(( cancel ));
: times >arg ;(( -arg begin dup while 1- yield> repeat drop ));
: links >arg ;(( -arg dup if begin @ dup while yield> repeat then drop ));

: for ( index lim -- ) swap >arg >arg ;(( -arg begin 2dup != while yield> 1+ repeat 2drop ));
: for+ ( index lim inc -- ) >rot swap >arg >arg >arg
       ( inc lim index -- ) ;(( -arg begin 2dup != while >yield over <i + repeat 2drop drop ));

: pchars ( st -- ) >arg ;(( -arg begin dup b@ while yield> 1+ repeat drop ));

{ : break ' >cancel , ['] continue ; immediate
  :timm break t, >cancel CONTINUE ; }

: nth ( i -- v ) 0 each 2dup = if drop i break then 1+ next swap drop ;
: count 0 each 1+ next ;

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

{ :noname ( taskseg -- taskseg )
    s" IStk: " type dup itop over @far itop-init swap far.stack- cr
    s" NStk: " type dup nexttop over @far nexttop-init swap far.stack- cr
; ' .dbg-stacks redefine }