forth/src/fh_builtins_control.c

#include "forth_internal.h"

static enum fh_error w_recurse(struct fh_thread_s *fh, const struct fh_word_s *w)
{
  (void) w;
  enum fh_error rv;
  ENSURE_STATE(FH_STATE_COMPILE);

  TRY(fh_put_instr(fh, FH_INSTR_WORD, fh->dict_last));
  return FH_OK;
}


static enum fh_error w_if(struct fh_thread_s *fh, const struct fh_word_s *w)
{
  (void) w;
  enum fh_error rv;
  ENSURE_STATE(FH_STATE_COMPILE);

  TRY(cs_push(fh, fh->here));
  TRY(fh_put_instr(fh, FH_INSTR_JUMPZERO, MAGICADDR_UNRESOLVED));
  return FH_OK;
}

static enum fh_error w_else(struct fh_thread_s *fh, const struct fh_word_s *w)
{
  (void) w;
  enum fh_error rv;
  ENSURE_STATE(FH_STATE_COMPILE);

  uint32_t ifaddr = 0;
  TRY(cs_pop(fh, &ifaddr));
  struct fh_instruction_s *if_instr = fh_instr_at(fh, ifaddr);
  if (!if_instr || if_instr->data != MAGICADDR_UNRESOLVED) {
    LOGE("IF-ELSE control stack corruption");
    return FH_ERR_INTERNAL;
  }

  if_instr->data = fh->here + INSTR_SIZE;

  TRY(cs_push(fh, fh->here));
  TRY(fh_put_instr(fh, FH_INSTR_JUMP, MAGICADDR_UNRESOLVED));
  return FH_OK;
}

static enum fh_error w_then(struct fh_thread_s *fh, const struct fh_word_s *w)
{
  (void) w;
  enum fh_error rv;
  ENSURE_STATE(FH_STATE_COMPILE);

  uint32_t ifaddr = 0;
  TRY(cs_pop(fh, &ifaddr));
  struct fh_instruction_s *if_instr = fh_instr_at(fh, ifaddr);
  if (!if_instr || if_instr->data != MAGICADDR_UNRESOLVED) {
    LOGE("IF-ELSE control stack corruption");
    return FH_ERR_INTERNAL;
  }

  if_instr->data = fh->here;
  return FH_OK;
}

static enum fh_error w_until(struct fh_thread_s *fh, const struct fh_word_s *w)
{
  (void) w;
  enum fh_error rv;
  ENSURE_STATE(FH_STATE_COMPILE);

  uint32_t destaddr = 0;
  TRY(cs_pop(fh, &destaddr));
  TRY(fh_put_instr(fh, FH_INSTR_JUMPZERO, destaddr));
  return FH_OK;
}

static enum fh_error w_begin(struct fh_thread_s *fh, const struct fh_word_s *w)
{
  (void) w;
  enum fh_error rv;
  ENSURE_STATE(FH_STATE_COMPILE);
  TRY(cs_push(fh, fh->here)); /* dest */
  return FH_OK;
}

static enum fh_error wp_do(struct fh_thread_s *fh, const struct fh_word_s *w)
{
  (void) w;
  enum fh_error rv;
  ENSURE_STATE(FH_STATE_COMPILE);

  TRY(fh_put_instr(fh, w->param ? FH_INSTR_DO_QUESTION : FH_INSTR_DO, MAGICADDR_UNRESOLVED));
  // R will now contain: limit,index

  TRY(cs_push(fh, fh->here)); // mark the start position (after init)
  return FH_OK;
}

static enum fh_error wp_loop(struct fh_thread_s *fh, const struct fh_word_s *w)
{
  (void) w;
  enum fh_error rv;
  struct fh_instruction_s *ii;
  ENSURE_STATE(FH_STATE_COMPILE);

  uint32_t loopendaddr = fh->here;

  uint32_t startaddr;
  TRY(cs_pop(fh, &startaddr));

  TRY(fh_put_instr(fh, w->param ? FH_INSTR_LOOP_PLUS : FH_INSTR_LOOP, startaddr));

