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)();
  FILE *fp;
};

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;
FILE *INPUT_FILE = NULL;

FILE *OUTPUT_FILE = NULL;
cell QUIET = 0;

#define F_IMMEDIATE 0x80

#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_here() {
  PUSHCP(HERE);
}

void f_latest() {
  PUSHCP(LATEST);
}

void f_state() {
  PUSHC(STATE);
}
#define BINOP(name, op) \
  void name() { \
    cell r = TOP(); \
    DROP(1); \
    TOP().i = TOP().i op r.i; \
  }

BINOP(f_add, +)
BINOP(f_sub, -)
BINOP(f_mul, *)
BINOP(f_div, /)
BINOP(f_eq, ==)
BINOP(f_neq, !=)
BINOP(f_ge, >=)
BINOP(f_gt, >)
BINOP(f_lt, <)
BINOP(f_le, <=)

void f_eq0() {
  TOP().i = (TOP().i == 0);
}
void f_not() {
  TOP().i = !TOP().i;
}

void f_get() {
  TOP() = (*(TOP().p));
}

void f_set() {
  cell *p = TOP().p;
  DROP(1);
  (*p) = TOP();
  DROP(1);
}

void f_bget() {
  TOP().i = *((char*)TOP().p);
}

void f_bset() {
  char *p = (char*)TOP().p;
  DROP(1);
  (*p) = TOP().i;
  DROP(1);
}

void f_drop() {
  DROP(1);
}

void f_dup() {
  PUSHC(TOP());
}

void f_over() {
  PUSHC(ST1());
}

void f_swap() {
  cell top = TOP();
  cell st1 = ST1();
  TOP() = st1;
  ST1() = 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 if (INPUT_FILE) {
    int val = fgetc(INPUT_FILE);
    if (val == EOF) {
      fclose(INPUT_FILE);
      INPUT_FILE = NULL;
      PUSHI(0);
    } else {
      PUSHI(val);
    }
  } else {
    PUSHI(0);
  }
  if (OUTPUT_FILE && TOP().i != 0) {
    fputc(TOP().i, OUTPUT_FILE);
  }
}

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() {
  if (!QUIET.i) {
    printf("%c", TOP().i);
  }
  if (OUTPUT_FILE) {
    fputc(TOP().i, OUTPUT_FILE);
  }
  DROP(1);
}

void f_puts() {
  char *s = TOP().s;
  while (s && *s) {
    PUSHI(*s);
    f_emit();
    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();
}

void f_comma() {
  *HERE++ = TOP();
  DROP(1);
}

void f_bcomma() {
  *((char*)HERE) = TOP().i;
  HERE = CELL_OFFSET(HERE, 1);
  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);
}

void f_docolon() {
  RPUSH(W);

  IP.p = W.p + 1;
  while (rstack != rstack_mem) {
    cell codeptr;
    W = *IP.p;
    IP.p++;
    codeptr = *W.p;
    if (codeptr.f == f_docolon) {
      RPUSH(IP);
      IP.p = W.p + 1;
    } else {
      codeptr.f();
    }
  }
}

void f_noop() {
}

void f_lit_() {
  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 -- (codepointer flags) | (name 0)
  cell *entry = LATEST;
  while (entry) {
    f_dup();
    PUSHP(entry + 2);
    f_streq();
    if (TOP().i) {
      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;
  }
  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;
}
void f_compileoff() {
  STATE.i = 0;
}

void f_immediate() {
  cell *flags = LATEST + 1;
  flags->u |= F_IMMEDIATE;
}
void f_compileword();

void f_semicolon() {
  PUSHS("_RET");
  f_compileword();
  f_compileoff();
}

void f_ret() {
  IP = *RPOP();
}

void f_colon() {
  f_word();
  f_create();
  PUSHP(f_docolon);
  f_comma();
  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("LIT_");
    f_compileword();
    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 {
      DROP(2); // name
      f_interpretunknown();
    }
  } else { // codepointer flags
    f_interpretword();
  }
}

void f_interpreter() {
  while(1) {
    f_word(); // w
    if (TOP().s[0] == '\0') {
      PUSHS("ok\n");
      f_puts();
      DROP(1);
      return;
    }
    f_compileword();
    if (stack < stack_mem) {
      stack = stack_mem;
      PUSHS("stack underflow!\n");
      f_puts();
      return;
    }
  }
}

void f_open() {
  FILE *fp = fopen(TOP().s, "a+");
  fseek(fp, 0, SEEK_SET);
  TOP().fp = fp;
}

void f_close() {
  fclose(TOP().fp);
  DROP(1);
}

