Add high-level flow control to the log-load transform

that was a lot

Change-Id: I6ae9c371fe1fe6fd2757d20df73a748339fa89d1
Force-Push: yes

3 files changed, 353 insertions, 0 deletions

diff --git a/core.e b/core.e
index 491b73c..eeeb1fc 100644
--- a/core.e
+++ b/core.e
@@ -757,6 +757,7 @@ here !
 ~   Jonesforth also offers C@C! as another name for its CCOPY, but neither
 ~ "@!" nor "mem@mem!" seems particulaly nice.
 ~
+~ TODO these parameters feel backwards
 ~ (destination, source, length --)
 : memcopy
   [ here @
@@ -776,6 +777,7 @@ here !
 ~ careful about which end the transfer starts from. This "move" vs. "copy"
 ~ distinction mirrors C terminology.
 ~
+~ TODO these parameters feel backwards
 ~ (destination, source, length --)
 : memmove
   [ here @
diff --git a/log-load.e b/log-load.e
index 9f8a8b7..927ff38 100644
--- a/log-load.e
+++ b/log-load.e
@@ -367,3 +367,216 @@
   ~ (log address, output point, here)
   ! ;
 
+
+~   Now we have a bunch of words that are the back-ends for the log-load
+~ transform's high-level flow control alternates. These implementations
+~ closely parallel the non-transformed versions in flow-control.e, which
+~ should be referenced in understanding them.
+~
+~   These variants are a bit unusual in their interfaces: They end with the
+~ log address at the top of the stack, even when they have values to return.
+~ That's because they're really just "talking" to each other; they don't need
+~ to interact with anything else, and doing it this way saves the alternates
+~ the work of swapping things around after.
+~
+~   Notice also that, because these run entirely at log-load time, they are
+~ always dealing with target pointers and don't have to convert address
+~ spaces.
+~
+~ (log address -- start pointer, log address)
+: log-load-left-curly-brace
+  log-load-here @ swap ;
+
+
+~ (start pointer, log address -- start pointer, length, log address)
+: log-load-right-curly-brace
+  swap dup 3roll
+  ~ (start pointer, start pointer, log address)
+  log-load-here @ swap
+  ~ (start pointer, start pointer, end pointer, log address)
+  3unroll swap - swap ;
+
+
+~ (start, length, log address -- log address)
+: log-load-if
+  3unroll
+  ~ (log address, start, length)
+  2dup swap dup
+  ~ (log address, start, length, length, start, start)
+  5 8 * +
+  ~ (log address, start, length, length, start, adjusted start)
+  3unroll swap
+  ~ (log address, start, length, adjusted start, start, length)
+  memmove
+  ~ (log address, start, length)
+  swap 3roll log-load-here dup @
+  ~ (length, start, log address, here pointer, old here)
+  swap 4 roll swap
+  ~ (length, log address, old here, start, here pointer)
+  !
+  ~ (length, log address, old here)
+  3unroll
+  ~ (old here, length, log address)
+  s" lit" log-load-find entry-to-execution-token log-load-comma
+  0 log-load-comma
+  s" !=" log-load-find entry-to-execution-token log-load-comma
+  s" 0branch" log-load-find entry-to-execution-token log-load-comma
+  ~ (old here, length, log address)
+  swap dup 3unroll
+  ~ (old here, length, log address, length)
+  8 + log-load-comma
+  ~ (old here, length, log-address)
+  3unroll
+  ~ (log address, old here, length)
+  drop 5 8 * +
+  ~ (log address, new here)
+  swap log-load-here
+  ~ (new here, log address, here pointer)
+  3roll swap ! ;
+
+
+~ (start, length, log address -- log address)
+: log-load-unless
+  3unroll
+  ~ (log address, start, length)
+  2dup swap dup
+  ~ (log address, start, length, length, start, start)
+  5 8 * +
+  ~ (log address, start, length, length, start, adjusted start)
+  3unroll swap
+  ~ (log address, start, length, adjusted start, start, length)
+  memmove
+  ~ (log address, start, length)
+  swap 3roll log-load-here dup @
+  ~ (length, start, log address, here pointer, old here)
+  swap 4 roll swap
+  ~ (length, log address, old here, start, here pointer)
+  !
+  ~ (length, log address, old here)
+  3unroll
+  ~ (old here, length, log address)
+  s" lit" log-load-find entry-to-execution-token log-load-comma
+  0 log-load-comma
+  s" =" log-load-find entry-to-execution-token log-load-comma
+  s" 0branch" log-load-find entry-to-execution-token log-load-comma
+  ~ (old here, length, log address)
+  swap dup 3unroll
+  ~ (old here, length, log address, length)
+  8 + log-load-comma
+  ~ (old here, length, log-address)
+  3unroll
+  ~ (log address, old here, length)
+  drop 5 8 * +
+  ~ (log address, new here)
+  swap log-load-here
+  ~ (new here, log address, here pointer)
+  3roll swap ! ;
+
+
+~ (true start, true length, false start, false length, log address
+~  -- log address)
+: log-load-if-else
+  5 unroll 2dup
+  ~ (log address, true start, true length, false start, false length,
+  ~  false start, false length)
+  swap dup 7 8 * + swap 3roll
+  ~ (log address, true start, true length, false start, false length,
+  ~  adjusted false start, false start, false length)
+  memmove
+  ~ (log address, true start, true length, false start, false length)
+  4 roll dup 5 unroll
+  ~ (log address, true start, true length, false start, false length,
+  ~  true start)
+  4 roll dup 5 unroll
+  ~ (log address, true start, true length, false start, false length,
+  ~  true start, true length)
+  swap dup 5 8 * +
+  ~ (log address, true start, true length, false start, false length,
+  ~  true length, true start, adjusted true start)
+  swap 3roll
+  ~ (log address, true start, true length, false start, false length,
+  ~  adjusted true start, true start, true length)
+  memmove
+  ~ (log address, true start, true length, false start, false length)
+
+  4 roll dup 5 unroll
+  ~ (log address, true start, true length, false start, false length,
+  ~  true start)
+  6 roll log-load-here @ 7 unroll
+  ~ (old here, true start, true length, false start, false length, true start,
+  ~  log address)
+  log-load-here 3roll swap !
+  ~ (old here, true start, true length, false start, false length,
+  ~  log address)
+  s" lit" log-load-find entry-to-execution-token log-load-comma
+  0 log-load-comma
+  s" !=" log-load-find entry-to-execution-token log-load-comma
+  s" 0branch" log-load-find entry-to-execution-token log-load-comma
+  ~ (old here, true start, true length, false start, false length,
+  ~  log address)
+  4 roll dup 5 unroll
+  ~ (old here, true start, true length, false start, false length,
+  ~  log address, true length)
+  3 8 * + log-load-comma
+  ~ (old here, true start, true length, false start, false length,
+  ~  log address)
+  3unroll
+  ~ (old here, true start, true length, log address,
+  ~  false start, false length)
+  swap dup 3unroll
+  ~ (old here, true start, true length, log address,
+  ~  false start, false length, false start)
+  5 8 * +
+  ~ (old here, true start, true length, log address,
+  ~  false start, false length, adjusted false start)
+  4 roll log-load-here 3roll swap !
+  ~ (old here, true start, true length,
+  ~  false start, false length, log address)
+  s" branch" log-load-find entry-to-execution-token log-load-comma
+  swap 8 + log-load-comma
+  ~ (old here, true start, true length, false start, log address)
+  4 unroll
+  ~ (old here, log address, true start, true length, false start)
+  drop drop drop
+  ~ (old here, log address)
+  log-load-here
+  3roll 7 8 * + swap ! ;
+
+
+~ (start, length, log address -- log address)
+: log-load-forever
+  s" branch" log-load-find entry-to-execution-token log-load-comma
+  swap 8 + -1 * log-load-comma
+  swap drop ;
+
+
+~ (test start, test length, body start, body length, log address
+~  -- log address)
+: log-load-while
+  ." at start " stackhex
+  5 unroll 2dup
+  ~ (log address, test start, test length, body start, body length,
+  ~  body start, body length)
+  swap dup 5 8 * + swap 3roll
+  ~ (log address, test start, test length, body start, body length,
+  ~  adjusted body start, body start, body length)
+  memmove
+
+  ~ (log address, test start, test length, body start, body length)
+  5 roll log-load-here @ 6 unroll
+  ~ (old here, test start, test length, body start, body length, log address)
+  log-load-here 4 roll dup 5 unroll swap !
+  ~ (old here, test start, test length, body start, body length, log address)
+  s" lit" log-load-find entry-to-execution-token log-load-comma
+  0 log-load-comma
+  s" !=" log-load-find entry-to-execution-token log-load-comma
+  s" 0branch" log-load-find entry-to-execution-token log-load-comma
+  swap dup 3unroll 3 8 * + log-load-comma
+  ~ (old here, test start, test length, body start, body length, log address)
+  log-load-here 5 8 * 8 roll + swap !
+  ~ (test start, test length, body start, body length, log address)
+  s" branch" log-load-find entry-to-execution-token log-load-comma
+  5 unroll
+  ~ (log address, test start, test length, body start, body length)
+  6 8 * + swap drop + swap drop -1 * log-load-comma ;
+
diff --git a/transform.e b/transform.e
index a137c0c..d4c1c43 100644
--- a/transform.e
+++ b/transform.e
@@ -702,6 +702,7 @@ allocate-transform-state s" transform-state" variable
   dup s" L!'" stringcmp 0 = { drop -1 exit } if
   dup s" ," stringcmp 0 = { drop -1 exit } if
 
+  dup s" foo" stringcmp 0 = { drop 0 exit } if ~ DO NOT SUBMIT
   ~   If we get here, that's a problem. Emit an error message to make sure
   ~ it's easy to diagnose. We also return a comically large negative value,
   ~ to make sure things fail as quickly as possible afterwards.
@@ -1896,6 +1897,131 @@ allocate-transform-state s" transform-state" variable
   ; make-immediate
 
 
+~   Not to be outdone by the label transform, the log-load transform also
+~ offers alternates of all the high-level flow-control words: if, unless,
+~ if-else, forever, and while. Unlike the label transform, we also need to
+~ implement alternates of { and }, because their values need to be on the
+~ stack at log-load "immediate" time, not at transform time.
+~
+~   Anyway, most of the implementation is deferred to pre-packaged words in
+~ log-load.e.
+: log-load-left-curly-brace-alternate
+  log-load-roll-log-address
+
+  swap-transform-variables
+  L@' log-load-left-curly-brace
+  swap-transform-variables
+
+  offset-to-target-address-space ,               ~ log-load-left-curly-brace
+
+  ~ It pushes a start pointer onto the stack.
+  1 transform-apply-stack-delta
+
+  log-load-unroll-log-address
+  ; make-immediate
+
+
+: log-load-right-curly-brace-alternate
+  log-load-roll-log-address
+
+  swap-transform-variables
+  L@' log-load-right-curly-brace
+  swap-transform-variables
+
+  offset-to-target-address-space ,               ~ log-load-right-curly-brace
+
+  ~ It pushes a length value onto the stack.
+  1 transform-apply-stack-delta
+
+  log-load-unroll-log-address
+  ; make-immediate
+
+
+~ (start pointer, length --)
+: log-load-if-alternate
+  log-load-roll-log-address
+
+  swap-transform-variables
+  L@' log-load-if
+  swap-transform-variables
+
+  offset-to-target-address-space ,               ~ log-load-if
+
+  ~ It pops the start and length.
+  -2 transform-apply-stack-delta
+
+  log-load-unroll-log-address
+  ; make-immediate
+
+
+~ (start pointer, length)
+: label-unless-alternate
+  log-load-roll-log-address
+
+  swap-transform-variables
+  L@' log-load-unless
+  swap-transform-variables
+
+  offset-to-target-address-space ,               ~ log-load-unless
+
+  ~ It pops the start and length.
+  -2 transform-apply-stack-delta
+
+  log-load-unroll-log-address
+  ; make-immediate
+
+
+~ (true start, true length, false start, false length)
+: log-load-if-else-alternate
+  log-load-roll-log-address
+
+  swap-transform-variables
+  L@' log-load-if-else
+  swap-transform-variables
+
+  offset-to-target-address-space ,               ~ log-load-if-else
+
+  ~ It pops two pairs of start and length.
+  -4 transform-apply-stack-delta
+
+  log-load-unroll-log-address
+  ; make-immediate
+
+
+~ (start, length --)
+: log-load-forever-alternate
+  log-load-roll-log-address
+
+  swap-transform-variables
+  L@' log-load-forever
+  swap-transform-variables
+
+  offset-to-target-address-space ,               ~ log-load-forever
+
+  ~ It pops the start and length.
+  -2 transform-apply-stack-delta
+
+  log-load-unroll-log-address
+  ; make-immediate
+
+
+~ (test start, test length, body start, body length --)
+: log-load-while-alternate
+  log-load-roll-log-address
+
+  swap-transform-variables
+  L@' log-load-while
+  swap-transform-variables
+
+  offset-to-target-address-space ,               ~ log-load-while
+
+  ~ It pops two pairs of start and length.
+  -4 transform-apply-stack-delta
+
+  log-load-unroll-log-address
+  ; make-immediate
+
+
 ~   This implements the log-load transform for a single word. It is directly
 ~ analogous to "interpret", and reading interpret.e may help in understanding
 ~ it, though it's meant to still make sense on its own.
@@ -1945,6 +2071,18 @@ allocate-transform-state s" transform-state" variable
     swap drop ' log-load-dot-string-alternate swap } if
   dup s" L@'" stringcmp 0 = { swap drop ' log-load-L@'-alternate swap } if
   dup s" L!'" stringcmp 0 = { swap drop ' log-load-L!'-alternate swap } if
+  dup s" {" stringcmp 0 = {
+    swap drop ' log-load-left-curly-brace-alternate swap } if
+  dup s" }" stringcmp 0 = {
+    swap drop ' log-load-right-curly-brace-alternate swap } if
+  dup s" if" stringcmp 0 = { swap drop ' log-load-if-alternate swap } if
+  dup s" unless" stringcmp 0 = {
+    swap drop ' log-load-unless-alternate swap } if
+  dup s" if-else" stringcmp 0 = {
+    swap drop ' log-load-if-else-alternate swap } if
+  dup s" forever" stringcmp 0 = {
+    swap drop ' log-load-forever-alternate swap } if
+  dup s" while" stringcmp 0 = { swap drop ' log-load-while-alternate swap } if
   ~ (name as stack string, 0 or alternate entry pointer, name pointer)
 
   ~   If we have an alternate, we want to run that now, regardless of what