Make branching more decompilable.

common/boot.fs

@@ -30,16 +30,16 @@ fp@ constant fp0
 : [char] char aliteral ; immediate
 
 ( Core Control Flow )
-: begin   here ; immediate
-: again   ['] branch , , ; immediate
-: until   ['] 0branch , , ; immediate
-: ahead   ['] branch , here 0 , ; immediate
-: then   here swap ! ; immediate
-: if   ['] 0branch , here 0 , ; immediate
-: else   ['] branch , here 0 , swap here swap ! ; immediate
-: while   ['] 0branch , here 0 , swap ; immediate
-: repeat   ['] branch , , here swap ! ; immediate
-: aft   drop ['] branch , here 0 , here swap ; immediate
+create begin ' nop @ ' begin !        : begin   ['] begin , here ; immediate
+create again ' branch @ ' again !     : again   ['] again , , ; immediate
+create until ' 0branch @ ' until !    : until   ['] until , , ; immediate
+create ahead ' branch @ ' ahead !     : ahead   ['] ahead , here 0 , ; immediate
+create then ' nop @ ' then !          : then   ['] then , here swap ! ; immediate
+create if ' 0branch @ ' if !          : if   ['] if , here 0 , ; immediate
+create else ' branch @ ' else !       : else   ['] else , here 0 , swap here swap ! ; immediate
+create while ' 0branch @ ' while !    : while   ['] while , here 0 , swap ; immediate
+create repeat ' branch @ ' repeat !   : repeat   ['] repeat , , here swap ! ; immediate
+create aft ' branch @ ' aft !         : aft   drop ['] aft , here 0 , here swap ; immediate
 
 ( Recursion )
 : recurse   current @ @ aliteral ['] execute , ; immediate
@@ -52,8 +52,8 @@ fp@ constant fp0
 variable nest-depth
 
 ( FOR..NEXT )
-: for   1 nest-depth +! postpone >r postpone begin ; immediate
-: next   -1 nest-depth +! postpone donext , ; immediate
+create for ' >r @ ' for !         : for   1 nest-depth +! ['] for , here ; immediate
+create next ' donext @ ' next !   : next   -1 nest-depth +! ['] next , , ; immediate
 
 ( DO..LOOP )
 variable leaving
@@ -72,7 +72,7 @@ variable leaving
 : +loop ( n -- ) postpone (+loop) postpone until
                  postpone unloop )leaving ; immediate
 : loop   1 aliteral postpone +loop ; immediate
-: i ( -- n ) postpone r@ ; immediate
+create i ' r@ @ ' i !  ( i is same as r@ )
 : j ( -- n ) rp@ 3 cells - @ ;
 : k ( -- n ) rp@ 5 cells - @ ;
 

common/forth_namespace_tests.fs

@@ -483,7 +483,7 @@ e: check-phase2
 
 DEFINED? windows [IF]
 
-e: test-windows-forth-namespace
+e: test-windows-forth-voclist
   internals ' graphics voclist-from
   out: graphics 
   out: ansi 
@@ -492,6 +492,7 @@ e: test-windows-forth-namespace
   out: tasks 
   out: windows 
   out: structures 
+  out: internalized 
   out: internals 
   out: FORTH 
 ;e
@@ -521,7 +522,7 @@ e: test-windows-forth-namespace
 
 [ELSE] DEFINED? posix [IF]
 
-e: test-posix-forth-namespace
+e: test-posix-forth-voclist
   internals ' sockets voclist-from
   out: sockets 
   out: internals 
@@ -533,6 +534,7 @@ e: test-posix-forth-namespace
   out: termios 
   out: posix 
   out: structures 
+  out: internalized 
   out: internals 
   out: FORTH 
 ;e
@@ -567,7 +569,7 @@ e: test-posix-forth-namespace
 
 [ELSE]
 
-e: test-esp32-forth-namespace
+e: test-esp32-forth-voclist
   internals ' ansi voclist-from
   out: ansi 
   out: registers 
@@ -590,6 +592,7 @@ e: test-esp32-forth-namespace
   out: streams 
   out: tasks 
   out: structures 
+  out: internalized 
   out: internals 
   out: FORTH 
 ;e

common/tier0_opcodes.h

@@ -80,6 +80,7 @@ typedef struct {
 } BUILTIN_WORD;
 
 #define TIER0_OPCODE_LIST \
+  YV(internals, NOP, ) \
   X("0=", ZEQUAL, tos = !tos ? -1 : 0) \
   X("0<", ZLESS, tos = (tos|0) < 0 ? -1 : 0) \
   X("+", PLUS, tos += *sp--) \

common/utils.fs

@@ -50,9 +50,9 @@ internals definitions
    dup ['] $@ = if drop ['] s" see.
                    dup @ dup >r >r dup cell+ r> type cell+ r> 1+ aligned +
                    [char] " emit space exit then
-   dup  ['] BRANCH =
-   over ['] 0BRANCH = or
-   over ['] DONEXT = or
+   dup  @ ['] BRANCH @ =
+   over @ ['] 0BRANCH @ = or
+   over @ ['] DONEXT @ = or
        if see. cell+ exit then
    see. ;
 : see-loop   dup >body swap >params 1- cells over +

common/utils_tests.fs

@@ -53,22 +53,40 @@ e: test-see-string
   out: : test  s" hello there" ; 
 ;e
 
-e: test-see-branch
+e: test-see-begin-again
   : test begin again ;
   see test
-  out: : test  BRANCH ; 
+  out: : test  begin again ; 
 ;e
 
-e: test-see-0branch
+e: test-see-begin-until
   : test begin until ;
   see test
-  out: : test  0BRANCH ; 
+  out: : test  begin until ; 
 ;e
 
-e: test-see-fornext
-  : test for next ;
+e: test-see-begin-while-repeat
+  : test begin while repeat ;
   see test
-  out: : test  >R DONEXT ; 
+  out: : test  begin while repeat ; 
+;e
+
+e: test-see-ahead-then
+  : test ahead then ;
+  see test
+  out: : test  ahead then ; 
+;e
+
+e: test-see-for-next
+  : test for i . next ;
+  see test
+  out: : test  for i . next ; 
+;e
+
+e: test-see-for-aft-next
+  : test for aft i . then next ;
+  see test
+  out: : test  for aft i . then next ; 
 ;e
 
 e: test-see-string-strides
@@ -82,23 +100,23 @@ e: test-see-string-strides
   : test7 1 if ." ------>" then ;
   : test8 1 if ." ------->" then ;
   see test0
-  out: : test0  1 0BRANCH s" " type ; 
+  out: : test0  1 if s" " type then ; 
   see test1
-  out: : test1  1 0BRANCH s" >" type ; 
+  out: : test1  1 if s" >" type then ; 
   see test2
-  out: : test2  1 0BRANCH s" ->" type ; 
+  out: : test2  1 if s" ->" type then ; 
   see test3
-  out: : test3  1 0BRANCH s" -->" type ; 
+  out: : test3  1 if s" -->" type then ; 
   see test4
-  out: : test4  1 0BRANCH s" --->" type ; 
+  out: : test4  1 if s" --->" type then ; 
   see test5
-  out: : test5  1 0BRANCH s" ---->" type ; 
+  out: : test5  1 if s" ---->" type then ; 
   see test6
-  out: : test6  1 0BRANCH s" ----->" type ; 
+  out: : test6  1 if s" ----->" type then ; 
   see test7
-  out: : test7  1 0BRANCH s" ------>" type ; 
+  out: : test7  1 if s" ------>" type then ; 
   see test8
-  out: : test8  1 0BRANCH s" ------->" type ; 
+  out: : test8  1 if s" ------->" type then ; 
 ;e
 
 e: test-noname

common/vocabulary.fs

@@ -63,6 +63,15 @@ transfer{
   [SKIP] [SKIP]' raw-ok boot-prompt free.
   $place zplace BUILTIN_MARK
 }transfer
+
+( Move branching opcodes to separate vocabulary )
+vocabulary internalized  internalized definitions
+: cleave   ' >link xt-transfer ;
+cleave begin   cleave again   cleave until
+cleave ahead   cleave then    cleave if
+cleave else    cleave while   cleave repeat
+cleave aft     cleave for     cleave next
+
 forth definitions
 
 ( Make DOES> switch to compile mode when interpreted )