void f__loadfile() {
  INPUT_FILE = TOP().fp;
  DROP(1);
  f_interpreter();
  if (INPUT_FILE != NULL) {
    fclose(INPUT_FILE);
    INPUT_FILE = NULL;
  }
}

void f_loadstring() {
  INPUT = TOP().s;
  DROP(1);
  f_interpreter();
  INPUT = NULL;
}

void f_appendlog() {
  OUTPUT_FILE = TOP().fp;
  fseek(OUTPUT_FILE, 0, SEEK_END);
  DROP(1);
}

void f_doconst() {
  PUSHC(*(W.p + 1));
}

void f_const() {
  f_word();
  f_create();
  PUSHP(f_doconst);
  f_comma();
  f_comma();
}

void f_bz_() {
  if (!TOP().u) {
    IP.p = IP.p->p; // branch
  } else {
    IP.p ++; // skip branch destination cell
  }
  DROP(1);
}

void f_bnz_() {
  if (TOP().u) {
    IP.p = IP.p->p; // branch
  } else {
    IP.p ++; // skip branch destination cell
  }
  DROP(1);
}

void f_goto_() {
  IP.p = IP.p->p;
}

void f_string_() {
  PUSHP(IP.p + 1);
  IP.p = CELL_OFFSET(IP.p + 1, IP.p->i + 1);
}

void f_string() {
  cell *length;
  char *s;
  char b;
  if (STATE.i) {
    PUSHS("S\"_");
    f_compileword();
    length = HERE;
    PUSHI(0);
    f_comma();
  }
  s = (char*)HERE;
  while(1) {
    f_key();
    b = TOP().i;
    DROP(1);
    if (b == '\"') {
      *s++ = 0;
      break;
    } else {
      *s++ = b;
    }
  }
  if (STATE.i) {
    length->i = (int)((s - ((char*)HERE)) - 1);
    HERE = (cell *)s;
  } else {
    PUSHP(HERE);
  }
}

void f_quote() {
  if (STATE.i) {
    PUSHS("LIT_");
    f_compileword();
  } else {
    f_word();
    f_lookup();
    DROP(1);
  }
}

void f_loadfile(char *filename) {
  PUSHS(filename);
  f_open();
  f__loadfile();
}

void f_runstring(char *s) {
  PUSHS(s);
  f_loadstring();
}

void f_quiet() {
  QUIET.i = 1;
}

void f_loud() {
  QUIET.i = 0;
}

#define CDEF(name, def) PUSHP(def); PUSHS(name); f_cdef()
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("lookup", f_lookup);
  CDEF(":", f_colon);
  CDEF(";", f_semicolon); f_immediate();
  CDEF("const", f_const);
  CDEF("+", f_add);
  CDEF("-", f_sub);
  CDEF("*", f_mul);
  CDEF("/", f_div);
  CDEF("=0", f_eq0);
  CDEF("not", f_not);
  CDEF("=", f_eq);
  CDEF("!=", f_neq);
  CDEF(">=", f_ge);
  CDEF(">", f_gt);
  CDEF("=", f_eq);
  CDEF("<", f_lt);
  CDEF("<=", f_le);
  CDEF("@", f_get);
  CDEF("!", f_set);
  CDEF("b@", f_bget);
  CDEF("b!", f_bset);
  CDEF("dup", f_dup);
  CDEF("over", f_over);
  CDEF("drop", f_drop);
  CDEF("swap", f_swap);
  CDEF("rot", f_rot);
  CDEF("emit", f_emit);
  CDEF("number", f_number);
  CDEF("LIT_", f_lit_);
  CDEF("GOTO_", f_goto_);
  CDEF("BZ_", f_bz_);
  CDEF("BNZ_", f_bnz_);
  CDEF("_RET", f_ret);
  CDEF(".", f_dot);
  CDEF(".s", f_puts);
  CDEF(",", f_comma);
  CDEF("b,", f_bcomma);
  CDEF("s\"", f_string); f_immediate();
  CDEF("S\"_", f_string_);
  CDEF("noop", f_noop);
  CDEF("open", f_open);
  CDEF("close", f_close);
  CDEF("loadfile", f__loadfile);
  CDEF("loadstring", f_loadstring);
  CDEF("quiet", f_quiet);
  CDEF("loud", f_loud);
  CDEF("appendlog", f_appendlog);


  PUSHS("forp.log");
  f_open();
  f_appendlog();


  f_loadfile("defs.frp");
}

int DIE = 0;
void f_quit() {
  DIE = 1;
}

int main() {
  char inputbuf[256];
  f_init();
  CDEF("quit", f_quit);

  while (!DIE) {
    f_runstring(gets(inputbuf));
  }
  return 0;
}