  // after the end LOOP
  uint32_t endaddr = fh->here;

  // resolve ?DO dest
  ii = fh_instr_at(fh, startaddr - INSTR_SIZE);
  if (!ii || ii->kind == FH_INSTR_DO_QUESTION && ii->data == MAGICADDR_UNRESOLVED) {
    ii->data = endaddr;
  }

  // Resolve LEAVEs
  while (startaddr < loopendaddr) {
    ii = fh_instr_at(fh, startaddr);
    if (!ii) {
      LOGE("WHAT?");
      return FH_ERR_INTERNAL;
    }
    if (ii->kind == FH_INSTR_LEAVE && ii->data == MAGICADDR_UNRESOLVED) {
      LOG("Resolve leave addr");
      ii->data = endaddr;
    }

    // forward, skipping strings safely
    if (ii->kind == FH_INSTR_TYPESTR || ii->kind == FH_INSTR_ALLOCSTR) {
      startaddr += INSTR_SIZE + ii->data;
      startaddr = WORDALIGNED(startaddr);
    } else {
      startaddr += INSTR_SIZE;
    }
  }

  return FH_OK;
}

static enum fh_error w_unloop(struct fh_thread_s *fh, const struct fh_word_s *w)
{
  (void) w;
  enum fh_error rv;
  uint32_t limit;
  TRY(rs_pop(fh, &limit));
  TRY(fh_loop_unnest(fh));
  return FH_OK;
}

static enum fh_error w_leave(struct fh_thread_s *fh, const struct fh_word_s *w)
{
  (void) w;
  enum fh_error rv;
  ENSURE_STATE(FH_STATE_COMPILE);

  TRY(fh_put_instr(fh, FH_INSTR_LEAVE, MAGICADDR_UNRESOLVED));
  return FH_OK;
}

static enum fh_error w_while(struct fh_thread_s *fh, const struct fh_word_s *w)
{
  (void) w;
  enum fh_error rv;

  ENSURE_STATE(FH_STATE_COMPILE);

  uint32_t destaddr = 0;
  TRY(cs_pop(fh, &destaddr));

  TRY(cs_push(fh, fh->here)); // orig
  TRY(cs_push(fh, destaddr)); // dest

  TRY(fh_put_instr(fh, FH_INSTR_JUMPZERO, MAGICADDR_UNRESOLVED));
  return FH_OK;
}

static enum fh_error w_repeat(struct fh_thread_s *fh, const struct fh_word_s *w)
{
  (void) w;
  enum fh_error rv;

  ENSURE_STATE(FH_STATE_COMPILE);

  uint32_t origaddr = 0;
  uint32_t destaddr = 0;
  TRY(cs_pop(fh, &destaddr));
  TRY(cs_pop(fh, &origaddr));

  struct fh_instruction_s *branch_instr = fh_instr_at(fh, origaddr);
  if (!branch_instr || branch_instr->data != MAGICADDR_UNRESOLVED) {
    LOGE("REPEAT control stack corruption");
    return FH_ERR_INTERNAL;
  }
  branch_instr->data = fh->here + INSTR_SIZE;

  TRY(fh_put_instr(fh, FH_INSTR_JUMP, destaddr));

  return FH_OK;
}

static enum fh_error w_again(struct fh_thread_s *fh, const struct fh_word_s *w)
{
  (void) w;
  enum fh_error rv;

  ENSURE_STATE(FH_STATE_COMPILE);

  uint32_t destaddr = 0;
  TRY(cs_pop(fh, &destaddr));
  TRY(fh_put_instr(fh, FH_INSTR_JUMP, destaddr));

  return FH_OK;
}

static enum fh_error wp_ij(struct fh_thread_s *fh, const struct fh_word_s *w)
{
  enum fh_error rv;
  TRY(ds_push(fh, w->param ? fh->loop_j : fh->loop_i));
  return FH_OK;
}


