fix core and core-ext impl to pass all tests

5 files changed, 43 insertions, 44 deletions

diff --git a/forth/core-ext.fth b/forth/core-ext.fth
index 9dab169..83dd666 100644
--- a/forth/core-ext.fth
+++ b/forth/core-ext.fth
@@ -21,21 +21,23 @@
 : \         _source @ >in @ +
             begin dup c@ while 0 over c! char+ repeat drop ; imm
 : again     postpone repeat ; imm
-: ?do       ['] 2dup , ['] _lit , here 0 , ['] >r , ['] = , postpone if
-            ['] 2drop , postpone 2r> ['] drop , ['] >r , ['] leave ,
-            postpone then postpone 2>r here ; imm
+
+: ?do       ['] _lit , here 0 , ['] >r , ['] 2dup , postpone 2>r
+            ['] = , postpone if postpone leave postpone then
+            here ; imm
 
 : .(        [char] ) word count type ; imm
 : c"        state @ if ['] _jmp , here 0 , then
             [char] " word
             state @ 0= if exit then
-            dup count nip allot
+            dup count nip 1+ allot
             here rot !
             postpone literal ; imm
 
 : buffer:   create allot ;
 : value     constant ;
 : to        ' 4 cells + state @ if postpone literal ['] ! , else ! then ; imm
+
 : defer     create does> @ execute ;
 : defer@    >body @ ;
 : defer!    >body ! ;
@@ -48,11 +50,10 @@
 : marker   here _latest @ create , , does>
            dup @ _latest ! cell+ @ here - allot ;
 
-: case     ['] _lit , 1 here 0 , ['] drop , ; imm
-: of       ['] over , ['] = , postpone if ; imm
-: endof    ['] _jmp , here >r 0 , postpone then
-           swap 1+ swap r> tuck ! ; imm
-: endcase  swap 0 do dup @ swap here swap ! loop drop ['] drop , ; imm
+: case      0 ; imm
+: of        ['] over , ['] = , postpone if ['] drop , ; imm
+: endof     postpone else ; imm
+: endcase   ['] drop , begin ?dup while postpone then repeat ; imm
 
 : holds    begin dup while 1- 2dup + c@ hold repeat 2drop ;
 
diff --git a/forth/core.fth b/forth/core.fth
index 90a8577..c5cd8f4 100644
--- a/forth/core.fth
+++ b/forth/core.fth
@@ -21,13 +21,22 @@
 : base     0 ;
 : here     1 cells @ ;
 : allot    1 cells +! ;
+
+: c!       0 _! ;
+: c@       0 _@ ;
+: c,       here c! 1 allot ;
+: char+    1+ ;
+: chars    ;
+
 : _latest  2 cells ;
 : imm      _latest @ dup @ 1 5 << | swap ! ;
 : immediate imm ;
 : state    3 cells ;
-: _source  4 cells ;
-: _sourceu 5 cells ;
-: >in      6 cells ;
+: _compxt  4 cells ;
+: _source  5 cells ;
+: _sourceu 6 cells ;
+: >in      7 cells ;
+: _begin   8 cells 80 chars + ;
 
 : ,        here ! 1 cells allot ;
 
@@ -54,12 +63,6 @@
 : 2over    3 pick 3 pick ;
 : 2swap    rot >r rot r> ;
 
-: c!       0 _! ;
-: c@       0 _@ ;
-: c,       here c! 1 allot ;
-: char+    1+ ;
-: chars    ;
-
 : decimal  10 base ! ;
 
 : 2r>      ['] r> , ['] r> , ['] swap , ; imm
@@ -82,23 +85,22 @@
 
 : do       ['] _lit , here 0 , ['] >r , postpone 2>r here ; imm
 : unloop   postpone 2r> ['] 2drop , ['] r> , ['] drop , ; imm
-: leave    postpone 2r> ['] 2drop , postpone 2r>
-           ['] drop , ['] >r , ['] exit , ; imm
+: leave    postpone 2r> ['] 2drop , ['] exit , ; imm
 : +loop    ['] r> , ['] 2dup , ['] + ,
            postpone r@ ['] swap , ['] >r ,
            ['] - , ['] 2dup , ['] + , ['] over , ['] ^ ,
            ['] rot , ['] rot , ['] ^ , ['] & , ['] _lit , 0 ,
            ['] < , ['] _jmp0 , ,
-           postpone unloop here swap ! ; imm
+           postpone unloop here 1 cells - swap ! ; imm
 : loop     postpone 2r> ['] 1+ , ['] 2dup ,
            postpone 2>r ['] = , ['] _jmp0 , ,
-           postpone unloop here swap ! ; imm
+           postpone unloop here 1 cells - swap ! ; imm
 : i        postpone r@ ; imm 
 : j        postpone 2r> ['] r> , postpone r@ ['] swap ,
            ['] >r , ['] -rot , postpone 2>r ; imm
 
-: align    here 1 cells 1- swap over & if 1 cells swap - allot else drop then ;
 : aligned  dup 1 cells 1- swap over & if 1 cells swap - + else drop then ;
+: align    here dup aligned swap - allot ;
 
 : and      & ;
 : or       | ;
@@ -155,21 +157,18 @@
            swap postpone literal postpone literal ; imm
 : ."       postpone s" state @ if ['] type , else type then ; imm
 
-: create   align here dup _latest @ - 1 1 cells 8 * 6 - << 1- swap <=
-           dup if -1 6 << , then 0 , >r
-           begin key? if key else bl then dup bl <> while
-           c, 1 over +! repeat drop align
-           ['] _lit , here 3 cells + , ['] exit dup , ,
-           dup _latest @ - r> if
-           over cell+ else 6 << over then +! _latest ! ;
-
-: _does>   _latest @ dup @ 31 & + cell+ aligned 2 cells +
-           ['] _jmp over ! cell+
-           r@ 1 cells - @ swap ! ;
-: does>    ['] _jmp , here 2 cells + dup , 2 cells + ,
-           ['] _does> , ['] exit , ; imm
+: :noname  here dup _compxt ! 0 , here swap ] ;
+
+: create   : here 4 cells + postpone literal postpone ; 0 , ;
 : >body    cell+ @ ;
 
+: _does>   >r _latest @ dup @ 31 & + cell+ aligned 2 cells +
+           ['] _jmp over ! cell+ r> cell+ swap ! ;
+
+: does>    state @ if
+           here 3 cells + postpone literal ['] _does> , ['] exit , else
+           here dup _does> dup _compxt ! 0 , ] then ; imm
+
 : variable create 1 cells allot ;
 : constant create , does> @ ;
 
@@ -179,7 +178,7 @@
            postpone if ['] type , ['] abort ,
            postpone else ['] 2drop , postpone then ; imm
 
-: recurse  depth 1- pick dup @ 31 & + cell+ aligned , ; imm
+: recurse  _compxt @ dup @ 31 & + cell+ aligned , ; imm
 
 : move     dup 0 <= if drop 2drop exit then
            >r 2dup < r> swap if
@@ -198,8 +197,6 @@
            else dup emit rot 2dup c! char+ swap drop swap 1- then
            repeat drop r> - 1 chars / ;
 
-: :noname  here 0 , here swap ] ;
-
 : evaluate _source @ >r _sourceu @ >r >in @ >r
            0 >in ! _sourceu ! _source ! _ev
            r> >in ! r> _sourceu ! r> _source ! ;
diff --git a/forth/tools.fth b/forth/tools.fth
index 3453ae3..8992d48 100644
--- a/forth/tools.fth
+++ b/forth/tools.fth
@@ -3,7 +3,6 @@
 : dump     hex 0 do i cells over + @ s>d <# # # # # bl hold #> type loop
            drop decimal ;
 
-7 cells 80 chars + constant _begin
 : words    _latest @ begin
            dup @ dup 31 &
            2 pick cell+ \ lt l len ws
diff --git a/libalee/corewords.cpp b/libalee/corewords.cpp
index 1a39b7e..6900b45 100644
--- a/libalee/corewords.cpp
+++ b/libalee/corewords.cpp
@@ -155,6 +155,7 @@ execute:
         break;
     case 22: // colon
         state.push(state.dict.alignhere());
+        state.dict.write(Dictionary::CompToken, state.top());
         while (!state.dict.hasInput())
             state.input();
         state.dict.addDefinition(state.dict.input());
diff --git a/libalee/dictionary.hpp b/libalee/dictionary.hpp
index b43ea2e..2b7afdf 100644
--- a/libalee/dictionary.hpp
+++ b/libalee/dictionary.hpp
@@ -47,11 +47,12 @@ public:
     constexpr static Addr Here       = sizeof(Cell);
     constexpr static Addr Latest     = sizeof(Cell) * 2;
     constexpr static Addr Compiling  = sizeof(Cell) * 3;
-    constexpr static Addr Source     = sizeof(Cell) * 4;
-    constexpr static Addr SourceLen  = sizeof(Cell) * 5;
-    constexpr static Addr Input      = sizeof(Cell) * 6; // len data...
+    constexpr static Addr CompToken  = sizeof(Cell) * 4;
+    constexpr static Addr Source     = sizeof(Cell) * 5;
+    constexpr static Addr SourceLen  = sizeof(Cell) * 6;
+    constexpr static Addr Input      = sizeof(Cell) * 7; // len data...
     constexpr static Addr InputCells = 80; // bytes!
-    constexpr static Addr Begin      = sizeof(Cell) * 7 + InputCells;
+    constexpr static Addr Begin      = sizeof(Cell) * 8 + InputCells;
 
     constexpr static Cell Immediate = (1 << 5);