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 #include +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(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(ptr) - 1; + }; + + constexpr static func jmp0_impl = [](auto){ + auto ptr = ++fthp->ip; + if (fthp->pop() == 0) + fthp->ip = *std::bit_cast(ptr) - 1; + }; + constexpr static auto& dict1 = native_dict< S{"_D" }, [](auto) { fthp->push(std::bit_cast(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(prologue); }, 0 , S{"CELL" }, [](auto) { fthp->push(sizeof(cell)); }, 0 - , S{"_JMP" }, [](auto) { - auto ptr = ++fthp->ip; - fthp->ip = *std::bit_cast(ptr) - 1; }, 0 - , S{"_JMP0"}, [](auto) { - auto ptr = ++fthp->ip; - if (fthp->pop() == 0) - fthp->ip = *std::bit_cast(ptr) - 1; }, 0 + , S{"_JMP" }, [](auto) { fthp->push(std::bit_cast(&jmp_impl)); }, 0 + , S{"_JMP0"}, [](auto) { fthp->push(std::bit_cast(&jmp0_impl)); }, 0 , S{"_PARSE"}, [](auto) { auto w = fthp->parse(); fthp->push(std::bit_cast(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(fthp->pop()); + , S{"_eval"}, [](auto) { + const addr u = 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 + fthp->parse_line({caddr, u}); }, 0 >::word; + constexpr static auto& dict2 = comp_dictR 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 lookup(auto xt) const; }; struct word_base : public word_list @@ -159,6 +161,16 @@ std::optional word_list::get(std::string_view sv) const return {}; } +std::optional word_list::lookup(auto xt) const +{ + for (auto lt = next; lt; lt = lt->next) { + if (std::bit_cast(lt->body()) < std::bit_cast(xt)) + return lt; + } + + return {}; +} + template struct S { char data[N];