#include "forth_internal.h" struct fh_global_s fh_globals = {}; /** State names */ static const char *statenames[FH_STATE_MAX] = { [FH_STATE_INTERPRET] = "INTERPRET", [FH_STATE_COMPILE] = "COMPILE", [FH_STATE_QUIT] = "QUIT", [FH_STATE_SHUTDOWN] = "SHUTDOWN", }; /** State names short */ static const char *stateshort[FH_STATE_MAX] = { [FH_STATE_INTERPRET] = "INT", [FH_STATE_COMPILE] = "COM", [FH_STATE_QUIT] = "QIT", [FH_STATE_SHUTDOWN] = "DIE", }; /** Sub-state names */ const char *substatenames[FH_SUBSTATE_MAX] = { [FH_SUBSTATE_NONE] = "NONE", [FH_SUBSTATE_PAREN_COMMENT] = "PAREN_COMMENT", [FH_SUBSTATE_LINE_COMMENT] = "LINE_COMMENT", [FH_SUBSTATE_EXIT] = "EXIT", [FH_SUBSTATE_SKIP_IF] = "SKIP_IF", }; /** Sub-state names */ static const char *instrnames[FH_INSTR_MAX] = { [FH_INSTR_WORD] = "WORD", [FH_INSTR_NUMBER] = "NUMBER", [FH_INSTR_ENDWORD] = "ENDWORD", [FH_INSTR_ALLOCSTR] = "ALLOCSTR", [FH_INSTR_TYPESTR] = "TYPESTR", [FH_INSTR_JUMP] = "JUMP", [FH_INSTR_JUMPZERO] = "JUMPZERO", [FH_INSTR_LEAVE] = "LEAVE", [FH_INSTR_DO] = "DO", [FH_INSTR_TO] = "TO", [FH_INSTR_DO_QUESTION] = "DO_QUESTION", [FH_INSTR_LOOP] = "LOOP", [FH_INSTR_LOOP_PLUS] = "LOOP_PLUS", [FH_INSTR_POSTPONED_WORD] = "POSTPONED_WORD", [FH_INSTR_ABORTSTR] = "ABORTSTR", [FH_INSTR_ACTIONOF] = "ACTIONOF", [FH_INSTR_ISDEFER] = "ISDEFER", }; void fh_abort(struct fh_thread_s *fh) { fh->data_stack_top = 0; fh_quit(fh); } void fh_drop_to_interactive(struct fh_thread_s *fh) { fh_input_teardown(fh); fh_push_input(fh, fh_create_input_from_filestruct(stdin, NULL)); fh->return_stack_top = 0; fh->execptr = MAGICADDR_EXEC_INTERACTIVE; fh_globals.interactive = 1; fh_setstate(fh, FH_STATE_INTERPRET, 0); } void fh_quit(struct fh_thread_s *fh) { if (fh_globals.interactive || fh_globals.rescue) { fh_drop_to_interactive(fh); fh_setstate(fh, FH_STATE_QUIT, 0); } else { fh_setstate(fh, FH_STATE_SHUTDOWN, 0); } } const char *instr_name(enum fh_instruction_kind kind) { if (kind >= FH_INSTR_MAX) { return "Unknown"; } else { return instrnames[kind]; } } /** Add a word to the dictionary. */ enum fh_error fh_add_word(const struct fh_word_s *w, struct fh_thread_s *fh) { enum fh_error rv; fh_align(fh); uint32_t ptr = fh->here; TRY(fh_heap_put(fh, w, DICTWORD_SIZE)); //LOG("Added word \"%s\" at 0x%08x", w->name, ptr); // thread it onto the linked list struct fh_word_s *word = fh_word_at(fh, ptr); if (!word) { return FH_ERR_INTERNAL; } word->previous = fh->dict_last; fh->dict_last = ptr; return FH_OK; } /** Log current runtime state */ static void showstate(const struct fh_thread_s *fh) { if (fh->substate == 0) { LOG("state -> %s", statenames[fh->state]); } else { LOG("state -> %s.%s", statenames[fh->state], substatenames[fh->substate]); } } /** Set runtime state and sub-state */ void fh_setstate(struct fh_thread_s *fh, enum fh_state state, enum fh_substate substate) { fh->state = state; fh->substate = substate; showstate(fh); } /** Set runtime sub-state (state is unchanged) */ void fh_setsubstate(struct fh_thread_s *fh, enum fh_substate substate) { fh->substate = substate; showstate(fh); } /** Execute a user word */ enum fh_error w_user_word(struct fh_thread_s *fh, const struct fh_word_s *w0) { enum fh_error rv; const struct fh_word_s *w; struct fh_word_s *w2; fh->executing_compiled = 1; w = w0; call: if (!w) { return FH_ERR_INTERNAL; } LOG("\x1b[35mExec: Called user word: %s\x1b[m", w->name); TRY(rs_push(fh, fh->execptr)); fh->execptr = w->param; if ((WORDFLAG_WORD | WORDFLAG_CREATED) == (w->flags & (WORDFLAG_WORD | WORDFLAG_CREATED))) { // push the >BODY addr if this is a CREATE'd word TRY(ds_push(fh, word_addr(fh, w) + DICTWORD_SIZE)); } instr:; if (fh->state == FH_STATE_SHUTDOWN) { return FH_OK; } if (fh->state == FH_STATE_QUIT) { LOG("QUIT word exec"); /* abort or quit was called, return to interactive mode */ fh_setstate(fh, FH_STATE_INTERPRET, FH_SUBSTATE_NONE); return FH_OK; } // make sure it's aligned fh->execptr = WORDALIGNED(fh->execptr); if (fh->execptr == 0 || fh->execptr > fh->here) { LOGE("Bad execptr value 0x%08x", fh->execptr); return FH_ERR_ILLEGAL_FETCH; } const struct fh_instruction_s *instr = fh_instr_at(fh, fh->execptr); if (!instr) { LOGE("Execution pointer out of bounds!"); return FH_ERR_INTERNAL; } fh->execptr += INSTR_SIZE; uint32_t strl; uint32_t val, testval; uint32_t limit, index; LOG("0x%08x: Instr %s, 0x%08x", fh->execptr, instr_name(instr->kind), instr->data); switch (instr->kind) { case FH_INSTR_NUMBER: TRY(ds_push(fh, instr->data)); goto instr; case FH_INSTR_POSTPONED_WORD: //if (fh->state == FH_STATE_COMPILE) { w2 = fh_word_at(fh, instr->data); if (!w2) { LOGE("Postponed bad word addr!"); return FH_ERR_INTERNAL; } if (w2->flags & WORDFLAG_IMMEDIATE) { goto call_w2; // LOG("Call immediate postponed word: %s", w2->name); // if (w2->flags & WORDFLAG_BUILTIN) { // TRY(rs_push(fh, fh->execptr)); // } // TRY(w2->handler(fh, w2)); // if (0 == (w2->flags & WORDFLAG_BUILTIN)) { // TRY(rs_pop(fh, &fh->execptr)); // } } else { LOG("\x1b[35mExec: Add postponed word\x1b[m %s", w2->name); TRY(fh_put_instr(fh, FH_INSTR_WORD, instr->data)); } /*} else { LOGE("Postpone in interpret mode!"); goto end; }*/ goto instr; case FH_INSTR_WORD: w2 = fh_word_at(fh, instr->data); if (!w2) { LOGE("Instr bad word addr!"); return FH_ERR_INTERNAL; } call_w2: if (w2->flags & WORDFLAG_BUILTIN) { LOG("\x1b[35mExec: native-word \"%s\"\x1b[m", w2->name); TRY(w2->handler(fh, w2)); if (fh->substate == FH_SUBSTATE_EXIT) { fh_setsubstate(fh, 0); LOG("Exec: early return"); TRY(rs_pop(fh, &fh->execptr)); if (fh->execptr == MAGICADDR_EXEC_INTERACTIVE) { goto end; } } goto instr; } else { LOG("\x1b[35mExec: user-word %s\x1b[m (CALL)", w2->name); w = fh_word_at(fh, instr->data); if (!w) { LOGE("CALL instr bad word addr!"); return FH_ERR_INTERNAL; } goto call; } case FH_INSTR_JUMPZERO: LOG("\x1b[35mExec: jump if zero -> 0x%08x\x1b[m", instr->data); if (instr->data == MAGICADDR_UNRESOLVED) { LOGE("Encountered unresolved jump!"); goto end; } TRY(ds_pop(fh, &val)); if (0 == val) { LOG("Jumping"); fh->execptr = instr->data; } else { LOG("No jump"); } goto instr; case FH_INSTR_JUMP: LOG("\x1b[35mExec: jump -> 0x%08x\x1b[m", instr->data); if (instr->data == MAGICADDR_UNRESOLVED) { LOGE("Encountered unresolved jump!"); goto end; } fh->execptr = instr->data; goto instr; case FH_INSTR_TO: TRY(ds_pop(fh, &val)); w2 = fh_word_at(fh, instr->data); if (!w2) { LOGE("TO instr bad variable addr!"); return FH_ERR_INTERNAL; } LOG("\x1b[35mExec: %d TO %s\x1b[m", val, w2->name); if (w2->flags & WORDFLAG_CONSTANT) { LOGE("Cannot assign to constant!"); return FH_ERR_ILLEGAL_STORE; } w2->param = val; goto instr; case FH_INSTR_DO: LOG("\x1b[35mExec: do\x1b[m"); TRY(ds_pop(fh, &index)); TRY(ds_pop(fh, &limit)); // just make sure it exists TRY(fh_loop_nest(fh, index)); TRY(rs_push(fh, limit)); goto instr; case FH_INSTR_DO_QUESTION: LOG("\x1b[35mExec: ?do\x1b[m"); if (instr->data == MAGICADDR_UNRESOLVED) { LOGE("Encountered unresolved jump!"); goto end; } TRY(ds_pop(fh, &index)); TRY(ds_pop(fh, &limit)); if (index == limit) { // jump to end fh->execptr = instr->data; } else { TRY(fh_loop_nest(fh, index)); TRY(rs_push(fh, limit)); } goto instr; case FH_INSTR_LOOP_PLUS: TRY(ds_pop(fh, &val)); // fall-through case FH_INSTR_LOOP: if (instr->kind == FH_INSTR_LOOP) { val = 1; } // R: index,limit TRY(rs_peek(fh, &limit)); LOG("\x1b[35mExec: +LOOP\x1b[m, i=%d, step %d, limit %d", fh->loop_i, val, limit); const int32_t vi = (int32_t) val; const int32_t bdr = (int32_t) limit - (int32_t) 1; const int32_t i0 = (int32_t) fh->loop_i; fh->loop_i += val; // this can overflow const int32_t i1 = (int32_t) fh->loop_i; // TODO this can probably be optimized if ( (vi > 0 && i0 <= bdr && i1 > bdr) || (vi > 0 && i0 > 0 && i1 < 0 && (bdr >= i0 || bdr <= i1)) || (vi < 0 && i0 > bdr && i1 <= bdr) || (vi < 0 && i0 < 0 && i1 > 0 && (bdr <= i0 || bdr >= i1)) ) { //LOGE("end of loop"); // end of loop TRY(rs_pop(fh, &limit)); TRY(fh_loop_unnest(fh)); } else { //LOGE("continue loop"); // continue the loop fh->execptr = instr->data; } goto instr; case FH_INSTR_LEAVE: LOG("\x1b[35mExec: leave\x1b[m"); if (instr->data == MAGICADDR_UNRESOLVED) { LOGE("Encountered unresolved jump!"); goto end; } TRY(rs_pop(fh, &limit)); TRY(fh_loop_unnest(fh)); fh->execptr = instr->data; goto instr; case FH_INSTR_OF: LOG("\x1b[35mExec: OF\x1b[m"); if (instr->data == MAGICADDR_UNRESOLVED) { LOGE("Encountered unresolved OF!"); goto end; } TRY(ds_pop(fh, &testval)); TRY(ds_pop(fh, &val)); LOG("Val %d, testval %d", val, testval); if (testval != val) { LOG("No match, go to ENDOF"); TRY(ds_push(fh, val)); fh->execptr = instr->data; } goto instr; case FH_INSTR_ENDCASE: LOG("\x1b[35mExec: ENDCASE\x1b[m"); TRY(ds_pop(fh, &val)); // discard the tested value goto instr; case FH_INSTR_ALLOCSTR: strl = instr->data; LOG("\x1b[35mExec: alloc-str\x1b[m \"%.*s\"", strl, fh_str_at(fh, fh->execptr)); TRY(ds_push(fh, fh->execptr)); // give pointer directly into the definition TRY(ds_push(fh, strl)); fh->execptr += strl; goto instr; case FH_INSTR_ALLOCSTR_C: LOG("\x1b[35mExec: alloc-str-c\x1b[m \"%.*s\", %d", fh->heap[fh->execptr], fh_str_at(fh, fh->execptr + 1), fh->heap[fh->execptr]); TRY(ds_push(fh, fh->execptr)); fh->execptr += instr->data; goto instr; case FH_INSTR_TYPESTR: strl = instr->data; LOG("\x1b[35mExec: type-str\x1b[m \"%.*s\"", strl, fh_str_at(fh, fh->execptr)); FHPRINT("%.*s", (int) strl, fh_str_at(fh, fh->execptr)); fh->execptr += strl; goto instr; case FH_INSTR_ABORTSTR: strl = instr->data; TRY(ds_pop(fh, &val)); LOG("\x1b[35mExec: abort-str\x1b[m \"%.*s\"", strl, fh_str_at(fh, fh->execptr)); if (val != 0) { FHPRINT("%.*s", (int) strl, fh_str_at(fh, fh->execptr)); LOG("ABORTing"); fh_abort(fh); goto end; } fh->execptr += strl; goto instr; case FH_INSTR_ENDWORD: LOG("\x1b[35mExec: word-end\x1b[m"); TRY(rs_pop(fh, &fh->execptr)); if (fh->execptr == MAGICADDR_EXEC_INTERACTIVE) { LOG("Done running compiled word"); goto end; } goto instr; case FH_INSTR_ACTIONOF: LOG("\x1b[35mExec: actionof\x1b[m"); w2 = fh_word_at(fh, instr->data); TRY(ds_push(fh, w2->param)); goto instr; case FH_INSTR_ISDEFER: LOG("\x1b[35mExec: isdefer\x1b[m"); w2 = fh_word_at(fh, instr->data); TRY(ds_pop(fh, &w2->param)); goto instr; default: LOGE("Run handler not implemented for instr opcode %d", instr->kind); return FH_ERR_BAD_OPCODE; } end: fh->executing_compiled = 0; return FH_OK; } /** Initialize a runtime */ enum fh_error fh_init(struct fh_thread_s *fh) { enum fh_error rv; /* Make sure we have a clean state */ memset(fh, 0, sizeof(struct fh_thread_s)); fh->dict_last = MAGICADDR_DICTFIRST; TRY(register_builtin_words(fh)); fh->execptr = MAGICADDR_EXEC_INTERACTIVE; fh->base = 10; return FH_OK; } enum fh_error fh_handle_word(struct fh_thread_s *fh, uint32_t addr) { enum fh_error rv; struct fh_word_s *w = fh_word_at(fh, addr); if (!w) { return FH_ERR_INTERNAL; } if (fh->state == FH_STATE_COMPILE && 0 == (w->flags & WORDFLAG_IMMEDIATE)) { LOG("\x1b[34m[%s] Compile word:\x1b[m %s", stateshort[fh->state], w->name); TRY(fh_put_instr(fh, FH_INSTR_WORD, addr)); } else { /* interpret or immediate in compiled code */ // enum fh_state oldstate = fh->state; // fh_setstate(fh, FH_STATE_INTERPRET, 0); LOG("\x1b[35m[%s] Run word:\x1b[m %s%s", stateshort[fh->state], w->name, (w->flags & WORDFLAG_IMMEDIATE) ? " 'imm" : ""); TRY(w->handler(fh, w)); // if (fh->state == FH_STATE_INTERPRET && fh->substate == FH_SUBSTATE_NONE) { // fh_setstate(fh, oldstate, 0); // } } return FH_OK; } enum fh_error fh_find_word(struct fh_thread_s *fh, const char *name, size_t wordlen, uint32_t *addr_out) { if (name == NULL) { return FH_ERR_UNKNOWN_WORD; } if (wordlen == 0) { wordlen = strlen(name); } uint32_t addr = fh->dict_last; while (addr != MAGICADDR_DICTFIRST) { struct fh_word_s *w = fh_word_at(fh, addr); if (!w) { break; } if (EQ(name, w->name, wordlen) && 0 == (w->flags & WORDFLAG_HIDDEN)) { // skip hidden names if (addr_out) { *addr_out = addr; } return FH_OK; } addr = w->previous; } // no log message, this can be OK - e.g. parsing a number //LOG("fail to find word %.*s", wordlen, name); return FH_ERR_UNKNOWN_WORD; } enum fh_error fh_loop_nest(struct fh_thread_s *fh, uint32_t indexvalue) { enum fh_error rv; LOG("Loop nest"); TRY(rs_push(fh, fh->loop_j)); fh->loop_j = fh->loop_i; fh->loop_i = indexvalue; return FH_OK; } enum fh_error fh_loop_unnest(struct fh_thread_s *fh) { enum fh_error rv; LOG("Loop un-nest"); fh->loop_i = fh->loop_j; TRY(rs_pop(fh, &fh->loop_j)); return FH_OK; } /** Postpone a word */ enum fh_error fh_postpone_word( struct fh_thread_s *fh, const char *name, const size_t wordlen ) { enum fh_error rv; uint32_t wadr; TRY(fh_find_word(fh, name, wordlen, &wadr)); LOG("Postpone word"); TRY(fh_put_instr(fh, FH_INSTR_POSTPONED_WORD, wadr)); return FH_OK; }