Forp: Rewrite if/else/then in Forth

forp.c

@@ -44,6 +44,18 @@ void PUSHS(char *s) { stack->s = s; stack++; }
 void RPUSH(cell c) { *rstack = c; rstack++; }
 #define RPOP() (--rstack)
 
+void f_here() {
+  PUSHCP(HERE);
+}
+
+void f_latest() {
+  PUSHCP(LATEST);
+}
+
+void f_state() {
+  PUSHC(STATE);
+}
+
 void f_add() {
   cell r = TOP();
   DROP(1);
@@ -64,6 +76,7 @@ void f_set() {
   cell *p = TOP().p;
   DROP(1);
   (*p) = TOP();
+  DROP(1);
 }
 
 void f_drop() {
@@ -75,10 +88,10 @@ void f_dup() {
 }
 
 void f_swap() {
-  cell top = ST1();
-  cell st1 = TOP();
-  ST1() = st1;
-  TOP() = top;
+  cell top = TOP();
+  cell st1 = ST1();
+  TOP() = st1;
+  ST1() = top;
 }
 
 void f_rot() { // a b c -- b c a
@@ -128,16 +141,24 @@ void f_emit() {
   DROP(1);
 }
 
-void f_dot() {
-  printf("%d ", TOP().i);
+void f_puts() {
+  char *s = TOP().s;
+  while (s && *s) {
+    PUSHI(*s);
+    f_emit();
+    s++;
+  }
   DROP(1);
 }
 
-void f_puts() {
-  printf("%s", TOP().s);
-  DROP(1);
+void f_dot() {
+  static char num[16];
+  sprintf(num, "%d ", TOP().i);
+  TOP().s = num;
+  f_puts();
 }
 
+
 void f_cr() {
   PUSHI('\n');
   f_emit();
@@ -189,7 +210,7 @@ void f_docolon() {
 void f_noop() {
 }
 
-void f_donumber() {
+void f_push_() {
   PUSHC(*IP.p);
   IP.p++;
 }
@@ -225,6 +246,21 @@ void f_lookup() { // name -- (codepointer flags) | (name 0)
   PUSHU(0);
 }
 
+void f_revlookup() { // codepointer -- name
+  cell *entry = LATEST;
+  while (entry) {
+    unsigned int length = entry[1].u & ~F_IMMEDIATE;
+    cell *name = entry + 2;
+    cell *cp = CELL_OFFSET(name, length + 1);
+    if (cp == TOP().p) {
+      TOP().p = name;
+      return;
+    }
+    entry = entry->p;
+  }
+  TOP().p = NULL;
+}
+
 void f_compileon() {
   STATE.i = 1;
 }
@@ -236,12 +272,11 @@ void f_immediate() {
   cell *flags = LATEST + 1;
   flags->u |= F_IMMEDIATE;
 }
+void f_compileword();
 
 void f_semicolon() {
   PUSHS("_RET");
-  f_lookup();
-  DROP(1);
-  f_comma();
+  f_compileword();
   f_compileoff();
 }
 
@@ -271,10 +306,8 @@ void f_interpretword() { // codefield flags --
 
 void f_interpretnumber() { // number --
   if (STATE.i) {
-    PUSHS("_DONUMBER");
-    f_lookup();
-    DROP(1);
-    f_comma();
+    PUSHS("PUSH_");
+    f_compileword();
     f_comma();
   }
 }
@@ -325,37 +358,34 @@ void f_interpret(char *input) {
 }
 
 void f_if() {
-  if (STATE.i) {
-    PUSHC(W);
-    f_comma();
-    PUSHP(HERE);
-    PUSHP(NULL);
-    f_comma();
+  PUSHS("IF_");
+  f_compileword();
+  PUSHP(HERE);
+  PUSHP(NULL);
+  f_comma();
+}
+
+void f_if_() {
+  if (TOP().u) {
+    IP.p ++;
   } else {
-    if (TOP().u) {
-      IP.p ++;
-    } else {
-      IP.p = IP.p->p; // skip to then
-    }
-    DROP(1);
+    IP.p = IP.p->p; // skip to else or then
   }
+  DROP(1);
 }
 
 void f_else() {
-  if (STATE.i) {
+  PUSHS("GOTO_");
+  f_compileword();
+  PUSHP(NULL);
+  f_comma();
 
-    PUSHC(W);
-    f_comma();
+  TOP().p->p = HERE; // make false condition of IF come here
+  TOP().p = HERE - 1; // make THEN patch our goto
+}
 
-    TOP().p->p = HERE + 1;
-    TOP().p = HERE;
-
-    PUSHP(NULL);
-    f_comma();
-
-  } else {
-    IP.p = IP.p->p;
-  }
+void f_goto_() {
+  IP.p = IP.p->p;
 }
 
 void f_then() {
@@ -363,6 +393,17 @@ void f_then() {
   DROP(1);
 }
 
+void f_quote() {
+  if (STATE.i) {
+    PUSHS("PUSH_");
+    f_compileword();
+  } else {
+    f_word();
+    f_lookup();
+    DROP(1);
+  }
+}
+
 int DIE = 0;
 void f_quit() {
   DIE = 1;
@@ -372,31 +413,41 @@ void f_quit() {
 void f_init() {
   CDEF("[", f_compileoff); f_immediate();
   CDEF("]", f_compileon);
+  CDEF("key", f_key);
+  CDEF("emit", f_emit);
+  CDEF("word", f_word);
   CDEF("immediate", f_immediate);
   CDEF("create", f_create);
+  CDEF("here", f_here);
+  CDEF("latest", f_latest);
+  CDEF("state", f_state);
+  CDEF("'", f_quote); f_immediate();
+  CDEF("`", f_revlookup);
   CDEF(":", f_colon);
   CDEF(";", f_semicolon); f_immediate();
   CDEF("+", f_add);
   CDEF("-", f_sub);
   CDEF("@", f_get);
   CDEF("!", f_set);
-  CDEF("if", f_if); f_immediate();
-  CDEF("else", f_else); f_immediate();
-  CDEF("then", f_then); f_immediate();
   CDEF("dup", f_dup);
   CDEF("drop", f_drop);
-  CDEF("swap", f_drop);
+  CDEF("swap", f_swap);
   CDEF("rot", f_rot);
   CDEF("emit", f_emit);
   CDEF("number", f_number);
-  CDEF("_DONUMBER", f_donumber);
+  CDEF("PUSH_", f_push_);
+  CDEF("GOTO_", f_goto_);
+  CDEF("IF_", f_if_);
   CDEF("_RET", f_ret);
   CDEF(".", f_dot);
   CDEF(".s", f_puts);
   CDEF(",", f_comma);
   CDEF("noop", f_noop);
   CDEF("quit", f_quit);
-  f_interpret(": -rot rot rot ;");
+  f_interpret(": if ' IF_ , here 0 , ; immediate");
+  f_interpret(": else ' GOTO_ , 0 , here swap ! here 2 - ; immediate");
+  f_interpret(": then here swap ! ; immediate");
+
 }
 
 int main() {