Implementing of DO LOOP in the high level — over BEGIN UNTIL

do-loop-hl.fth

\ 2019-07-23 ruv

\ Implementing of DO LOOP in the high level — in the basis of BEGIN UNTIL and AHEAD THEN

\ An environmental dependency: the control-flow stack should be implemented using the data stack.
\ Otherwise the code should be adjusted to deal with the separate control-flow stack
\ (or maybe CS-ROLL and CS-DEPTH could be used for portability)


(
  If the loop index did not cross the boundary between the loop limit minus one and the loop limit,
  continue execution at the beginning of the loop. 

  [ limit-1 ; limit ]
  
  index1 < limit <= index2
  index2 < limit <= index1
)

: (+loop) ( n limit index1 -- limit index2 flag ) \ flag=0 to continue, flag<>0 to stop iterations  
  dup >r over - ( n limit index1-limit ) ( R: index1 )
  dup 3 pick ( n limit index1-limit index1-limit n )
  xor 0< 0= ( n limit index1-limit flag ) \ the same sign  
  if drop swap r> + 0 exit then ( n limit index1-limit  )
  dup 3 pick + ( n limit index1-limit index1-limit+n  )
  xor 0< 0= ( n limit flag ) \ the same sign
  if swap r> + 0 exit then ( n limit )
  swap r> + true
;
\ the above "(+loop)" word algorithm was taken from ikForth
\ see: https://github.com/ikysil/ikforth/bootdict/x86/fcontrol.asm


: p postpone postpone ; immediate

variable ac  variable d0

: initialize-loop ( -- ac_prev d0_prev ) ac @  ac 0! d0 @ depth d0 ! ;
: finalize-loop ( ac_prev d0_prev c: i*x -- ) begin ac @ while p then ac 1-! repeat depth d0 @ <> -22 and throw d0 ! ac ! ;
: ac+ ac 1+! ;
: cs-cnt depth d0 @ - ;

: (do) p begin p 2>r ;

: do initialize-loop (do) ; immediate

: ?do initialize-loop p 2dup p <> p if (do) ac+ ; immediate

: leave p 2r> cs-cnt n>r p ahead nr> drop ac+ ; immediate

: +loop p 2r> p (+loop) p until finalize-loop p 2drop ; immediate

: loop 1 p literal p +loop ; immediate

: unloop p rdrop p rdrop ; immediate

: i p r@ ; immediate

: j p 2r> p r@ p -rot p 2>r ; immediate