implemented CASE-OF

README.md

@@ -55,7 +55,7 @@ HERE HOLD I IF IMMEDIATE INVERT J LEAVE LITERAL LOOP LSHIFT M* MAX MIN MOD MOVE
 REPEAT ROT RSHIFT S>D S" SIGN SM/REM SOURCE SPACE SPACES STATE SWAP THEN TYPE U. U< UNTIL UM* UM/MOD UNLOOP VARIABLE WHILE WORD XOR [ ['] [CHAR] ] 
 
 CORE-EXT:
-.( :NONAME 0<> 0> 2>R 2R> 2R@ <> ?DO AGAIN FALSE HEX NIP PAD PICK ROLL S\" TO TRUE TUCK U.R U> UNUSED VALUE
+.( :NONAME 0<> 0> 2>R 2R> 2R@ <> ?DO AGAIN BUFFER: CASE ENDCASE ENDOF FALSE HEX HOLDS MARKER NIP OF PAD PICK ROLL S\" TO TRUE TUCK U.R U> UNUSED VALUE WITHIN
 \
 
 Other sets:
@@ -69,8 +69,8 @@ CORE:
 ABORT" ACCEPT EVALUATE KEY
 
 CORE-EXT:
-.R ACTION-OF BUFFER: C" CASE COMPILE, DEFER DEFER! DEFER@ ENDCASE ENDOF ERASE HOLDS IS
-MARKER OF PARSE PARSE-NAME REFILL RESTORE-INPUT SAVE-INPUT SOURCE-ID WITHIN [COMPILE]
+.R ACTION-OF C" COMPILE, DEFER DEFER! DEFER@ ERASE IS
+PARSE PARSE-NAME REFILL RESTORE-INPUT SAVE-INPUT SOURCE-ID [COMPILE]
 ```
 
 .

include/fh_config.h

@@ -32,5 +32,6 @@
 #define MAGICADDR_STATE            0xFFFF57a7ULL
 #define MAGICADDR_INPTR            0xFFFFF175ULL
 #define MAGICADDR_UNRESOLVED       0xFFFFFBADULL
+#define MAGICADDR_ENDCASE_UNRESOLVED 0xFFFC5BADULL
 
 #endif //FORTH_FH_CONFIG_H

include/fh_runtime.h

@@ -44,6 +44,13 @@ enum fh_instruction_kind {
   /* Jump if zero */
   FH_INSTR_JUMPZERO,
 
+  /* Jump if the two elements on stack do not equal, consuming the top one. 
+   * Otherwise consume both and continue. */
+  FH_INSTR_OF,
+
+  /* Endcase, pop the testval from DS */
+  FH_INSTR_ENDCASE,
+
   /* Loop exit */
   FH_INSTR_LEAVE,
 

src/fh_builtins_control.c

@@ -118,6 +118,7 @@ static enum fh_error wp_loop(struct fh_thread_s *fh, const struct fh_word_s *w)
     ii->data = endaddr;
   }
 
+  // Resolve LEAVEs
   while (startaddr < loopendaddr) {
     ii = fh_instr_at(fh, startaddr);
     if (!ii) {
@@ -223,6 +224,86 @@ static enum fh_error wp_ij(struct fh_thread_s *fh, const struct fh_word_s *w)
   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},
@@ -241,6 +322,10 @@ const struct name_and_handler fh_builtins_control[] = {
     {"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 */ }
 };

src/fh_runtime.c

@@ -139,7 +139,7 @@ enum fh_error w_user_word(struct fh_thread_s *fh, const struct fh_word_s *w0)
   fh->execptr += INSTR_SIZE;
 
   uint32_t strl;
-  uint32_t val;
+  uint32_t val, testval;
   uint32_t limit, index;
 
   LOG("0x%08x: Instr %s, 0x%08x", fh->execptr, instr_name(instr->kind), instr->data);
@@ -321,6 +321,29 @@ enum fh_error w_user_word(struct fh_thread_s *fh, const struct fh_word_s *w0)
       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;
+
       /* special case for strings stored in compile memory */
     case FH_INSTR_ALLOCSTR:
     case FH_INSTR_TYPESTR:

src/fh_see.c

@@ -53,6 +53,14 @@ static void show_word(struct fh_thread_s *fh, const struct fh_word_s *w)
             }
             break;
 
+          case FH_INSTR_OF:
+            FHPRINT("OF(value %d / 0x%08x)\n", instr->data, instr->data);
+            break;
+
+          case FH_INSTR_ENDCASE:
+            FHPRINT("ENDCASE\n");
+            break;
+
           case FH_INSTR_TO:
             w2 = fh_word_at(fh, instr->data);
             if (w2) {