More shuffling.

Makefile

@@ -190,18 +190,19 @@ COMMON_PHASE1 = common/comments.fs \
                 common/structures.fs
 
 COMMON_PHASE1e = common/comments.fs \
-                                    common/tier2_forth.fs \
+                                    common/tier2a_forth.fs \
                  common/boot.fs \
+                                    common/tier2b_forth.fs \
                  common/io.fs \
                  common/conditionals.fs \
                  common/vocabulary.fs \
                  common/floats.fs \
                  common/structures.fs
 
-COMMON_PHASE2 = common/tasks.fs common/utils.fs common/locals.fs \
+COMMON_PHASE2 = common/utils.fs common/locals.fs
-                common/streams.fs
 
-COMMON_FILETOOLS = common/filetools.fs common/including.fs \
+COMMON_FILETOOLS = common/tasks.fs common/streams.fs \
+                   common/filetools.fs common/including.fs \
                    common/blocks.fs
 
 COMMON_DESKTOP = common/ansi.fs common/desktop.fs \

common/boot.fs

@@ -23,16 +23,11 @@ fp@ constant fp0
 : remaining ( -- n ) 'heap-start @ 'heap-size @ + 'heap @ - ;
 : used ( -- n ) 'heap @ sp@ 'stack-cells @ cells + - 28 + ;
 
