From 8df11ef268f050461390d7070cb84d0d72dbfec6 Mon Sep 17 00:00:00 2001 From: Clyne Sullivan Date: Wed, 4 Dec 2024 19:10:39 -0500 Subject: [PATCH] more words, nearing forth2012 conformance --- core.fth | 15 ++++++++++---- main.cpp | 21 ++++++++++++------- sforth/forth.hpp | 54 ++++++++++++++++++++++++++++++++++++++---------- sforth/types.hpp | 4 ++++ 4 files changed, 72 insertions(+), 22 deletions(-) diff --git a/core.fth b/core.fth index 170edea..8d4789b 100644 --- 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 06dad34..b14d9e4 100644 --- a/main.cpp +++ b/main.cpp @@ -22,24 +22,31 @@ #include #include -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(forth.pop()); -}, &dot> emit; +}, &udot> emit; constinit static sforth::native_word<"TYPE", [](auto) { const unsigned u = forth.pop(); const auto caddr = reinterpret_cast(forth.pop()); diff --git a/sforth/forth.hpp b/sforth/forth.hpp index 6f29be4..effba62 100644 --- 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(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(h) + sizeof(word_base)); - if (entry) - *here++ = std::bit_cast(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(++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(fthp->pop()); + std::string_view w {caddr + 1, std::bit_cast(caddr[0])}; + if (auto g = fthp->get(w); !g.has_value()) + fthp->push(std::bit_cast(caddr), 0); + else + fthp->push(std::bit_cast((*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((*g)->body()) : 0); }, 0 , S{":" }, [](auto) { auto w = fthp->parse(); - fthp->add(w); - *fthp->here++ = std::bit_cast(prologue); - fthp->compiling = true; }, 0 - , S{";" }, [](auto) { *fthp->here++ = 0; fthp->compiling = false; }, word_base::immediate + auto d = std::bit_cast(fthp->begin_def(w)); + fthp->rpush(d); + *fthp->here++ = std::bit_cast(prologue); }, 0 + , S{";" }, [](auto) { + *fthp->here++ = 0; + fthp->next = std::bit_cast(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(g.has_value()); - *fthp->here++ = std::bit_cast((*g)->body()); }, word_base::immediate + + if ((*g)->is_immediate()) { + *fthp->here++ = std::bit_cast((*g)->body()); + } else { + *fthp->here++ = std::bit_cast(&lit_impl); + *fthp->here++ = std::bit_cast((*g)->body()); + *fthp->here++ = std::bit_cast(&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(fthp->pop()); + const auto caddr = std::bit_cast(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 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 ade5d4b..7950664 100644 --- 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 word_list::get(std::string_view sv) const