forth/src/fh_runtime.c

#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",
};


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;

  w = w0;
  call:
  if (!w) { return FH_ERR_INTERNAL; }

  LOG("Run user word: %s", w->name);

  TRY(rs_push(fh, fh->execptr));
  fh->execptr = w->param;

  instr:;
  if (fh->state == FH_STATE_QUIT) {
    /* 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);
  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;
  uint32_t limit, index, index0;

  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("Add postponed word: %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("Exec: native-word \"%s\"", 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("Exec: user-word %s (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:
      if (instr->data == MAGICADDR_UNRESOLVED) {
        LOGE("Encountered unresolved jump!");
        goto end;
      }

      TRY(ds_pop(fh, &val));
      if (0 == val) {
        fh->execptr = instr->data;
      }
      goto instr;

    case FH_INSTR_JUMP:
      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("Exec: %d->%s", 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:
      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:
      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("+LOOP, i=%d, step %d, limit %d", fh->loop_i, val, limit);

      index0 = fh->loop_i;
      fh->loop_i += val;

      LOG("after add: %d", fh->loop_i);

      // FIXME this is probably wrong
      // FIXME yes it actually is wrong
      if (((int32_t)index0 < (int32_t)limit) == ((int32_t)fh->loop_i < (int32_t)limit) && fh->loop_i != limit) { // boundary not crossed, continue
        fh->execptr = instr->data; // go to beginning
      } else {
        // end of loop
        TRY(rs_pop(fh, &limit));
        TRY(fh_loop_unnest(fh));
      }
      goto instr;

    case FH_INSTR_LEAVE:
      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;

      /* special case for strings stored in compile memory */
    case FH_INSTR_ALLOCSTR:
    case FH_INSTR_TYPESTR:
      strl = instr->data;
      if (instr->kind == FH_INSTR_ALLOCSTR) {
        LOG("Exec: alloc-str \"%.*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));
      } else {
        LOG("Exec: type-str \"%.*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_ENDWORD:
      LOG("Exec: word-end");
      TRY(rs_pop(fh, &fh->execptr));
      if (fh->execptr == MAGICADDR_EXEC_INTERACTIVE) {
        LOG("Done running compiled word");
        goto end;
      }
      goto instr;
  }

  end:
  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 (0 == strncasecmp(name, w->name, wordlen) && w->name[wordlen] == 0) {
      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;
}