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

literal, postpone to forth and more

Browse Source
llvm
Clyne 3 weeks ago
parent e887550e77
commit 31dd2ee7c8
Signed by: clyne
GPG Key ID: 7BA5A2980566A649
2 changed files with 41 additions and 64 deletions
Show Stats Download Patch File Download Diff File

14
core.fth
Unescape Escape View File

@ -1,8 +1,7 @@
: ['] ' postpone literal ; immediate
\ : postpone _parse _get
\ dup cell+ @ 256 and if
\ >xt , else ['] _lit , >xt , ['] , , then ; immediate
: literal [ ' _lit dup , , ] , , ; immediate
: ['] ' [ ' literal , ] ; immediate
: postpone _parse _get dup cell+ @ 256 and if
>xt , else ['] _lit , >xt , ['] , , then ; immediate
: _msb [ 1 cell 8 * 1- lshift ] literal ;
: 2/ dup 1 rshift swap 0< if _msb or then ;
@ -17,13 +16,13 @@
: repeat _jmp , , if postpone then then ; immediate
: until _jmp0 , , drop ; immediate
: do ['] literal , here 0 , ['] >r , postpone 2>r here ; immediate
: do ['] _lit , here 0 , ['] >r , postpone 2>r here ; immediate
: unloop postpone 2r> ['] 2drop , ['] r> , ['] drop , ; immediate
: leave postpone 2r> ['] 2drop , postpone exit ; immediate
: +loop ['] r> , ['] 2dup , ['] + ,
postpone r@ ['] swap , ['] >r ,
['] - , ['] 2dup , ['] + , ['] over , ['] xor ,
['] rot , ['] rot , ['] xor , ['] and , ['] literal , 0 ,
['] rot , ['] rot , ['] xor , ['] and , ['] _lit , 0 ,
['] < , _jmp0 , ,
postpone unloop here 1 cells - swap ! ; immediate
: loop postpone 2r> ['] 1+ , ['] 2dup ,
@ -48,6 +47,7 @@
: space bl emit ;
: spaces begin dup 0 > while space 1- repeat drop ;
: key >in @ 0< if 0 else tib @ >in @ + c@ 1 >in +! then ;
: word 0 here c! begin \ bl
key 2dup <> \ bl key <>
over 0<> and while \ bl key

91
sforth/forth.hpp
Unescape Escape View File

@ -158,10 +158,14 @@ struct forth : public word_list
return *rp++;
}
void comma(CellSized auto v) {
void comma1(CellSized auto v) {
*here++ = std::bit_cast<cell>(v);
}
void comma(CellSized auto... vs) {
(comma1(vs), ...);
}
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);
@ -196,10 +200,13 @@ struct forth : public word_list
const auto n = from_chars<cell>(word, base);
assert<error::word_not_found>(n.has_value());
push(*n);
if (compiling)
execute((*get("LITERAL"))->body());
if (compiling) {
comma((*get("_LIT"))->body());
comma(*n);
} else {
push(*n);
}
} else {
auto body = (*ent)->body();
@ -261,8 +268,6 @@ constexpr auto initialize()
fthp->ip = fthp->rpop();
};
constexpr static func comma = [](auto) { *fthp->here++ = fthp->pop(); };
constexpr static func lit_impl = [](auto) {
fthp->push(*++fthp->ip);
};
@ -280,37 +285,30 @@ constexpr auto initialize()
constexpr static auto& dict1 = native_dict<
S{"_D" }, [](auto) { fthp->push(fthp); }, 0
, S{"CELL" }, [](auto) { fthp->push(sizeof(cell)); }, 0
, S{"_JMP" }, [](auto) { fthp->push(&jmp_impl); }, 0
, S{"_JMP0"}, [](auto) { fthp->push(&jmp0_impl); }, 0
, 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{"_END" }, [](auto) { fthp->push(fthp->dict.end()); }, 0
, S{"_LIT" }, lit_impl, 0 // required by parser
, S{"SWAP" }, [](auto) { auto a = fthp->pop(); auto b = fthp->pop(); fthp->push(a, b); }, 0
, S{"+" }, [](auto) { fthp->top() += fthp->pop(); }, 0
, S{"-" }, [](auto) { fthp->top() -= fthp->pop(); }, 0
, S{"*" }, [](auto) { fthp->top() *= fthp->pop(); }, 0
, S{"/" }, [](auto) { fthp->top() /= fthp->pop(); }, 0
, S{"MOD" }, [](auto) { fthp->top() %= fthp->pop(); }, 0
, S{"AND" }, [](auto) { fthp->top() &= fthp->pop(); }, 0
, S{"OR" }, [](auto) { fthp->top() |= fthp->pop(); }, 0
, S{"XOR" }, [](auto) { fthp->top() ^= fthp->pop(); }, 0
, S{"SWAP" }, [](auto) { auto a = fthp->pop(); fthp->push(a, fthp->pop()); }, 0
, S{"+" }, [](auto) { fthp->top() += fthp->pop(); }, 0
, S{"-" }, [](auto) { fthp->top() -= fthp->pop(); }, 0
, S{"*" }, [](auto) { fthp->top() *= fthp->pop(); }, 0
, S{"/" }, [](auto) { fthp->top() /= fthp->pop(); }, 0
, S{"MOD" }, [](auto) { fthp->top() %= fthp->pop(); }, 0
, S{"AND" }, [](auto) { fthp->top() &= fthp->pop(); }, 0
, S{"OR" }, [](auto) { fthp->top() |= fthp->pop(); }, 0
, S{"XOR" }, [](auto) { fthp->top() ^= fthp->pop(); }, 0
, S{"LSHIFT"}, [](auto) { fthp->top() <<= fthp->pop(); }, 0
, S{"RSHIFT"}, [](auto) {
const auto shift = fthp->pop();
fthp->push(fthp->template pop<addr>() >> shift); }, 0
, S{"RSHIFT"}, [](auto) { fthp->template top<addr>() >>= fthp->pop(); }, 0
, S{"M*" }, [](auto) {
dcell a = fthp->pop();
a *= fthp->pop();
dcell a = fthp->pop(); a *= fthp->pop();
fthp->push(a, a >> (8 * sizeof(cell))); }, 0
, S{"UM*" }, [](auto) {
daddr a = fthp->template pop<addr>();
a *= fthp->template pop<addr>();
fthp->push(a, a >> (8 * sizeof(addr))); }, 0
, S{"LITERAL"}, [](auto x) {
if (fthp->compiling) {
fthp->comma(&lit_impl);
fthp->comma(fthp->pop());
} else {
lit_impl(x);
} }, word_base::immediate
, S{"@" }, [](auto) { fthp->top() = *fthp->template top<cell *>(); }, 0
, S{"!" }, [](auto) { auto p = fthp->template pop<cell *>(); *p = fthp->pop(); }, 0
, S{"C@" }, [](auto) { fthp->top() = *fthp->template top<char *>(); }, 0
@ -318,51 +316,30 @@ constexpr auto initialize()
, S{"=" }, [](auto) { auto v = fthp->pop(); fthp->top() = -(fthp->top() == v); }, 0
, S{"<" }, [](auto) { auto v = fthp->pop(); fthp->top() = -(fthp->top() < v); }, 0
, S{"U<" }, [](auto) {
const auto v = fthp->template pop<addr>();
const auto w = fthp->template pop<addr>();
auto v = fthp->template pop<addr>();
auto w = fthp->template pop<addr>();
fthp->push(-(w < v)); }, 0
, S{":" }, [](auto) {
auto w = fthp->parse();
auto d = std::bit_cast<func *>(fthp->begin_def(w));
fthp->rpush(d);
fthp->comma(prologue); }, 0
, S{"CELL" }, [](auto) { fthp->push(sizeof(cell)); }, 0
, S{"_JMP" }, [](auto) { fthp->push(&jmp_impl); }, 0
, S{"_JMP0"}, [](auto) { fthp->push(&jmp0_impl); }, 0
, S{"_PARSE"}, [](auto) {
auto w = fthp->parse();
fthp->push(w.data(), w.size()); }, 0
auto w = fthp->parse(); fthp->push(w.data(), w.size()); }, 0
, S{"_GET"}, [](auto) {
const auto u = fthp->template pop<addr>();
const auto caddr = fthp->template pop<const char *>();
auto u = fthp->template pop<addr>();
auto caddr = fthp->template pop<char *>();
auto g = fthp->get({caddr, u});
fthp->push(g.has_value() ? *g : nullptr); }, 0
, S{"POSTPONE"}, [](auto) {
fthp->template assert<error::compile_only_word>(fthp->compiling);
auto w = fthp->parse();
auto g = fthp->get(w);
fthp->template assert<error::word_not_found>(g.has_value());
if ((*g)->is_immediate()) {
fthp->comma((*g)->body());
} else {
fthp->comma(&lit_impl);
fthp->comma((*g)->body());
fthp->comma(&comma);
} }, word_base::immediate
, S{"KEY"}, [](auto) {
if (fthp->sourcei != std::string_view::npos)
fthp->push(fthp->source[fthp->sourcei++]);
else
fthp->push(0); }, 0
, S{"_eval"}, [](auto) {
const auto u = fthp->template pop<addr>();
const auto caddr = fthp->template pop<const char *>();
auto u = fthp->template pop<addr>();
auto caddr = fthp->template pop<char *>();
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{"unused" }, S{"_end here -"}, 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

Write Preview
Loading…
Cancel
Save