Initial Forth interpreter implementation (Forp)

forp.c

@@ -0,0 +1,340 @@
+#include <stdio.h>
+
+#define MEM_SIZE 16384
+#define STACK_SIZE 64
+#define RSTACK_SIZE 32
+
+union cell_union;
+typedef union cell_union cell;
+
+union cell_union {
+  int i;
+  unsigned int u;
+  cell *p;
+  char *s;
+  void (*f)();
+};
+
+char mem[MEM_SIZE];
+cell *HERE = (cell*)mem;
+cell *LATEST = NULL;
+cell IP = NULL;
+cell W = NULL;
+cell STATE = 0;
+cell rstack_mem[RSTACK_SIZE];
+cell *rstack = rstack_mem;
+cell stack_mem[STACK_SIZE];
+cell *stack = stack_mem;
+
+char *INPUT = NULL;
+
+#define CELL_OFFSET(cp, b) ((cell*)(((char *)(cp)) + b))
+#define TOP() (*(stack - 1))
+#define ST1() (*(stack - 2))
+#define ST2() (*(stack - 3))
+#define DROP(n) (stack -= n)
+void PUSHC(cell c) { *stack = c; stack++; }
+void PUSHI(int i) { stack->i = i; stack++; }
+void PUSHU(unsigned int u) { stack->u = u; stack++; }
+void PUSHCP(cell *c) { stack->p = c; stack++; }
+#define PUSHP(p) PUSHCP((cell*)p)
+void PUSHS(char *s) { stack->s = s; stack++; }
+void RPUSH(cell c) { *rstack = c; rstack++; }
+#define RPOP() (--rstack)
+
+void f_add() {
+  cell r = TOP();
+  DROP(1);
+  TOP().i += r.i;
+}
+
+void f_sub() {
+  cell r = TOP();
+  DROP(1);
+  TOP().i -= r.i;
+}
+
+void f_get() {
+  TOP() = (*(TOP().p));
+}
+
+void f_set() {
+  cell *p = TOP().p;
+  DROP(1);
+  (*p) = TOP();
+}
+
+void f_drop() {
+  DROP(1);
+}
+
+void f_dup() {
+  PUSHC(TOP());
+}
+
+void f_swap() {
+  cell top = ST1();
+  cell st1 = TOP();
+  ST1() = st1;
+  TOP() = top;
+}
+
+void f_rot() { // a b c -- b c a
+  cell c = TOP();
+  cell b = ST1();
+  cell a = ST2();
+  TOP() = a;
+  ST1() = c;
+  ST2() = b;
+}
+
+
+void f_key() {
+  if (INPUT) {
+    PUSHI(*INPUT);
+    INPUT++;
+    if (TOP().i == 0) {
+      INPUT = NULL;
+    }
+  } else {
+    PUSHI(0);
+  }
+}
+
+void f_word() {
+  static char buf[32] = {0};
+  int key = ' ';
+  int ibuf = 0;
+
+  while (key == ' ' || key == '\n' || key == '\r') {
+    f_key();
+    key = TOP().i;
+    DROP(1);
+  }
+
+  while (key != ' ' && key != '\n' && key != '\r' && key != 0) {
+    buf[ibuf++] = key;
+    f_key();
+    key = TOP().i;
+    DROP(1);
+  }
+  buf[ibuf] = 0;
+  PUSHS(buf);
+}
+
+void f_emit() {
+  printf("%c", TOP().i);
+  DROP(1);
+}
+
+void f_dot() {
+  printf("%d ", TOP().i);
+  DROP(1);
+}
+
+void f_puts() {
+  printf("%s", TOP().s);
+  DROP(1);
+}
+
+void f_cr() {
+  PUSHI('\n');
+  f_emit();
+}
+
+void f_comma() {
+  *HERE++ = TOP();
+  DROP(1);
+}
+
+void f_create() { // name --
+  int namelen;
+  HERE->p = LATEST;
+  LATEST = HERE;
+  HERE++;
+  namelen = strlen(TOP().s);
+  HERE->u = namelen; HERE ++;
+  memcpy(HERE, TOP().s, namelen + 1);
+  HERE = CELL_OFFSET(HERE, namelen + 1);
+  DROP(1);
+}
+
+void f_cdef() { // func name --
+  f_create();
+  HERE->p = TOP().p;
+  HERE ++;
+  DROP(1);
+}
+
+
+int RET = 0;
+void f_docolon() {
+  RPUSH(IP);
+  IP.p = W.p + 1;
+
+  while (!RET) {
+    W = *IP.p;
+    IP.p++;
+    W.p->f();
+  }
+  RET = 0;
+  IP = *RPOP();
+}
+
+void f_ret() {
+  RET = 1;
+}
+
+void f_donumber() {
+  PUSHC(*IP.p);
+  IP.p++;
+}
+
+void f_number() { // str -- num isnum
+  int num = 0, result;
+  result = sscanf(TOP().s, "%d", &num);
+  TOP().i = num;
+  PUSHI(result == 1);
+}
+
+void f_streq() {
+  int result = strcmp(TOP().s, ST1().s);
+  DROP(1);
+  TOP().i = result == 0;
+}
+
+void f_lookup() { // name -- code pointer
+  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);
+      return;
+    }
+    DROP(1);
+    entry = entry->p;
+  }
+  TOP().p = NULL;
+}
+
+void f_def() {
+  cell *herebefore = HERE;
+  cell *latestbefore = LATEST;
+  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;
+    } else {
+      f_comma();
+      DROP(1);
+    }
+  }
+}
+
+void f_interpret(char *input) {
+  INPUT = input;
+  while(1) {
+    f_word(); // w
+    if (TOP().s[0] == '\0') {
+      PUSHS("ok\n");
+      f_puts();
+      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();
+    if (stack < stack_mem) {
+      stack = stack_mem;
+      PUSHS("stack underflow!\n");
+      f_puts();
+      return;
+    }
+  }
+}
+
+int DIE = 0;
+void f_quit() {
+  DIE = 1;
+}
+
+#define CDEF(name, def) PUSHP(def); PUSHS(name); f_cdef()
+void f_init() {
+  CDEF(":", f_def);
+  CDEF(";", f_ret);
+  CDEF("+", f_add);
+  CDEF("-", f_sub);
+  CDEF("@", f_get);
+  CDEF("!", f_set);
+  CDEF("dup", f_dup);
+  CDEF("drop", f_drop);
+  CDEF("swap", f_drop);
+  CDEF("rot", f_rot);
+  CDEF("emit", f_emit);
+  CDEF("number", f_number);
+  CDEF("_DONUMBER", f_donumber);
+  CDEF(".", f_dot);
+  CDEF(".s", f_puts);
+  CDEF(",", f_comma);
+  CDEF("quit", f_quit);
+  f_interpret(": -rot rot rot ;");
+}
+
+int main() {
+  char inputbuf[256];
+  f_init();
+
+  while (!DIE) {
+    f_interpret(gets(inputbuf));
+  }
+  return 0;
+}