clyne
/
sforth
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

even more forth porting

Browse Source
llvm
Clyne 3 weeks ago
parent 8a6503cd7f
commit f8fdc3746c
Signed by: clyne
GPG Key ID: 7BA5A2980566A649
3 changed files with 52 additions and 29 deletions
Show Stats Download Patch File Download Diff File

21
core.fth
Unescape Escape View File

@ -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 ;

46
sforth/forth.hpp
Unescape Escape View File

@ -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);
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

12
sforth/types.hpp
Unescape Escape View File

@ -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];

Write Preview
Loading…
Cancel
Save