pete286/forp.c

#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;
}