Forp: Refactor interpreter, inline VM loop, implement if/then and immediate words

forp.c

@@ -28,6 +28,8 @@ cell *stack = stack_mem;
 
 char *INPUT = NULL;
 
+#define F_IMMEDIATE 0x80
+
 #define CELL_OFFSET(cp, b) ((cell*)(((char *)(cp)) + b))
 #define TOP() (*(stack - 1))
 #define ST1() (*(stack - 2))
@@ -88,7 +90,6 @@ void f_rot() { // a b c -- b c a
   ST2() = b;
 }
 
-
 void f_key() {
   if (INPUT) {
     PUSHI(*INPUT);
@@ -166,23 +167,26 @@ void f_cdef() { // func name --
   DROP(1);
 }
 
-
-int RET = 0;
 void f_docolon() {
-  RPUSH(IP);
-  IP.p = W.p + 1;
+  RPUSH(W);
 
-  while (!RET) {
+  IP.p = W.p + 1;
+  while (rstack != rstack_mem) {
+    cell codeptr;
     W = *IP.p;
     IP.p++;
-    W.p->f();
+    codeptr = *W.p;
+    if (codeptr.f == f_docolon) {
+      RPUSH(IP);
+      IP.p = W.p + 1;
+    } else {
+      codeptr.f();
+    }
   }
-  RET = 0;
-  IP = *RPOP();
 }
 
-void f_ret() {
-  RET = 1;
+
+void f_noop() {
 }
 
 void f_donumber() {
@@ -203,63 +207,100 @@ void f_streq() {
   TOP().i = result == 0;
 }
 
-void f_lookup() { // name -- code pointer
+void f_lookup() { // name -- (codepointer flags) | (name 0)
   cell *entry = LATEST;
   while (entry) {
     f_dup();
     PUSHP(entry + 2);
     f_streq();
     if (TOP().i) {
-      DROP(1);
-      TOP().p = CELL_OFFSET(entry + 2, entry[1].u + 1);
+      unsigned int flags = entry[1].u;
+      TOP().u = flags;
+      ST1().p = CELL_OFFSET(entry + 2, (flags & ~F_IMMEDIATE) + 1);
       return;
     }
     DROP(1);
     entry = entry->p;
   }
-  TOP().p = NULL;
+  PUSHU(0);
 }
 
-void f_def() {
-  cell *herebefore = HERE;
-  cell *latestbefore = LATEST;
+void f_compileon() {
+  STATE.i = 1;
+}
+void f_compileoff() {
+  STATE.i = 0;
+}
+
+void f_immediate() {
+  cell *flags = LATEST + 1;
+  flags->u |= F_IMMEDIATE;
+}
+
+void f_semicolon() {
+  PUSHS("_RET");
+  f_lookup();
+  DROP(1);
+  f_comma();
+  f_compileoff();
+}
+
+void f_ret() {
+  IP = *RPOP();
+}
+
+void f_colon() {
   f_word();
   f_create();
   PUSHP(f_docolon);
   f_comma();
-  while(1) {
-    f_word(); // w
-    f_dup();  // w w
-    f_lookup(); // w code
-    if (TOP().p == NULL) {
-      DROP(1); // w
-      f_dup(); // w w
-      f_number(); // w n isnum
-      if (TOP().i) {
-	PUSHS("_DONUMBER");
-	f_lookup(); // w n isnum _donumber
-	f_comma();
-	PUSHI(ST1().i); // w n isnum n
-	f_comma(); // w n isnum
-	DROP(3);
-      } else {
-	DROP(2); // w
-	HERE = herebefore;
-	LATEST = latestbefore;
-	f_puts();
-	PUSHS("?\n");
-	f_puts();
-	f_cr();
-	return;
-      }
-    } else if (TOP().p->f == f_ret) {
-      f_comma();
-      DROP(1);
-      return;
+  f_compileon();
+}
+
+void f_interpretword() { // codefield flags --
+  if (!STATE.i || (TOP().u & F_IMMEDIATE)) {
+    DROP(1);
+    W = TOP(); // w code
+    DROP(1);
+    W.p->f();
+  } else {
+    DROP(1);
+    f_comma();
+  }
+}
+
+void f_interpretnumber() { // number --
+  if (STATE.i) {
+    PUSHS("_DONUMBER");
+    f_lookup();
+    DROP(1);
+    f_comma();
+    f_comma();
+  }
+}
+
+void f_interpretunknown() { // name --
+  f_puts();
+  PUSHS("?\n");
+  f_puts();
+}
+
+void f_compileword() { // name --
+  f_lookup();
+  if (!TOP().u) { // name 0
+    DROP(1); // name
+    f_dup(); // name name
+    f_number(); // name n isnum
+    if (TOP().i) {
+      f_rot(); // name n isnum -- n isnum name
+      DROP(2); // n isnum w -- n
+      f_interpretnumber();
     } else {
-      f_comma();
-      DROP(1);
+      DROP(2); // name
+      f_interpretunknown();
     }
+  } else { // codepointer flags
+    f_interpretword();
   }
 }
 
@@ -273,26 +314,7 @@ void f_interpret(char *input) {
       DROP(1);
       return;
     }
-    f_dup(); // w w
-    f_lookup(); // w code
-    if (TOP().p == NULL) {
-      DROP(1); // w
-      f_dup(); // w w
-      f_number(); // w n isnum
-      if (TOP().i) {
-	f_rot(); // w n isnum -- n isnum w
-	DROP(2); // n isnum w -- n
-	continue;
-      }
-      DROP(2); // w
-      f_puts();
-      PUSHS("?\n");
-      f_puts();
-      return;
-    }
-    W = TOP(); // w code
-    DROP(2);
-    W.p->f();
+    f_compileword();
     if (stack < stack_mem) {
       stack = stack_mem;
       PUSHS("stack underflow!\n");
@@ -302,6 +324,45 @@ void f_interpret(char *input) {
   }
 }
 
+void f_if() {
+  if (STATE.i) {
+    PUSHC(W);
+    f_comma();
+    PUSHP(HERE);
+    PUSHP(NULL);
+    f_comma();
+  } else {
+    if (TOP().u) {
+      IP.p ++;
+    } else {
+      IP.p = IP.p->p; // skip to then
+    }
+    DROP(1);
+  }
+}
+
+void f_else() {
+  if (STATE.i) {
+
+    PUSHC(W);
+    f_comma();
+
+    TOP().p->p = HERE + 1;
+    TOP().p = HERE;
+
+    PUSHP(NULL);
+    f_comma();
+
+  } else {
+    IP.p = IP.p->p;
+  }
+}
+
+void f_then() {
+  TOP().p->p = HERE;
+  DROP(1);
+}
+
 int DIE = 0;
 void f_quit() {
   DIE = 1;
@@ -309,12 +370,19 @@ void f_quit() {
 
 #define CDEF(name, def) PUSHP(def); PUSHS(name); f_cdef()
 void f_init() {
-  CDEF(":", f_def);
-  CDEF(";", f_ret);
+  CDEF("[", f_compileoff); f_immediate();
+  CDEF("]", f_compileon);
+  CDEF("immediate", f_immediate);
+  CDEF("create", f_create);
+  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);
@@ -322,9 +390,11 @@ void f_init() {
   CDEF("emit", f_emit);
   CDEF("number", f_number);
   CDEF("_DONUMBER", f_donumber);
+  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 ;");
 }