even more forth porting

3 files changed, 52 insertions, 29 deletions

diff --git a/core.fth b/core.fth
index 1091b2d..c996d39 100644
--- a/core.fth
+++ b/core.fth
@@ -1,10 +1,5 @@
-
 : [']       ' postpone literal ; immediate
 
-: if        ['] _jmp0 , here 0 , ; immediate
-: then      here swap ! ; immediate
-: else      ['] _jmp , here 0 , swap here swap ! ; immediate
-
 \ : postpone  _parse _get
 \             dup cell+ @ 256 and if
 \             >xt , else ['] _lit , >xt , ['] , , then ; immediate
@@ -19,8 +14,8 @@
 
 : begin     0 here ; immediate
 : while     swap 1+ swap postpone if -rot ; immediate
-: repeat    ['] _jmp , , if postpone then then ; immediate
-: until     ['] _jmp0 , , drop ; immediate
+: repeat    _jmp , , if postpone then then ; immediate
+: until     _jmp0 , , drop ; immediate
 
 : do        ['] literal , here 0 , ['] >r , postpone 2>r here ; immediate
 : unloop    postpone 2r> ['] 2drop , ['] r> , ['] drop , ; immediate
@@ -29,10 +24,10 @@
             postpone r@ ['] swap , ['] >r ,
             ['] - , ['] 2dup , ['] + , ['] over , ['] xor ,
             ['] rot , ['] rot , ['] xor , ['] and , ['] literal , 0 ,
-            ['] < , ['] _jmp0 , ,
+            ['] < , _jmp0 , ,
             postpone unloop here 1 cells - swap ! ; immediate
 : loop      postpone 2r> ['] 1+ , ['] 2dup ,
-            postpone 2>r ['] = , ['] _jmp0 , ,
+            postpone 2>r ['] = , _jmp0 , ,
             postpone unloop here 1 cells - swap ! ; immediate
 : i         postpone r@ ; immediate
 : j         postpone 2r> ['] r> , postpone r@ ['] swap ,
@@ -42,7 +37,7 @@
 : >body     [ 2 cells ] literal + @ ;
 
 : _does>    latest dup cell+ @ [ 5 cells ] literal + +
-            ['] _jmp over ! cell+ ! ;
+            _jmp over ! cell+ ! ;
 
 : does>     here 4 cells + postpone literal ['] _does> , 0 , ; immediate
 
@@ -64,7 +59,7 @@
 : char      0 here char+ c! bl word char+ c@ ;
 : [char]    char postpone literal ; immediate
 
-: s"        state @ if ['] _jmp , here 0 , then
+: s"        state @ if _jmp , here 0 , then
             [char] " word count
             state @ 0<> if
             dup cell+ allot
@@ -75,7 +70,7 @@
 
 : (         begin [char] ) key = until ; immediate
 
-: execute   [ here 3 cells + ] literal ! [ ' _jmp , 0 , ] ;
+: execute   [ here 3 cells + ] literal ! [ _jmp , 0 , ] ;
 
 : move      dup 0 <= if drop 2drop exit then
             >r 2dup < r> swap if
@@ -87,7 +82,7 @@
             >r 2dup c! char+ r> 1- repeat
             2drop drop ;
 
-: source    tib 0 begin 2dup + c@ while 1+ repeat ;
+: source    tib @ 0 begin 2dup + c@ while 1+ repeat ;
 : find      dup count _get dup if
             nip dup >xt swap cell+ @ 256 and if 1 else -1 then
             then ;
diff --git a/sforth/forth.hpp b/sforth/forth.hpp
index 5dc0d00..64cf50c 100644
--- a/sforth/forth.hpp
+++ b/sforth/forth.hpp
@@ -28,9 +28,12 @@
 #include <string_view>
 #include <utility>
 
+extern bool sforth_debug_hook();
+
 namespace sforth {
 
 constexpr bool enable_exceptions = true;
+constexpr bool enable_debugger = false;
 
 enum class error : int
 {
@@ -198,7 +201,13 @@ struct forth : public word_list
 
     void execute(const func *body) {
         assert<error::execute_error>(body && *body);
-        (*body)(body);
+
+        if constexpr (!enable_debugger) {
+            (*body)(body);
+        } else {
+            if (::sforth_debug_hook())
+                (*body)(body);
+        }
     }
 
     constexpr forth(const word_base *latest):
@@ -243,6 +252,17 @@ constexpr auto initialize()
         fthp->push(*ptr);
     };
 
+    constexpr static func jmp_impl = [](auto){
+        auto ptr = ++fthp->ip;
+        fthp->ip = *std::bit_cast<func **>(ptr) - 1;
+    };
+
+    constexpr static func jmp0_impl = [](auto){
+        auto ptr = ++fthp->ip;
+        if (fthp->pop() == 0)
+            fthp->ip = *std::bit_cast<func **>(ptr) - 1;
+    };
+
     constexpr static auto& dict1 = native_dict<
           S{"_D"   },  [](auto) { fthp->push(std::bit_cast<cell>(fthp)); }, 0
         , S{"DEPTH"},  [](auto) { fthp->push(std::distance(fthp->sp, fthp->dstack.end())); }, 0
@@ -292,13 +312,8 @@ constexpr auto initialize()
             fthp->rpush(d);
             *fthp->here++ = std::bit_cast<cell>(prologue); }, 0
         , S{"CELL" }, [](auto) { fthp->push(sizeof(cell)); }, 0
-        , S{"_JMP" }, [](auto) {
-            auto ptr = ++fthp->ip;
-            fthp->ip = *std::bit_cast<func **>(ptr) - 1; }, 0
-        , S{"_JMP0"}, [](auto) {
-            auto ptr = ++fthp->ip;
-            if (fthp->pop() == 0)
-                fthp->ip = *std::bit_cast<func **>(ptr) - 1; }, 0
+        , S{"_JMP" }, [](auto) { fthp->push(std::bit_cast<cell>(&jmp_impl)); }, 0
+        , S{"_JMP0"}, [](auto) { fthp->push(std::bit_cast<cell>(&jmp0_impl)); }, 0
         , S{"_PARSE"}, [](auto) {
             auto w = fthp->parse();
             fthp->push(std::bit_cast<cell>(w.data()), w.size()); }, 0
@@ -325,17 +340,18 @@ constexpr auto initialize()
                 fthp->push(fthp->source[fthp->sourcei++]);
             else
                 fthp->push(0); }, 0
-        , S{"EVALUATE"}, [](auto) {
-            const auto u = std::bit_cast<addr>(fthp->pop());
+        , S{"_eval"}, [](auto) {
+            const addr u = fthp->pop();
             const auto caddr = std::bit_cast<const char *>(fthp->pop());
-            const auto olds = fthp->source;
-            const auto oldi = fthp->sourcei;
-            fthp->parse_line({caddr, u});
-            fthp->source = olds;
-            fthp->sourcei = oldi; }, 0
+            fthp->parse_line({caddr, u}); }, 0
     >::word;
+
     constexpr static auto& dict2 = comp_dict<prologue, &dict1
         //, S{"*/MOD"  }, S{">R M* R> SM/REM"}, 0
+        , S{"evaluate"}, S{"tib @ >in @ 2>r _eval 2r> >in ! tib !"}, 0
+        , S{"if"     }, S{"_jmp0 , here 0 ,"}, word_base::immediate
+        , S{"then"   }, S{"here swap !"}, word_base::immediate
+        , S{"else"   }, S{"_jmp , here 0 , swap here swap !"}, word_base::immediate
         , S{"*/"     }, S{">R M* D>S R> /"}, 0
         , S{"/MOD"   }, S{"2DUP MOD -ROT /"}, 0
         , S{"RECURSE"}, S{"R> R> DUP >R SWAP >R >XT ,"}, word_base::immediate
@@ -397,7 +413,7 @@ constexpr auto initialize()
         , S{"RP"    }, S{"_D 2 CELLS +"}, 0
         , S{"IP"    }, S{"_D 3 CELLS +"}, 0
         , S{"DP"    }, S{"_D 4 CELLS +"}, 0
-        , S{"TIB"   }, S{"_D 5 CELLS + @"}, 0
+        , S{"TIB"   }, S{"_D 5 CELLS +"}, 0
         , S{">IN"   }, S{"_D 6 CELLS +"}, 0
         , S{"STATE" }, S{"_D 7 CELLS +"}, 0
         , S{"BASE"  }, S{"_D 8 CELLS +"}, 0
diff --git a/sforth/types.hpp b/sforth/types.hpp
index 3cb76ba..06d438b 100644
--- a/sforth/types.hpp
+++ b/sforth/types.hpp
@@ -119,6 +119,8 @@ struct word_list
         sourcei = sv.find_first_not_of(" \t\r\n", e);
         return word;
     }
+
+    std::optional<const word_base *> lookup(auto xt) const;
 };
 
 struct word_base : public word_list
@@ -159,6 +161,16 @@ std::optional<const word_base *> word_list::get(std::string_view sv) const
     return {};
 }
 
+std::optional<const word_base *> word_list::lookup(auto xt) const
+{
+    for (auto lt = next; lt; lt = lt->next) {
+        if (std::bit_cast<addr>(lt->body()) < std::bit_cast<addr>(xt))
+            return lt;
+    }
+
+    return {};
+}
+
 template<unsigned N>
 struct S {
     char data[N];