-( Compilation State )
-: [ 0 state ! ; immediate
-: ] -1 state ! ; immediate
-
 ( Quoting Words )
 : ' bl parse 2dup find dup >r -rot r> 0= 'notfound @ execute 2drop ;
 : ['] ' aliteral ; immediate
 : char bl parse drop c@ ;
 : [char] char aliteral ; immediate
-: literal aliteral ; immediate
 
 ( Core Control Flow )
 : begin   here ; immediate

common/forth_namespace_tests.fs

@@ -121,13 +121,10 @@ e: check-boot
   out: until 
   out: again 
   out: begin 
-  out: literal 
   out: [char] 
   out: char 
   out: ['] 
   out: ' 
-  out: ] 
-  out: [ 
   out: used 
   out: remaining 
   out: fdepth 
@@ -147,7 +144,6 @@ e: check-tier2-opcodes
   out: >link& 
   out: >link 
   out: >name 
-  out: >body 
   out: aligned 
   out: align 
 ;e
@@ -215,6 +211,9 @@ e: check-tier1-opcodes
 ;e
 
 e: check-tier0-opcodes
+  out: [ 
+  out: ] 
+  out: literal 
   out: 0= 
   out: 0< 
   out: + 
@@ -256,6 +255,7 @@ e: check-tier0-opcodes
   out: CONSTANT 
   out: DOES> 
   out: IMMEDIATE 
+  out: >BODY 
   out: : 
   out: EXIT 
   out: ; 
@@ -471,14 +471,14 @@ e: check-filetools
   check-blocks
   check-imports
   check-snapshots
+  out: streams 
+  out: ms 
+  check-tasks
 ;e
 
 e: check-phase2
-  out: streams 
   check-locals
   check-utils
-  out: ms 
-  check-tasks
 ;e
 
 DEFINED? windows [IF]

common/tasks.fs

@@ -14,10 +14,12 @@
 
 ( Cooperative Tasks )
 
-vocabulary tasks   tasks definitions
+vocabulary tasks   tasks definitions also internals
 
 variable task-list
 
+: .tasks   task-list @ begin dup 2 cells - see. @ dup task-list @ = until drop ;
+
 forth definitions tasks also internals
 
 : pause
@@ -51,4 +53,4 @@ DEFINED? ms-ticks [IF]
 
 tasks definitions
 0 0 0 task main-task   main-task start-task
-forth definitions
+only forth definitions

common/tier0_opcodes.h

@@ -145,6 +145,7 @@ typedef struct {
               DROPn(2); COMMA(tos); DROP) \
   X("DOES>", DOES, DOES(ip); ip = (cell_t *) *rp; --rp) \
   Y(IMMEDIATE, DOIMMEDIATE()) \
+  X(">BODY", TOBODY, tos = (cell_t) TOBODY(tos)) \
   XV(internals, "'SYS", SYS, DUP; tos = (cell_t) g_sys) \
   YV(internals, YIELD, PARK; return rp) \
   X(":", COLON, DUP; DUP; tos = parse(32, sp); \

common/tier1_opcodes.h

@@ -81,4 +81,7 @@
   XV(internals, "'argv", ARGV, DUP; tos = (cell_t) &g_sys->argv) \
   XV(internals, "'runner", RUNNER, DUP; tos = (cell_t) &g_sys->runner) \
   Y(context, DUP; tos = (cell_t) (g_sys->context + 1)) \
-  Y(latestxt, DUP; tos = (cell_t) g_sys->latestxt)
+  Y(latestxt, DUP; tos = (cell_t) g_sys->latestxt) \
+  XV(forth_immediate, "[", LBRACKET, g_sys->state = 0) \
+  XV(forth_immediate, "]", RBRACKET, g_sys->state = -1) \
+  YV(forth_immediate, literal, COMMA(g_sys->DOLIT_XT); COMMA(tos); DROP)

common/tier1a_forth.fs

@@ -73,16 +73,5 @@ drop
 ( Compilation State )
 : [ 0 state ! ; immediate
 : ] -1 state ! ; immediate
-: ' bl parse 2dup find dup >r -rot r> 0= 'notfound @ execute 2drop ;
+
 : literal aliteral ; immediate
-
-: f= ( r r -- f ) f- f0= ;
-: f< ( r r -- f ) f- f0< ;
-: f> ( r r -- f ) fswap f< ;
-: f<> ( r r -- f ) f= 0= ;
-: f<= ( r r -- f ) f> 0= ;
-: f>= ( r r -- f ) f< 0= ;
-
-4 constant sfloat
-: sfloats ( n -- n*4 ) sfloat * ;
-: sfloat+ ( a -- a ) sfloat + ;

common/tier2_opcodes.h

@@ -19,7 +19,6 @@
   X(">link&", TOLINKAT, tos = (cell_t) TOLINK(tos)) \
   X(">link", TOLINK, tos = *TOLINK(tos)) \
   X(">name", TONAME, DUP; *sp = (cell_t) TONAME(tos); tos = *TONAMELEN(tos)) \
-  X(">body", TOBODY, tos = (cell_t) TOBODY(tos)) \
   Y(aligned, tos = CELL_ALIGNED(tos)) \
   Y(align, g_sys->heap = (cell_t *) CELL_ALIGNED(g_sys->heap)) \
   YV(internals, fill32, cell_t c = tos; DROP; cell_t n = tos; DROP; \

common/tier2a_forth.fs

@@ -12,6 +12,9 @@
 \ See the License for the specific language governing permissions and
 \ limitations under the License.
 
+: aligned ( a -- a ) cell 1 - dup >r + r> invert and ;
+: align   here aligned here - allot ;
+
 ( Dictionary Format )
 : >flags& ( xt -- a ) cell - ;   : >flags ( xt -- flags ) >flags& c@ ;
 : >name-length ( xt -- n ) >flags& 1+ c@ ;
@@ -19,9 +22,3 @@
 : >size ( xt -- n ) dup >params cells swap >name-length aligned + 3 cells + ;
 : >link& ( xt -- a ) 2 cells - ;   : >link ( xt -- a ) >link& @ ;
 : >name ( xt -- a n ) dup >name-length swap >link& over aligned - swap ;
-: >body ( xt -- a ) dup @ [ ' >flags @ ] literal = 2 + cells + ;
-
-: aligned ( a -- a ) cell 1 - dup >r + r> invert and ;
-: align   here aligned here - allot ;
-
-: fill32 ( a n v ) swap >r swap r> 0 ?do 2dup ! cell+ loop 2drop ;

common/tier2b_forth.fs

@@ -0,0 +1,15 @@
+\ Copyright 2022 Bradley D. Nelson
+\
+\ Licensed under the Apache License, Version 2.0 (the "License");
+\ you may not use this file except in compliance with the License.
+\ You may obtain a copy of the License at
+\
+\     http://www.apache.org/licenses/LICENSE-2.0
+\
+\ Unless required by applicable law or agreed to in writing, software
+\ distributed under the License is distributed on an "AS IS" BASIS,
+\ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+\ See the License for the specific language governing permissions and
+\ limitations under the License.
+
+: fill32 ( a n v ) swap >r swap r> 0 ?do 2dup ! cell+ loop 2drop ;

common/utils.fs

@@ -122,8 +122,3 @@ forth definitions also internals
 : words   0 to line-pos context @ @
           begin dup while ?ins. dup onlines see. >link repeat drop cr ;
 only forth definitions
-
-( Extra Task Utils )
-tasks definitions also internals
-: .tasks   task-list @ begin dup 2 cells - see. @ dup task-list @ = until drop ;
-only forth definitions

web/fini.fs

@@ -18,6 +18,11 @@ transfer internals-builtins
 forth definitions internals
 ( Bring a forth to the top of the vocabulary. )
 : ok   ." uEforth" raw-ok ;
+
+: dummy-type   2drop yield ;  ' dummy-type is type
+: dummy-key   yield 0 ;  ' dummy-key is key
+: dummy-key?   yield 0 ;  ' dummy-key is key?
+
 transfer forth
 forth
 ok

web/fuse_web.js

@@ -139,6 +139,9 @@ cases = ReplaceAll(cases, 'DOES(ip)', 'DOES(ip|0)');
 cases = ReplaceAll(cases, 'PARK;', '');  // TODO
 cases = ReplaceAll(cases, '; ', ';\n            ');
 
+cases = ReplaceAll(cases, 'tos = ((tos) + (*(tos) == OP_DOCREATE || *(tos) == OP_DODOES ? 2 : 1))',
+                          'tos = TOBODY(tos|0)|0');
+
 code = code.replace('{{boot}}', function() { return boot; });
 code = code.replace('{{dict}}', function() { return dict; });
 code = code.replace('{{cases}}', function() { return cases; });

web/web.template.js

@@ -83,7 +83,7 @@ function TONAME(xt) {
     ? u8[TOLINK(xt)] : TOLINK(xt) - CELL_ALIGNED(u8[TONAMELEN(xt)]);
 }
 function TOBODY(xt) {
-  return xt + (i32[xt>>2] === OP_DOCREATE || i32[xt>>2] === OP_DODOES ? 2 : 1);
+  return xt + (i32[xt>>2] === OP_DOCREATE || i32[xt>>2] === OP_DODOES ? 2 : 1) * 4;
 }
 
 function DOES(ip) {
@@ -437,6 +437,7 @@ function VM(stdlib, foreign, heap) {
   var DOES = foreign.DOES;
   var DOIMMEDIATE = foreign.DOIMMEDIATE;
   var UNSMUDGE = foreign.UNSMUDGE;
+  var TOBODY = foreign.TOBODY;
   var create = foreign.create;
   var find = foreign.find;
   var parse = foreign.parse;
@@ -533,6 +534,7 @@ var ffi = {
   'COMMA': function(n) { COMMA(n); },
   'CCOMMA': function(n) { COMMA(n); },
   'SSMOD': function(sp) { SSMOD(sp); },
+  'TOBODY': function(tos) { return TOBODY(tos); },
   'DOES': function(ip) { DOES(ip); },
   'DOIMMEDIATE': function() { DOIMMEDIATE(); },
   'UNSMUDGE': function() { UNSMUDGE(); },
@@ -549,6 +551,7 @@ var module = VM(globalObj, ffi, heap);
 Init();
 setTimeout(function() {
   module.run();
+  console.log('yield');
 }, 10);
 
 })();