static enum fh_error w_case(struct fh_thread_s *fh, const struct fh_word_s *w)
{
  (void) w;
  enum fh_error rv;
  TRY(cs_push(fh, fh->here)); // save marker for ENDCASE to resolve all the ENDOF's within
  ENSURE_STATE(FH_STATE_COMPILE);
  return FH_OK;
}

static enum fh_error w_of(struct fh_thread_s *fh, const struct fh_word_s *w)
{
  (void) w;
  enum fh_error rv;
  ENSURE_STATE(FH_STATE_COMPILE);
  TRY(cs_push(fh, fh->here)); // save the marker for ENDOF
  TRY(fh_put_instr(fh, FH_INSTR_OF, MAGICADDR_UNRESOLVED));
  return FH_OK;
}

static enum fh_error w_endof(struct fh_thread_s *fh, const struct fh_word_s *w)
{
  (void) w;
  enum fh_error rv;
  ENSURE_STATE(FH_STATE_COMPILE);
  uint32_t ofaddr;
  TRY(cs_pop(fh, &ofaddr));

  struct fh_instruction_s *of_instr = fh_instr_at(fh, ofaddr);
  if (!of_instr || of_instr->data != MAGICADDR_UNRESOLVED) {
    LOGE("CASE-OF control stack corruption");
    return FH_ERR_INTERNAL;
  }

  of_instr->data = fh->here + INSTR_SIZE; // next

  TRY(fh_put_instr(fh, FH_INSTR_JUMP, MAGICADDR_ENDCASE_UNRESOLVED)); // go to end of CASEs
  return FH_OK;
}

static enum fh_error w_endcase(struct fh_thread_s *fh, const struct fh_word_s *w)
{
  (void) w;
  enum fh_error rv;
  ENSURE_STATE(FH_STATE_COMPILE);
  uint32_t caseaddr;
  TRY(cs_pop(fh, &caseaddr));

  // Now walk the instructions and resolve every MAGICADDR_ENDCASE_UNRESOLVED

  uint32_t caseendaddr = fh->here;
  struct fh_instruction_s *ii;

  // Resolve ENDOF. TODO copied from LOOP impl, unify?
  while (caseaddr < caseendaddr) {
    ii = fh_instr_at(fh, caseaddr);
    if (!ii) {
      LOGE("WHAT?");
      return FH_ERR_INTERNAL;
    }
    if (ii->kind == FH_INSTR_JUMP && ii->data == MAGICADDR_ENDCASE_UNRESOLVED) {
      LOG("Resolve endof jump");
      ii->data = caseendaddr + INSTR_SIZE;
    }

    // forward, skipping strings safely
    if (ii->kind == FH_INSTR_TYPESTR || ii->kind == FH_INSTR_ALLOCSTR) {
      caseaddr += INSTR_SIZE + ii->data;
      caseaddr = WORDALIGNED(caseaddr);
    } else {
      caseaddr += INSTR_SIZE;
    }
  }

  TRY(fh_put_instr(fh, FH_INSTR_ENDCASE, 0));

  return FH_OK;
}

const struct name_and_handler fh_builtins_control[] = {
    {"i",       wp_ij,     0, 0},
    {"j",       wp_ij,     0, 1},
    {"if",      w_if,      1, 0},
    {"else",    w_else,    1, 0},
    {"then",    w_then,    1, 0},
    {"recurse", w_recurse, 1, 0},
    {"do",      wp_do,     1, 0},
    {"?do",     wp_do,     1, 1},
    {"loop",    wp_loop,   1, 0},
    {"leave",   w_leave,   1, 0},
    {"+loop",   wp_loop,   1, 1},
    {"begin",   w_begin,   1, 0},
    {"while",   w_while,   1, 0},
    {"repeat",  w_repeat,  1, 0},
    {"again",   w_again,   1, 0},
    {"until",   w_until,   1, 0},
    {"unloop",  w_unloop,  0, 0},
    {"case",    w_case,    1, 0},
    {"of",      w_of,      1, 0},
    {"endof",   w_endof,   1, 0},
    {"endcase", w_endcase, 1, 0},

    { /* end marker */ }
};