Trying to build a forth runtime in C
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
forth/src/fh_builtins_meta.c

580 lines
14 KiB

#include "forth_internal.h"
static enum fh_error w_colon(struct fh_thread_s *fh, const struct fh_word_s *w)
{
(void) w;
enum fh_error rv;
ENSURE_STATE(FH_STATE_INTERPRET);
char *wordname = NULL;
size_t namelen = 0;
fh_input_consume_spaces(fh);
TRY(fh_input_read_word(fh, &wordname, &namelen));
LOG("Name: %.*s", namelen, wordname);
fh_setstate(fh, FH_STATE_COMPILE, 0);
uint32_t ptr;
TRY(fh_heap_reserve(fh, DICTWORD_SIZE, &ptr));
struct fh_word_s *new_word = fh_word_at(fh, ptr);
if (!new_word) return FH_ERR_INTERNAL;
new_word->previous = fh->dict_last;
new_word->param = fh->here;
new_word->handler = w_user_word;
strncpy(new_word->name, wordname, namelen);
new_word->name[namelen] = 0;
new_word->flags = WORDFLAG_WORD;
fh->dict_last = ptr;
return FH_OK;
}
static enum fh_error w_forget(struct fh_thread_s *fh, const struct fh_word_s *w)
{
(void) w;
enum fh_error rv;
ENSURE_STATE(FH_STATE_INTERPRET);
char *wordname = NULL;
size_t namelen = 0;
fh_input_consume_spaces(fh);
TRY(fh_input_read_word(fh, &wordname, &namelen));
LOG("Name to forget: %.*s", namelen, wordname);
uint32_t addr;
TRY(fh_find_word(fh, wordname, namelen, &addr));
struct fh_word_s *removedword = fh_word_at(fh, addr);
if (!removedword) return FH_ERR_INTERNAL;
fh->dict_last = removedword->previous;
return FH_OK;
}
static enum fh_error w_postpone(struct fh_thread_s *fh, const struct fh_word_s *w)
{
(void) w;
enum fh_error rv;
ENSURE_STATE(FH_STATE_COMPILE);
char *wordname;
size_t namelen = 0;
fh_input_consume_spaces(fh);
TRY(fh_input_read_word(fh, &wordname, &namelen));
TRY(fh_postpone_word(fh, wordname, namelen));
return FH_OK;
}
static enum fh_error rt_read_value(struct fh_thread_s *fh, const struct fh_word_s *w)
{
enum fh_error rv;
TRY(ds_push(fh, w->param));
return FH_OK;
}
static enum fh_error rt_read_varaddr(struct fh_thread_s *fh, const struct fh_word_s *w)
{
enum fh_error rv;
uint32_t addr = (void *) &w->param - (void *) &fh->heap[0]; // this is ugly
TRY(ds_push(fh, addr));
return FH_OK;
}
static enum fh_error wp_variable(struct fh_thread_s *fh, const struct fh_word_s *w)
{
(void) w;
enum fh_error rv;
bool is_value = w->param == 1;
bool is_const = w->param == 2;
if (is_const && fh->state == FH_STATE_COMPILE) {
uint32_t wordaddr = (void *)w - (void *)&fh->heap[0]; // this is ugly
TRY(fh_put_instr(fh, FH_INSTR_WORD, wordaddr));
return FH_OK;
}
ENSURE_STATE(FH_STATE_INTERPRET);
char *wordname;
size_t namelen = 0;
fh_input_consume_spaces(fh);
TRY(fh_input_read_word(fh, &wordname, &namelen));
uint32_t ptr;
uint32_t value = 0;
if (is_value || is_const) {
TRY(ds_pop(fh, &value));
}
TRY(fh_heap_reserve(fh, DICTWORD_SIZE, &ptr));
struct fh_word_s *new_word = fh_word_at(fh, ptr);
if (!new_word) return FH_ERR_INTERNAL;
new_word->previous = fh->dict_last;
new_word->param = value;
new_word->handler = (is_value || is_const) ? rt_read_value : rt_read_varaddr;
strncpy(new_word->name, wordname, namelen);
new_word->name[namelen] = 0;
new_word->flags = (is_const ? WORDFLAG_CONSTANT : WORDFLAG_VARIABLE) | WORDFLAG_BUILTIN;
if (is_const) {
LOG("Create CONSTANT %s = %d (0x%08x)", new_word->name, value, value);
} else if (is_value) {
LOG("Create VALUE %s = %d (0x%08x)", new_word->name, value, value);
} else {
LOG("Create VARIABLE %s at 0x%08x", new_word->name, ptr); // param field is the first
}
fh->dict_last = ptr;
return FH_OK;
}
static enum fh_error w_to(struct fh_thread_s *fh, const struct fh_word_s *w)
{
(void) w;
enum fh_error rv;
if (fh->state == FH_STATE_INTERPRET) {
uint32_t value;
TRY(ds_pop(fh, &value));
char *wordname;
size_t namelen = 0;
uint32_t waddr;
fh_input_consume_spaces(fh);
TRY(fh_input_read_word(fh, &wordname, &namelen));
TRY(fh_find_word(fh, wordname, namelen, &waddr));
struct fh_word_s *ww = fh_word_at(fh, waddr);
if (!ww) return FH_ERR_INTERNAL;
if (ww->flags & WORDFLAG_WORD) {
LOGE("Cannot assign to dictionary word param field!");
return FH_ERR_NOT_APPLICABLE;
}
if (ww->flags & WORDFLAG_CONSTANT) {
LOGE("Cannot assign to constant!");
return FH_ERR_NOT_APPLICABLE;
}
ww->param = value;
} else if (fh->state == FH_STATE_COMPILE) {
// immediate
char *wordname;
size_t namelen = 0;
uint32_t waddr;
fh_input_consume_spaces(fh);
TRY(fh_input_read_word(fh, &wordname, &namelen));
TRY(fh_find_word(fh, wordname, namelen, &waddr));
TRY(fh_put_instr(fh, FH_INSTR_TO, waddr));
}
return FH_OK;
}
static enum fh_error w_leftbracket(struct fh_thread_s *fh, const struct fh_word_s *w)
{
(void) w;
ENSURE_STATE(FH_STATE_COMPILE);
fh_setstate(fh, FH_STATE_INTERPRET, 0);
return FH_OK;
}
static enum fh_error w_rightbracket(struct fh_thread_s *fh, const struct fh_word_s *w)
{
(void) w;
ENSURE_STATE(FH_STATE_INTERPRET);
fh_setstate(fh, FH_STATE_COMPILE, 0);
return FH_OK;
}
static enum fh_error w_source(struct fh_thread_s *fh, const struct fh_word_s *w)
{
(void) w;
enum fh_error rv;
TRY(ds_push(fh, INPUTBUF_ADDR));
TRY(ds_push(fh, fh->inputlen));
// TRY(ds_push(fh, INPUTBUF_ADDR + fh->inputptr));
// TRY(ds_push(fh, fh->inputlen - fh->inputptr));
return FH_OK;
}
static enum fh_error w_literal(struct fh_thread_s *fh, const struct fh_word_s *w)
{
(void) w;
enum fh_error rv;
ENSURE_STATE(FH_STATE_COMPILE);
uint32_t val;
TRY(ds_pop(fh, &val));
TRY(fh_put_instr(fh, FH_INSTR_NUMBER, val));
return FH_OK;
}
static enum fh_error w_semicolon(struct fh_thread_s *fh, const struct fh_word_s *w0)
{
(void) w0;
enum fh_error rv;
ENSURE_STATE(FH_STATE_COMPILE);
TRY(fh_put_instr(fh, FH_INSTR_ENDWORD, 0));
/* Return to interpret state */
fh_setstate(fh, FH_STATE_INTERPRET, 0);
// XXX if there was another definition previously and it was used in some other compiled function,
// that old implementation will still be called.
return FH_OK;
}
static enum fh_error w_immediate(struct fh_thread_s *fh, const struct fh_word_s *w)
{
(void) w;
enum fh_error rv;
if (fh->dict_last == 0) {
LOGE("Dict is empty, cannot modify previous word!");
return FH_ERR_INVALID_STATE;
}
struct fh_word_s *word = fh_word_at(fh, fh->dict_last);
if (!word) return FH_ERR_INTERNAL;
word->flags |= WORDFLAG_IMMEDIATE;
return FH_OK;
}
static enum fh_error w_backslash(struct fh_thread_s *fh, const struct fh_word_s *w)
{
(void) w;
fh_setsubstate(fh, FH_SUBSTATE_LINE_COMMENT);
return FH_OK;
}
static enum fh_error w_paren(struct fh_thread_s *fh, const struct fh_word_s *w)
{
(void) w;
fh_setsubstate(fh, FH_SUBSTATE_PAREN_COMMENT);
return FH_OK;
}
static enum fh_error wp_char(struct fh_thread_s *fh, const struct fh_word_s *w)
{
(void) w;
enum fh_error rv;
bool bracketed = w->param;
if (bracketed) ENSURE_STATE(FH_STATE_COMPILE);
char *wordname = NULL;
size_t namelen = 0;
fh_input_consume_spaces(fh);
TRY(fh_input_read_word(fh, &wordname, &namelen));
char c = (char) *wordname;
if (bracketed) {
TRY(fh_put_instr(fh, FH_INSTR_NUMBER, c));
} else {
TRY(ds_push(fh, c));
}
return FH_OK;
}
static enum fh_error w_depth(struct fh_thread_s *fh, const struct fh_word_s *w)
{
(void) w;
enum fh_error rv;
TRY(ds_push(fh, fh->data_stack_top));
return FH_OK;
}
static enum fh_error w_unused(struct fh_thread_s *fh, const struct fh_word_s *w)
{
(void) w;
enum fh_error rv;
TRY(ds_push(fh, HEAP_SIZE - fh->here));
return FH_OK;
}
static enum fh_error w_to_in(struct fh_thread_s *fh, const struct fh_word_s *w)
{
(void) w;
enum fh_error rv;
TRY(ds_push(fh, MAGICADDR_INPTR));
return FH_OK;
}
static bool chartest_equals_or_end(char c, void *param)
{
char cc = (char) *(uint32_t *) param;
return c == cc || c == 0;
}
static enum fh_error w_word(struct fh_thread_s *fh, const struct fh_word_s *w)
{
(void) w;
enum fh_error rv;
uint32_t ch;
TRY(ds_pop(fh, &ch));
if (ch > 0xFF) {
LOGE("Char out of ASCII bounds!");
return FH_ERR_NOT_APPLICABLE;
}
fh_input_consume_matching(fh, chartest_equals_or_end, &ch);
char *out;
size_t len;
fh_input_read_delimited(fh, &out, &len, chartest_equals_or_end, &ch);
if (len >= WORDBUF_SIZE) {
LOGE("WORD parsed string too long");
return FH_ERR_NAME_TOO_LONG;
}
fh_store_char(fh, WORDBUF_ADDR, (char) len);
fh_heap_copyptr(fh, WORDBUF_ADDR + 1, out, len);
TRY(ds_push(fh, WORDBUF_ADDR));
return FH_OK;
}
static enum fh_error w_count(struct fh_thread_s *fh, const struct fh_word_s *w)
{
(void) w;
enum fh_error rv;
uint32_t caddr;
TRY(ds_pop(fh, &caddr));
uint8_t len;
TRY(fh_fetch_char(fh, caddr, (char *) &len));
TRY(ds_push(fh, caddr + 1));
TRY(ds_push(fh, len));
return FH_OK;
}
static enum fh_error w_create(struct fh_thread_s *fh, const struct fh_word_s *w)
{
(void) w;
enum fh_error rv;
ENSURE_STATE(FH_STATE_INTERPRET);
char *wordname;
size_t namelen = 0;
fh_input_consume_spaces(fh);
TRY(fh_input_read_word(fh, &wordname, &namelen));
uint32_t ptr;
TRY(fh_heap_reserve(fh, DICTWORD_SIZE, &ptr));
struct fh_word_s *new_word = fh_word_at(fh, ptr);
if (!new_word) return FH_ERR_INTERNAL;
new_word->previous = fh->dict_last;
new_word->param = fh->here;
new_word->handler = rt_read_value;
strncpy(new_word->name, wordname, namelen);
new_word->name[namelen] = 0;
new_word->flags = WORDFLAG_BUILTIN | WORDFLAG_CREATED;
fh->dict_last = ptr;
return FH_OK;
}
static enum fh_error w_find(struct fh_thread_s *fh, const struct fh_word_s *w)
{
(void) w;
enum fh_error rv;
ENSURE_STATE(FH_STATE_INTERPRET);
uint32_t caddr;
TRY(ds_pop(fh, &caddr));
uint8_t len;
TRY(fh_fetch_char(fh, caddr, (char *) &len));
uint32_t addr;
if (FH_OK != fh_find_word(fh, fh_str_at(fh, caddr + 1), len, &addr)) {
/* not found */
TRY(ds_push(fh, caddr));
TRY(ds_push(fh, 0));
return FH_OK;
}
struct fh_word_s *word = fh_word_at(fh, addr);
if (!word) return FH_ERR_INTERNAL;
TRY(ds_push(fh, addr));
TRY(ds_push(fh, (word->flags & WORDFLAG_IMMEDIATE) ? 1 : -1));
return FH_OK;
}
static enum fh_error wp_tick(struct fh_thread_s *fh, const struct fh_word_s *w)
{
(void) w;
enum fh_error rv;
bool bracketed = w->param;
if (bracketed) ENSURE_STATE(FH_STATE_COMPILE);
char *wordname;
size_t namelen = 0;
fh_input_consume_spaces(fh);
TRY(fh_input_read_word(fh, &wordname, &namelen));
uint32_t addr;
if (FH_OK != fh_find_word(fh, wordname, namelen, &addr)) {
LOGE("' %.*s word not found!", (int) namelen, wordname);
return FH_ERR_UNKNOWN_WORD;
}
if (bracketed) {
TRY(fh_put_instr(fh, FH_INSTR_NUMBER, addr));
} else {
TRY(ds_push(fh, addr));
}
return FH_OK;
}
static enum fh_error w_execute(struct fh_thread_s *fh, const struct fh_word_s *w)
{
(void) w;
enum fh_error rv;
uint32_t addr;
TRY(ds_pop(fh, &addr));
if (addr != WORDALIGNED(addr)) {
LOGE("Invalid execution token, address must be aligned!");
return FH_ERR_ILLEGAL_FETCH;
}
struct fh_word_s *word = fh_word_at(fh, addr);
if (!word) {
LOGE("Execute with bad addr");
return FH_ERR_NOT_APPLICABLE;
}
if (!word->handler) {
LOGE("Execute word with no handler");
return FH_ERR_NOT_APPLICABLE;
}
TRY(word->handler(fh, word));
return FH_OK;
}
static enum fh_error w_env_query(struct fh_thread_s *fh, const struct fh_word_s *w)
{
(void) w;
enum fh_error rv;
uint32_t len;
TRY(ds_pop(fh, &len));
uint32_t addr;
TRY(ds_pop(fh, &addr));
const char *str = fh_str_at(fh, addr);
if (!str) {
LOGE("Bad string addr for env query!");
return FH_ERR_NOT_APPLICABLE;
}
LOG("Test environment \"%.*s\"", len, str);
if (EQ(str, "/COUNTED-STRING", len)) {
TRY(ds_push(fh, 255));
TRY(ds_push(fh, 1));
}
else if (EQ(str, "/HOLD", len)) {
TRY(ds_push(fh, WORDBUF_SIZE));
TRY(ds_push(fh, 1));
}
else if (EQ(str, "/PAD", len)) {
TRY(ds_push(fh, MIN_PAD_SIZE));
TRY(ds_push(fh, 1));
}
else if (EQ(str, "ADDRESS-UNIT-BITS", len)) {
TRY(ds_push(fh, 8));
TRY(ds_push(fh, 1));
}
else if (EQ(str, "FLOORED", len)) {
TRY(ds_push(fh, TOBOOL(1))); // FIXME is it?
TRY(ds_push(fh, 1));
}
else if (EQ(str, "MAX-CHAR", len)) {
TRY(ds_push(fh, 255));
TRY(ds_push(fh, 1));
}
else if (EQ(str, "MAX-D", len)) {
// TODO update when double arith is properly implemented
TRY(ds_push(fh, 0));
}
else if (EQ(str, "MAX-UD", len)) {
// TODO update when double arith is properly implemented
TRY(ds_push(fh, 0));
}
else if (EQ(str, "MAX-N", len)) {
TRY(ds_push(fh, 0x7FFFFFFFULL));
TRY(ds_push(fh, 1));
}
else if (EQ(str, "MAX-U", len)) {
TRY(ds_push(fh, 0xFFFFFFFFULL));
TRY(ds_push(fh, 1));
}
else if (EQ(str, "RETURN-STACK-CELLS", len)) {
TRY(ds_push(fh, RETURN_STACK_DEPTH));
TRY(ds_push(fh, 1));
}
else if (EQ(str, "STACK-CELLS", len)) {
TRY(ds_push(fh, DATA_STACK_DEPTH));
TRY(ds_push(fh, 1));
}
else if (EQ(str, "CORE", len)) {
TRY(ds_push(fh, TOBOOL(1)));
TRY(ds_push(fh, 1));
}
else {
TRY(ds_push(fh, 0));
}
return FH_OK;
}
const struct name_and_handler fh_builtins_meta[] = {
{"depth", w_depth, 0, 0},
{"unused", w_unused, 0, 0},
{">in", w_to_in, 0, 0},
{":", w_colon, 0, 0},
{";", w_semicolon, 1, 0},
{"forget", w_forget, 1, 0},
{"\\", w_backslash, 1, 0}, // line comment
{"(", w_paren, 1, 0}, // enclosed comment
{"immediate", w_immediate, 0, 0},
{"postpone", w_postpone, 1, 0},
{"[", w_leftbracket, 1, 0},
{"]", w_rightbracket, 1, 0},
{"source", w_source, 0, 0},
{"literal", w_literal, 1, 0},
{"char", wp_char, 0, 0},
{"[char]", wp_char, 1, 1},
{"to", w_to, 1, 0},
{"variable", wp_variable, 1, 0},
{"value", wp_variable, 1, 1},
{"constant", wp_variable, 1, 2},
{"word", w_word, 0, 0},
{"count", w_count, 0, 0},
{"create", w_create, 0, 0},
{"find", w_find, 0, 0},
{"'", wp_tick, 1, 0},
{"[']", wp_tick, 1, 1},
{"execute", w_execute, 0, 0},
{"environment?", w_env_query, 0, 0},
{ /* end marker */ }
};