/// sforth, an implementation of forth /// Copyright (C) 2024 Clyne Sullivan /// /// This program is free software: you can redistribute it and/or modify it /// under the terms of the GNU General Public License as published by the Free /// Software Foundation, either version 3 of the License, or (at your option) /// any later version. /// /// This program is distributed in the hope that it will be useful, but WITHOUT /// ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or /// FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for /// more details. /// /// You should have received a copy of the GNU General Public License along /// with this program. If not, see . #ifndef SFORTH_HPP #define SFORTH_HPP #include #include #include #include #include #include #include #include #include #include #include using cell = std::intptr_t; using addr = std::uintptr_t; using func = void (*)(const void *); struct word_base; struct word_list { const word_base *next; constexpr word_list(const word_base *n = nullptr): next{n} {} std::optional get(std::string_view sv) const; static constexpr auto parse(const char *source, std::size_t& sourcei) -> std::string_view { const std::string_view sv {source}; const auto e = sv.find_first_of(" \t\r\n", sourcei); const auto word = e != std::string_view::npos ? sv.substr(sourcei, e - sourcei) : sv.substr(sourcei); sourcei = sv.find_first_not_of(" \t\r\n", e); return word; } }; struct word_base : public word_list { static constexpr addr immediate = 1 << 8; addr flags_len; constexpr word_base(const word_base *n, addr fl): word_list{n}, flags_len{fl} {} std::string_view name() const { return {std::bit_cast(this + 1)}; } const func *body() const { const auto ptr = std::bit_cast(this + 1); const auto fptr = ptr + (flags_len & 0xFF); return std::bit_cast(fptr); } constexpr void make_immediate() { flags_len |= immediate; } }; template struct cS { char data[N]; consteval cS(const char (&s)[N]) { std::copy(s, s + N, data); } consteval operator const char *() const { return data; } consteval auto size() const { return N; } }; struct forth : public word_list { static constexpr bool enable_exceptions = true; static constexpr int data_size = 16; static constexpr int return_size = 16; static constexpr auto npos = std::string_view::npos; enum class error { init_error, parse_error, execute_error, dictionary_overflow, word_not_found, stack_underflow, stack_overflow, return_stack_underflow, return_stack_overflow, compile_only_word }; template static inline void assert(bool condition) { if constexpr (enable_exceptions) { if (!condition) throw Err; } } void push(cell v) { assert(sp != dstack.begin()); *--sp = v; } void push(cell v, auto... vs) { push(v); (push(vs), ...); } void rpush(func *v) { assert(rp != rstack.begin()); *--rp = v; } cell& top() { assert(sp != dstack.end()); return *sp; } cell pop() { assert(sp != dstack.end()); return *sp++; } auto rpop() -> func * { assert(rp != rstack.end()); return *rp++; } template auto pop() { static_assert(N > 0, "pop() with N <= 0"); auto t = std::tuple {pop()}; if constexpr (N > 1) return std::tuple_cat(t, pop()); else return t; } forth& add(std::string_view name, func entry = nullptr) { const auto namesz = (name.size() + 1 + sizeof(cell) - 1) & ~(sizeof(cell) - 1); const auto size = (sizeof(word_base) + namesz) / sizeof(cell); assert(!name.empty()); //assert(state->here + size < &dictionary.back()); const auto h = std::exchange(here, here + size); next = 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; } auto parse() -> std::string_view { return word_list::parse(source, sourcei); } void parse_line(std::string_view sv) { source = sv.data(); sourcei = sv.find_first_not_of(" \t\r\n"); while (sourcei != npos) { const auto word = parse(); if (auto ent = get(word); !ent) { cell n; const auto [p, e] = std::from_chars(word.cbegin(), word.cend(), n, base); assert(e == std::errc() && p == word.cend()); push(n); if (compiling) execute((*get("literal"))->body()); } else { auto body = (*ent)->body(); if (compiling && ((*ent)->flags_len & word_base::immediate) == 0) { *here++ = std::bit_cast(body); } else { execute(body); } } } } void execute(const func *body) { assert(body && *body); (*body)(body); } template static void prologue(const void *bodyf) { static auto& fth = **fthp; auto body = (func *)bodyf; fth.rpush(fth.ip); for (fth.ip = body + 1; *fth.ip; fth.ip++) fth.execute(std::bit_cast(*fth.ip)); fth.ip = fth.rpop(); } template static void initialize(cell *end_value); static auto error_string(error err) noexcept -> std::string_view { using enum error; switch (err) { case init_error: return "init error"; case parse_error: return "parse error"; case execute_error: return "execute error"; case dictionary_overflow: return "dictionary overflow"; case word_not_found: return "word not found"; case stack_underflow: return "stack underflow"; case stack_overflow: return "stack overflow"; case return_stack_underflow: return "return stack underflow"; case return_stack_overflow: return "return stack overflow"; case compile_only_word: return "compile only word"; default: return "unknown error"; } } constexpr forth() { sp = dstack.end(); rp = rstack.end(); } cell *sp; func **rp; func *ip = nullptr; cell *here = std::bit_cast(this + 1); const char *source = nullptr; std::size_t sourcei = npos; cell compiling = false; cell *end = nullptr; cell base = 10; std::array dstack; std::array rstack; }; template struct native_word : public word_base { constexpr static auto N = (sizeof(Name) + sizeof(cell) - 1) & ~(sizeof(cell) - 1); std::array namebuf; func body; consteval const func *get_ct(std::string_view name) const { if (name == std::string_view{Name.data}) return &body; else if constexpr (Prev != nullptr) return Prev->get_ct(name); else return nullptr; } consteval native_word(addr flags = 0): word_base{Prev, N | flags}, namebuf{}, body{Body} { std::copy(Name.data, Name.data + sizeof(Name), namebuf.data()); } }; template struct comp_word : public native_word { static constexpr std::size_t B = [] { std::size_t b = 1; std::string_view sv {Body.data}; auto sourcei = sv.find_first_not_of(" \t\r\n"); while (sourcei != std::string_view::npos) { const auto word = word_list::parse(Body.data, sourcei); b++; if (!Prev->get_ct(word)) b++; } return b; }(); union bodyt { const func *f; cell c; }; std::array bodybuf {}; consteval comp_word(addr flags = 0): native_word{flags} { auto bptr = bodybuf.begin(); std::string_view sv {Body}; auto sourcei = sv.find_first_not_of(" \t\r\n"); while (sourcei != std::string_view::npos) { const auto word = word_list::parse(Body, sourcei); auto w = Prev->get_ct(word); if (w) { bptr->f = Prev->get_ct(word); bptr++; } else { cell n; std::from_chars(word.cbegin(), word.cend(), n, 10); bptr->f = Prev->get_ct("_lit"); bptr++; bptr->c = n; bptr++; } } } }; template struct native_dict { constexpr static native_word::word; else return (const word_base *)nullptr; }()> word {Flags}; }; template struct comp_dict { constexpr static comp_word::word; else return Prev; }()> word {Flags}; }; std::optional word_list::get(std::string_view sv) const { for (auto lt = next; lt; lt = lt->next) { if (sv == lt->name()) return lt; } return {}; } template void forth::initialize(cell *end_value) { assert(*fthp); static auto& fth = **fthp; static auto _d = std::bit_cast(*fthp); constexpr static func lit_impl = [](auto) { auto ptr = std::bit_cast(++fth.ip); fth.push(*ptr); }; constexpr static auto& dict1 = native_dict< cS{"_d" }, [](auto) { fth.push(_d); }, 0 , cS{"sp" }, [](auto) { fth.push(_d + sizeof(cell)); }, 0 , cS{"rp" }, [](auto) { fth.push(_d + 2 * sizeof(cell)); }, 0 , cS{"ip" }, [](auto) { fth.push(_d + 3 * sizeof(cell)); }, 0 , cS{"dp" }, [](auto) { fth.push(_d + 4 * sizeof(cell)); }, 0 , cS{"state"}, [](auto) { fth.push(_d + 7 * sizeof(cell)); }, 0 , cS{"base" }, [](auto) { fth.push(_d + 9 * sizeof(cell)); }, 0 , cS{"_lit" }, lit_impl, 0 , cS{"swap" }, [](auto) { auto [a, b] = fth.pop<2>(); fth.push(a, b); }, 0 , cS{"drop" }, [](auto) { fth.pop(); }, 0 , cS{"dup" }, [](auto) { fth.push(fth.top()); }, 0 , cS{"rot" }, [](auto) { auto [a, b, c] = fth.pop<3>(); fth.push(b, a, c); }, 0 , cS{"+" }, [](auto) { fth.top() += fth.pop(); }, 0 , cS{"-" }, [](auto) { fth.top() -= fth.pop(); }, 0 , cS{"*" }, [](auto) { fth.top() *= fth.pop(); }, 0 , cS{"/" }, [](auto) { fth.top() /= fth.pop(); }, 0 , cS{"mod" }, [](auto) { fth.top() %= fth.pop(); }, 0 , cS{"and" }, [](auto) { fth.top() &= fth.pop(); }, 0 , cS{"or" }, [](auto) { fth.top() |= fth.pop(); }, 0 , cS{"xor" }, [](auto) { fth.top() ^= fth.pop(); }, 0 , cS{"lshift"}, [](auto) { fth.top() <<= fth.pop(); }, 0 , cS{"rshift"}, [](auto) { fth.top() >>= fth.pop(); }, 0 , cS{"[" }, [](auto) { fth.compiling = false; }, word_base::immediate , cS{"]" }, [](auto) { fth.compiling = true; }, 0 , cS{"immediate"}, [](auto) { const_cast(fth.next)->make_immediate(); }, 0 , cS{"literal"}, [](auto) { //assert(fth.compiling); *fth.here++ = std::bit_cast(&lit_impl); *fth.here++ = fth.pop(); }, word_base::immediate , cS{"@" }, [](auto) { fth.push(*std::bit_cast(fth.pop())); }, 0 , cS{"!" }, [](auto) { auto [p, v] = fth.pop<2>(); *std::bit_cast(p) = v; }, 0 , cS{"c@" }, [](auto) { fth.push(*std::bit_cast(fth.pop())); }, 0 , cS{"c!" }, [](auto) { auto [p, v] = fth.pop<2>(); *std::bit_cast(p) = v; }, 0 , cS{"=" }, [](auto) { auto v = fth.pop(); fth.top() = -(fth.top() == v); }, 0 , cS{"<" }, [](auto) { auto v = fth.pop(); fth.top() = -(fth.top() < v); }, 0 , cS{"\'" }, [](auto) { auto w = fth.parse(); auto g = fth.get(w); fth.push(g ? std::bit_cast((*g)->body()) : 0); }, 0 , cS{":" }, [](auto) { const auto prologue = forth::prologue; auto w = fth.parse(); fth.add(w); *fth.here++ = std::bit_cast(prologue); fth.compiling = true; }, 0 , cS{";" }, [](auto) { *fth.here++ = 0; fth.compiling = false; }, word_base::immediate , cS{"\\" }, [](auto) { fth.sourcei = npos; }, word_base::immediate , cS{"cell" }, [](auto) { fth.push(sizeof(cell)); }, 0 , cS{"_jmp" }, [](auto) { auto ptr = ++fth.ip; fth.ip = *std::bit_cast(ptr) - 1; }, 0 , cS{"_jmp0"}, [](auto) { auto ptr = ++fth.ip; if (fth.pop() == 0) fth.ip = *std::bit_cast(ptr) - 1; }, 0 , cS{"chars"}, [](auto) {}, 0 , cS{"postpone"}, [](auto) { assert(fth.compiling); auto w = fth.parse(); auto g = fth.get(w); assert(g.has_value()); *fth.here++ = std::bit_cast((*g)->body()); }, word_base::immediate >::word; constexpr static auto& dict2 = comp_dict, &dict1 , cS{"align" }, cS{"here dup aligned swap - allot"}, 0 , cS{"aligned"}, cS{"cell 1- + cell 1- invert and"}, 0 , cS{"decimal"}, cS{"10 base !"}, 0 , cS{"hex" }, cS{"16 base !"}, 0 , cS{"<=" }, cS{"2dup < >r = r> or"}, 0 , cS{"2!" }, cS{"swap over ! cell+ !"}, 0 , cS{"2@" }, cS{"dup cell+ @ swap @"}, 0 , cS{"c," }, cS{"here c! 1 allot"}, 0 , cS{"," }, cS{"here ! cell allot"}, 0 , cS{"allot" }, cS{"dp +!"}, 0 , cS{"+!" }, cS{"dup >r swap r> @ + swap !"}, 0 , cS{"2swap" }, cS{"rot >r rot r>"}, 0 , cS{"2dup" }, cS{"over over"}, 0 , cS{"2over" }, cS{"3 pick 3 pick"}, 0 , cS{">r" }, cS{"rp@ cell - rp ! rp@ cell+ @ rp@ ! rp@ cell+ !"}, 0 , cS{"r>" }, cS{"rp@ @ rp@ cell+ rp ! rp@ @ swap rp@ !"}, 0 , cS{"over" }, cS{"1 pick"}, 0 , cS{"pick" }, cS{"cells cell+ sp@ + @"}, 0 , cS{"sp@" }, cS{"sp @"}, 0 , cS{"rp@" }, cS{"rp @ cell+"}, 0 , cS{"here" }, cS{"dp @"}, 0 , cS{"latest"}, cS{"_d @"}, 0 , cS{"1-" }, cS{"1 -" }, 0 , cS{"1+" }, cS{"1 +" }, 0 , cS{"cell+" }, cS{"cell +"}, 0 , cS{"cells" }, cS{"cell *"}, 0 , cS{"char+" }, cS{"1 +" }, 0 , cS{"-rot" }, cS{"rot rot"}, 0 , cS{"2drop" }, cS{"drop drop"}, 0 , cS{"0=" }, cS{"0 ="}, 0 , cS{"0<" }, cS{"0 <"}, 0 , cS{"<>" }, cS{"= 0="}, 0 , cS{">" }, cS{"swap <"}, 0 , cS{"invert"}, cS{"-1 xor"}, 0 , cS{"negate"}, cS{"-1 *"}, 0 , cS{"2*" }, cS{"2 *"}, 0 , cS{"bl" }, cS{"32"}, 0 >::word; fth.next = &dict2; fth.end = end_value; } //static_assert(offsetof(word_base, flags_len) == 1 * sizeof(cell)); //static_assert(offsetof(forth, sp) == 1 * sizeof(cell)); //static_assert(offsetof(forth, rp) == 2 * sizeof(cell)); //static_assert(offsetof(forth, ip) == 3 * sizeof(cell)); //static_assert(offsetof(forth, here) == 4 * sizeof(cell)); //static_assert(offsetof(forth, source) == 5 * sizeof(cell)); //static_assert(offsetof(forth, sourcei) == 6 * sizeof(cell)); //static_assert(offsetof(forth, compiling) == 7 * sizeof(cell)); //static_assert(offsetof(forth, end) == 8 * sizeof(cell)); //static_assert(offsetof(forth, base) == 9 * sizeof(cell)); #endif // SFORTH_HPP