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 : literal [ ' _lit dup , , ] , , ; immediate
: ['] ' [ ' literal , ] ; immediate
\ : postpone _parse _get : postpone _parse _get dup cell+ @ 256 and if
\ dup cell+ @ 256 and if >xt , else ['] _lit , >xt , ['] , , then ; immediate
\ >xt , else ['] _lit , >xt , ['] , , then ; immediate
: _msb [ 1 cell 8 * 1- lshift ] literal ; : _msb [ 1 cell 8 * 1- lshift ] literal ;
: 2/ dup 1 rshift swap 0< if _msb or then ; : 2/ dup 1 rshift swap 0< if _msb or then ;
@ -17,13 +16,13 @@
: repeat _jmp , , if postpone then then ; immediate : repeat _jmp , , if postpone then then ; immediate
: until _jmp0 , , drop ; 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 : unloop postpone 2r> ['] 2drop , ['] r> , ['] drop , ; immediate
: leave postpone 2r> ['] 2drop , postpone exit ; immediate : leave postpone 2r> ['] 2drop , postpone exit ; immediate
: +loop ['] r> , ['] 2dup , ['] + , : +loop ['] r> , ['] 2dup , ['] + ,
postpone r@ ['] swap , ['] >r , postpone r@ ['] swap , ['] >r ,
['] - , ['] 2dup , ['] + , ['] over , ['] xor , ['] - , ['] 2dup , ['] + , ['] over , ['] xor ,
['] rot , ['] rot , ['] xor , ['] and , ['] literal , 0 , ['] rot , ['] rot , ['] xor , ['] and , ['] _lit , 0 ,
['] < , _jmp0 , , ['] < , _jmp0 , ,
postpone unloop here 1 cells - swap ! ; immediate postpone unloop here 1 cells - swap ! ; immediate
: loop postpone 2r> ['] 1+ , ['] 2dup , : loop postpone 2r> ['] 1+ , ['] 2dup ,
@ -48,6 +47,7 @@
: space bl emit ; : space bl emit ;
: spaces begin dup 0 > while space 1- repeat drop ; : 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 : word 0 here c! begin \ bl
key 2dup <> \ bl key <> key 2dup <> \ bl key <>
over 0<> and while \ 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++; return *rp++;
} }
void comma(CellSized auto v) { void comma1(CellSized auto v) {
*here++ = std::bit_cast<cell>(v); *here++ = std::bit_cast<cell>(v);
} }
void comma(CellSized auto... vs) {
(comma1(vs), ...);
}
auto begin_def(std::string_view name) -> word_base * { auto begin_def(std::string_view name) -> word_base * {
const auto namesz = (name.size() + 1 + sizeof(cell) - 1) & ~(sizeof(cell) - 1); const auto namesz = (name.size() + 1 + sizeof(cell) - 1) & ~(sizeof(cell) - 1);
const auto size = (sizeof(word_base) + namesz) / sizeof(cell); 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); const auto n = from_chars<cell>(word, base);
assert<error::word_not_found>(n.has_value()); assert<error::word_not_found>(n.has_value());
push(*n);
if (compiling) if (compiling) {
execute((*get("LITERAL"))->body()); comma((*get("_LIT"))->body());
comma(*n);
} else {
push(*n);
}
} else { } else {
auto body = (*ent)->body(); auto body = (*ent)->body();
@ -261,8 +268,6 @@ constexpr auto initialize()
fthp->ip = fthp->rpop(); fthp->ip = fthp->rpop();
}; };
constexpr static func comma = [](auto) { *fthp->here++ = fthp->pop(); };
constexpr static func lit_impl = [](auto) { constexpr static func lit_impl = [](auto) {
fthp->push(*++fthp->ip); fthp->push(*++fthp->ip);
}; };
@ -280,37 +285,30 @@ constexpr auto initialize()
constexpr static auto& dict1 = native_dict< constexpr static auto& dict1 = native_dict<
S{"_D" }, [](auto) { fthp->push(fthp); }, 0 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{"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{"_LIT" }, lit_impl, 0 // required by parser
, S{"SWAP" }, [](auto) { auto a = fthp->pop(); auto b = fthp->pop(); fthp->push(a, b); }, 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{"*" }, [](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{"MOD" }, [](auto) { fthp->top() %= fthp->pop(); }, 0
, S{"AND" }, [](auto) { fthp->top() &= fthp->pop(); }, 0 , S{"AND" }, [](auto) { fthp->top() &= fthp->pop(); }, 0
, S{"OR" }, [](auto) { fthp->top() |= fthp->pop(); }, 0 , S{"OR" }, [](auto) { fthp->top() |= fthp->pop(); }, 0
, S{"XOR" }, [](auto) { fthp->top() ^= fthp->pop(); }, 0 , S{"XOR" }, [](auto) { fthp->top() ^= fthp->pop(); }, 0
, S{"LSHIFT"}, [](auto) { fthp->top() <<= fthp->pop(); }, 0 , S{"LSHIFT"}, [](auto) { fthp->top() <<= fthp->pop(); }, 0
, S{"RSHIFT"}, [](auto) { , S{"RSHIFT"}, [](auto) { fthp->template top<addr>() >>= fthp->pop(); }, 0
const auto shift = fthp->pop();
fthp->push(fthp->template pop<addr>() >> shift); }, 0
, S{"M*" }, [](auto) { , S{"M*" }, [](auto) {
dcell a = fthp->pop(); dcell a = fthp->pop(); a *= fthp->pop();
a *= fthp->pop();
fthp->push(a, a >> (8 * sizeof(cell))); }, 0 fthp->push(a, a >> (8 * sizeof(cell))); }, 0
, S{"UM*" }, [](auto) { , S{"UM*" }, [](auto) {
daddr a = fthp->template pop<addr>(); daddr a = fthp->template pop<addr>();
a *= fthp->template pop<addr>(); a *= fthp->template pop<addr>();
fthp->push(a, a >> (8 * sizeof(addr))); }, 0 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) { fthp->top() = *fthp->template top<cell *>(); }, 0
, S{"!" }, [](auto) { auto p = fthp->template pop<cell *>(); *p = fthp->pop(); }, 0 , S{"!" }, [](auto) { auto p = fthp->template pop<cell *>(); *p = fthp->pop(); }, 0
, S{"C@" }, [](auto) { fthp->top() = *fthp->template top<char *>(); }, 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{"<" }, [](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) { , S{"U<" }, [](auto) {
const auto v = fthp->template pop<addr>(); auto v = fthp->template pop<addr>();
const auto w = fthp->template pop<addr>(); auto w = fthp->template pop<addr>();
fthp->push(-(w < v)); }, 0 fthp->push(-(w < v)); }, 0
, S{":" }, [](auto) { , S{":" }, [](auto) {
auto w = fthp->parse(); auto w = fthp->parse();
auto d = std::bit_cast<func *>(fthp->begin_def(w)); auto d = std::bit_cast<func *>(fthp->begin_def(w));
fthp->rpush(d); fthp->rpush(d);
fthp->comma(prologue); }, 0 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) { , S{"_PARSE"}, [](auto) {
auto w = fthp->parse(); auto w = fthp->parse(); fthp->push(w.data(), w.size()); }, 0
fthp->push(w.data(), w.size()); }, 0
, S{"_GET"}, [](auto) { , S{"_GET"}, [](auto) {
const auto u = fthp->template pop<addr>(); auto u = fthp->template pop<addr>();
const auto caddr = fthp->template pop<const char *>(); auto caddr = fthp->template pop<char *>();
auto g = fthp->get({caddr, u}); auto g = fthp->get({caddr, u});
fthp->push(g.has_value() ? *g : nullptr); }, 0 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) { , S{"_eval"}, [](auto) {
const auto u = fthp->template pop<addr>(); auto u = fthp->template pop<addr>();
const auto caddr = fthp->template pop<const char *>(); auto caddr = fthp->template pop<char *>();
fthp->parse_line({caddr, u}); }, 0 fthp->parse_line({caddr, u}); }, 0
>::word; >::word;
constexpr static auto& dict2 = comp_dict<prologue, &dict1 constexpr static auto& dict2 = comp_dict<prologue, &dict1
//, S{"*/MOD" }, S{">R M* R> SM/REM"}, 0 //, 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{"evaluate"}, S{"tib @ >in @ 2>r _eval 2r> >in ! tib !"}, 0
, S{"if" }, S{"_jmp0 , here 0 ,"}, word_base::immediate , S{"if" }, S{"_jmp0 , here 0 ,"}, word_base::immediate
, S{"then" }, S{"here swap !"}, word_base::immediate , S{"then" }, S{"here swap !"}, word_base::immediate

Write Preview
Loading…
Cancel
Save