evocation/flow-control.e

~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
~ ~~ High-level flow-control ~~
~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
~
~   We use a novel suffix-based approach to flow control. We define words
~ { and } which describe the boundaries of blocks of code, leaving a
~ description on the value stack, while still compiling the contents
~ normally.
~
~   Then follow-up words such as "if" can use that information to slide
~ the blocks around and insert any needed branches and other logic.
~
~   Both the label transform and the log-load transform go out of their way
~ to make sure these words work. Because of that, we actually get to use these
~ before defining them... just keep in mind nothing under the transform is
~ calling THESE versions.


~ (-- start pointer)
: { here @ ; make-immediate

~ (start pointer -- start pointer, length)
: } dup here @ swap - ; make-immediate


~ (start pointer, length --)
: if
  2dup swap dup 5 8 * + 3roll
  ~ (start pointer, length, start pointer, adjusted start pointer, length)
  memmove
  ~ (start pointer, length)

  swap here @ swap here ! swap
  ~ (old here, length)

  ' lit entry-to-execution-token , 0 ,
  ' != entry-to-execution-token ,

  ~   The branch length needs to be one word longer than the block length,
  ~ because the length field itself is part of the scope of the branch.
  ' 0branch entry-to-execution-token , dup 8 + ,
  ~ (old here, length)

  drop 5 8 * + here !
  ; make-immediate


~ (start pointer, length --)
: unless
  2dup swap dup 5 8 * + 3roll
  ~ (start pointer, length, start pointer, adjusted start pointer, length)
  memmove
  ~ (start pointer, length)
  swap here @ swap here ! swap
  ~ (old here, length)
  ' lit entry-to-execution-token , 0 ,
  ' = entry-to-execution-token ,
  ~   The branch length needs to be one word longer than the block length,
  ~ because the length field itself is part of the scope of the branch.
  ' 0branch entry-to-execution-token , dup 8 + ,
  ~ (old here, length)
  drop 5 8 * + here ! ; make-immediate


~ (true start, true length, false start, false length --)
: if-else

  ~   First we slide the false-block forward, then the true-block. We slide
  ~ them both directly into their final positions, leaving space at the start
  ~ for a test and branch, and space in between for an unconditional branch.
  ~ Those spaces will take five words, and two words, respectively. So the
  ~ false-block gets moved by seven words, and the true-block gets moved by
  ~ five words.
  2dup swap dup 7 8 * + 3roll memmove
  ~ (true start, true length, false start, false length)
  3 pick dup 5 8 * + 4 pick memmove
  ~ (true start, true length, false start, false length)

  ~   Now we write out the initial test-and-branch.
  4 roll dup 5 unroll here @ 6 unroll here !
  ~ (old here, true start, true length, false start, false length)
  ' lit entry-to-execution-token , 0 ,
  ' != entry-to-execution-token ,
  ~   Branch past the length field, the true-block, and the unconditional
  ~ branch in the middle.
  ' 0branch entry-to-execution-token ,
  3roll dup 4 unroll 3 8 * + ,

  ~  Next, write out the unconditional branch in the middle.
  swap dup 3unroll 5 8 * + here !
  ' branch entry-to-execution-token ,
  ~  Branch past the length field and the false-block.
  dup 8 + ,

  ~  Set "here" to point to the true end.
  drop drop drop drop 7 8 * + here !
  ; make-immediate


~ (start, length --)
: forever
  ' branch entry-to-execution-token , 8 + -1 * , drop
  ; make-immediate


~   This slides the body forward, leaving the test where it is. It puts a
~ conditional branch in-between them, then appends an unconditional branch
~ at the end.
~
~ (test start, test length, body start, body length --)
: while
  ~   The conditional branch needs five words.
  2dup swap dup 5 8 * + 3roll memmove
  here @ 5 unroll swap dup 3unroll here !
  ~ (old here, test start, test length, body start, body length)
  ' lit entry-to-execution-token , 0 ,
  ' != entry-to-execution-token ,
  ~ Branch past the length field, the body, and the unconditional branch.
  ' 0branch entry-to-execution-token ,
  dup 3 8 * + ,
  ~ Set "here" to the new end.
  5 8 * 6 roll + here !
  ~ (test start, test length, body start, body length)
  ~   Unconditionally branch backwards past the branch word, the body, the
  ~ conditional branch, and the test.
  ' branch entry-to-execution-token ,
  6 8 * + swap drop + swap drop -1 * ,
  ; make-immediate


~   This is a helper which does non-local exit by directly overwriting the
~ control stack, then calling regular "exit" (implicitly as part of its own
~ semicolon). The name "nexit" is short for n-exit, meaning that it takes a
~ parameter which tells it how many times to exit.
~
~   1 nexit is equivalent to regular "exit". 2 nexit is equivalent to asking
~ your own caller to exit. 0 nexit does nothing.
~
~   This style of programming isn't encouraged, but may be useful when doing
~ code that transforms other code.
~
~   This is much lower-level than the other flow-control stuff, but it isn't
~ compatible with the label transform due to relying on r0, so it needs to go
~ somewhere other than core.e, and this was the closest fit.
~
~   Anecdotally, this feature is traditionally called "shunt", and sometimes
~ "rdrop".
~
~ (count --)
: nexit 8 * control@ + r0 @ min control! ;