more words, nearing forth2012 conformance

diff --git a/core.fth b/core.fth
index 170edea248485f01589c78e1503f01e397886b7f..8d4789b6a1b2bde235c1f2083fe21d73055fc15d 100644 (file)
--- a/core.fth
+++ b/core.fth
@@ -4,10 +4,6 @@
 : then      here swap ! ; immediate
 : else      ['] _jmp , here 0 , swap here swap ! ; immediate
 
-: 2r>       ['] r> , ['] r> , ['] swap , ; immediate
-: 2>r       ['] swap , ['] >r , ['] >r , ; immediate
-: r@        ['] r> , ['] dup , ['] >r , ; immediate
-
 : _msb      [ 1 cell 8 * 1- lshift ] literal ;
 : 2/        dup 1 rshift swap 0< if _msb or then ;
 
@@ -69,7 +65,18 @@
             dup cell+ allot
             rot here swap !
             swap postpone literal postpone literal then ; immediate
+: ."       postpone s" state @ if postpone type else type then ; immediate
 
 : (         begin [char] ) key = until ; immediate
 
 : execute   [ here 3 cells + ] literal ! [ ' _jmp , 0 , ] ;
+
+: move     dup 0 <= if drop 2drop exit then
+           >r 2dup < r> swap if
+           1- 0 swap do over i + c@ over i + c! -1 +loop
+           else
+           0 do over i + c@ over i + c! loop
+           then 2drop ;
+: fill     -rot begin dup 0 > while
+           >r 2dup c! char+ r> 1- repeat
+           2drop drop ;

diff --git a/main.cpp b/main.cpp
index 06dad34f8dafd409cfbe1b3bf0a0c97a6555996a..b14d9e4b02da8ae6890902021aea6ffa42e80154 100644 (file)
--- a/main.cpp
+++ b/main.cpp
@@ -22,24 +22,31 @@
 #include <span>
 #include <string>
 
-constinit static sforth::forth<2048> forth {sforth::initialize<&forth>()};
+constinit static sforth::forth<4096> forth {sforth::initialize<&forth>()};
 
-constinit static sforth::native_word<".", [](auto) {
+static void putu(sforth::addr v)
+{
     char buf[32] = {};
     auto ptr = buf + sizeof(buf);
-    auto v = forth.pop();
-    bool neg = v < 0;
-    if (neg) v = -v;
     *--ptr = '\0';
     do {
         *--ptr = "0123456789abcdefghijklmnopqrstuvwxyz"[v % forth.base];
     } while (v /= forth.base);
-    if (neg) *--ptr = '-';
     std::cout << ptr << ' ';
+}
+
+constinit static sforth::native_word<".", [](auto) {
+    sforth::addr v = forth.pop();
+    if (v & (1 << (8 * sizeof(sforth::cell) - 1)))
+        std::cout << '-';
+    putu(v);
 }> dot;
+constinit static sforth::native_word<"U.", [](auto) {
+    putu(forth.pop());
+}, &dot> udot;
 constinit static sforth::native_word<"EMIT", [](auto) {
     std::cout << static_cast<char>(forth.pop());
-}, &dot> emit;
+}, &udot> emit;
 constinit static sforth::native_word<"TYPE", [](auto) {
     const unsigned u = forth.pop();
     const auto caddr = reinterpret_cast<const char *>(forth.pop());

diff --git a/sforth/forth.hpp b/sforth/forth.hpp
index 6f29be47b8e680f8928f956804b82f87e7e988f3..effba62790ba31c6abe6c2aa2e21c509626da02f 100644 (file)
--- a/sforth/forth.hpp
+++ b/sforth/forth.hpp
@@ -110,7 +110,7 @@ struct forth : public word_list
         return *rp++;
     }
 
-    forth& add(std::string_view name, func entry = nullptr) {
+    auto begin_def(std::string_view name) -> word_base * {
         const auto namesz = (name.size() + 1 + sizeof(cell) - 1) & ~(sizeof(cell) - 1);
         const auto size = (sizeof(word_base) + namesz) / sizeof(cell);
 
@@ -118,12 +118,12 @@ struct forth : public word_list
         //assert<error::dictionary_overflow>(state->here + size < &dictionary.back());
 
         const auto h = std::exchange(here, here + size);
-        next = new (h) word_base (next, namesz);
+        auto def = new (h) word_base (next, namesz);
         std::copy(name.begin(), name.end(),
             std::bit_cast<char *>(h) + sizeof(word_base));
-        if (entry)
-            *here++ = std::bit_cast<cell>(entry);
-        return *this;
+
+        compiling = true;
+        return def;
     }
 
     auto parse() -> std::string_view {
@@ -197,6 +197,8 @@ constexpr auto initialize()
         fthp->ip = fthp->rpop();
     };
 
+    constexpr static func comma = [](auto) { *fthp->here++ = fthp->pop(); };
+
     constexpr static func lit_impl = [](auto) {
         auto ptr = std::bit_cast<cell *>(++fthp->ip);
         fthp->push(*ptr);
@@ -213,6 +215,7 @@ constexpr auto initialize()
         , S{"DEPTH"}, [](auto) { fthp->push(std::distance(fthp->sp, fthp->dstack.end())); }, 0
         , S{"UNUSED"}, [](auto) { fthp->push(sizeof(cell) * std::distance(fthp->here, fthp->dict.end())); }, 0
         , S{"_LIT" }, lit_impl, 0
+        , S{","    }, comma, 0
         , S{"SWAP" }, [](auto) { auto a = fthp->pop(); auto b = fthp->pop(); fthp->push(a, b); }, 0
         , S{"DROP" }, [](auto) { fthp->pop(); }, 0
         , S{"DUP"  }, [](auto) { fthp->push(fthp->top()); }, 0
@@ -260,16 +263,26 @@ constexpr auto initialize()
             addr v = fthp->pop();
             addr w = fthp->pop();
             fthp->push(-(w < v)); }, 0
+        , S{"FIND" }, [](auto) {
+            const auto caddr = std::bit_cast<const char *>(fthp->pop());
+            std::string_view w {caddr + 1, std::bit_cast<unsigned char>(caddr[0])};
+            if (auto g = fthp->get(w); !g.has_value())
+                fthp->push(std::bit_cast<cell>(caddr), 0);
+            else
+                fthp->push(std::bit_cast<cell>((*g)->body()), (*g)->is_immediate() ? 1 : -1); }, 0
         , S{"\'"   }, [](auto) {
             auto w = fthp->parse();
             auto g = fthp->get(w);
             fthp->push(g ? std::bit_cast<cell>((*g)->body()) : 0); }, 0
         , S{":"    }, [](auto) {
             auto w = fthp->parse();
-            fthp->add(w);
-            *fthp->here++ = std::bit_cast<cell>(prologue);
-            fthp->compiling = true; }, 0
-        , S{";"    }, [](auto) { *fthp->here++ = 0; fthp->compiling = false; }, word_base::immediate
+            auto d = std::bit_cast<func *>(fthp->begin_def(w));
+            fthp->rpush(d);
+            *fthp->here++ = std::bit_cast<cell>(prologue); }, 0
+        , S{";"    }, [](auto) {
+            *fthp->here++ = 0;
+            fthp->next = std::bit_cast<word_base *>(fthp->rpop());
+            fthp->compiling = false; }, word_base::immediate
         , S{"\\"   }, [](auto) { fthp->sourcei = std::string_view::npos; }, word_base::immediate
         , S{"CELL" }, [](auto) { fthp->push(sizeof(cell)); }, 0
         , S{"_JMP" }, [](auto) {
@@ -285,7 +298,14 @@ constexpr auto initialize()
             auto w = fthp->parse();
             auto g = fthp->get(w);
             assert<error::word_not_found>(g.has_value());
-            *fthp->here++ = std::bit_cast<cell>((*g)->body()); }, word_base::immediate
+
+            if ((*g)->is_immediate()) {
+                *fthp->here++ = std::bit_cast<cell>((*g)->body());
+            } else {
+                *fthp->here++ = std::bit_cast<cell>(&lit_impl);
+                *fthp->here++ = std::bit_cast<cell>((*g)->body());
+                *fthp->here++ = std::bit_cast<cell>(&comma);
+            } }, word_base::immediate
         , S{"SOURCE"}, [](auto) {
             auto len = 0u;
             while (fthp->source[len])
@@ -298,8 +318,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());
+            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
     >::word;
     constexpr static auto& dict2 = comp_dict<prologue, &dict1
+        , S{"RECURSE"}, S{"R> R> DUP >R SWAP >R >XT ,"}, word_base::immediate
+        , S{">XT"    }, S{"CELL+ DUP @ 127 AND + CELL+"}, 0
         , S{"ALIGN"  }, S{"HERE DUP ALIGNED SWAP - ALLOT"}, 0
         , S{"ALIGNED"}, S{"CELL 1- + CELL 1- INVERT AND"}, 0
         , S{"DECIMAL"}, S{"10 BASE !"}, 0
@@ -309,12 +339,14 @@ constexpr auto initialize()
         , S{"2@"    }, S{"DUP CELL+ @ SWAP @"}, 0
         , S{"C,"    }, S{"HERE C! 1 ALLOT"}, 0
         , S{"EXIT" },  S{"0 ,"}, word_base::immediate
-        , S{","     }, S{"HERE ! CELL ALLOT"}, 0
         , S{"ALLOT" }, S{"DP +!"}, 0
         , S{"+!"    }, S{"DUP >R SWAP R> @ + SWAP !"}, 0
         , S{"2SWAP" }, S{"ROT >R ROT R>"}, 0
         , S{"2DUP"  }, S{"OVER OVER"}, 0
         , S{"2OVER" }, S{"3 PICK 3 PICK"}, 0
+        , S{"2R>"   }, S{"R> R> R> ROT >R SWAP"}, 0
+        , S{"2>R"   }, S{"R> -ROT SWAP >R >R >R"}, 0
+        , S{"R@"    }, S{"R> R> DUP >R SWAP >R"}, 0
         , S{">R"    }, S{"RP@ CELL - RP ! RP@ CELL+ @ RP@ ! RP@ CELL+ !"}, 0
         , S{"R>"    }, S{"RP@ @ RP@ CELL+ RP ! RP@ @ SWAP RP@ !"}, 0
         , S{"OVER"  }, S{"1 PICK"}, 0

diff --git a/sforth/types.hpp b/sforth/types.hpp
index ade5d4b194f50d88f0249c29e1f34786f188972d..7950664049365929b0c27883d0e2db6e2cf68f51 100644 (file)
--- a/sforth/types.hpp
+++ b/sforth/types.hpp
@@ -123,6 +123,10 @@ struct word_base : public word_list
     constexpr void make_immediate() {
         flags_len |= immediate;
     }
+
+    constexpr bool is_immediate() const {
+        return flags_len & immediate;
+    }
 };
 
 std::optional<const word_base *> word_list::get(std::string_view sv) const