neuttower/jorth.c

//#define TRACE

#include <stdio.h>
#include <stdlib.h>
#include <sys/stat.h>
#include <dos.h>
#include <dir.h>
#include "jorth.h"

#define TASK_REGISTER_SIZE 3
#define TASK_USER_SIZE 8
#define TASK_HEADER_SIZE (TASK_USER_SIZE + TASK_REGISTER_SIZE)
#define TASK_SIZE (TASK_HEADER_SIZE + STACK_SIZE + RSTACK_SIZE)
#define STACK_OFFSET (TASK_HEADER_SIZE)
#define RSTACK_OFFSET (TASK_HEADER_SIZE + STACK_SIZE)

#define TASK_USER_NEXT 0
#define TASK_USER_STATE 1
#define TASK_USER_MAILBOX 2
#define TASK_USER_QUIET 3
#define TASK_USER_KEY 4
#define TASK_USER_KEYSRC 5
#define TASK_USER_ECHO 6
#define TASK_USER_EMIT 7

char mem[MEM_SIZE] = { 0 };
cell *HERE = ((cell*)mem) + TASK_SIZE;
cell *LATEST = NULL;
cell IP = NULL;
cell W = NULL;
#define STATE (*(RUNNING + TASK_USER_STATE))
cell *RUNNING = (cell*)mem;
cell *TASKS = (cell*)mem;
cell *stack = ((cell*)mem) + STACK_OFFSET;
cell *rstack = ((cell*)mem) + RSTACK_OFFSET;
#ifdef TRACE
int TRACING = 0;
#endif

#define QUIET (*(RUNNING + TASK_USER_QUIET))

FILE *ACTIVE_FILE = NULL;

void DROP(n) {
  stack -= n;
  if (stack < RUNNING + STACK_OFFSET) {
    stack = RUNNING + STACK_OFFSET;
    PUSHS("underflow!\n");
    f_puts();
  }
}

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++; }
void PUSHS(char *s) { stack->s = s; stack++; }
void RPUSH(cell c) { *rstack = c; rstack++; }

void f_here() {
  PUSHCP(HERE);
}

void f_here_set() {
  HERE = TOP().p;
  DROP(1);
}
void f_there() {
  PUSHCP(&mem[MEM_SIZE]);
}

void f_latest() {
  PUSHCP(LATEST);
}

void f_latest_set() {
  LATEST = TOP().p;
  DROP(1);
}

void f_tasks() {
  PUSHCP(TASKS);
}

void f_tasks_set() {
  TASKS = TOP().p;
  DROP(1);
}

void f_state() {
  PUSHC(STATE);
}

void f_running() {
  PUSHCP(RUNNING);
}

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

BINOP(f_add, i, +)
BINOP(f_sub, i, -)
BINOP(f_mul, i, *)
BINOP(f_div, i, /)
BINOP(f_mod, u, %)
BINOP(f_eq, i, ==)
BINOP(f_neq, i, !=)
BINOP(f_ge, i, >=)
BINOP(f_gt, i, >)
BINOP(f_lt, i, <)
BINOP(f_le, i, <=)
BINOP(f_uge, u, >=)
BINOP(f_ugt, u, >)
BINOP(f_ult, u, <)
BINOP(f_ule, u, <=)
BINOP(f_and, u, &&)
BINOP(f_or, u, ||)
BINOP(f_bitand, u, &)
BINOP(f_bitor, u, |)
BINOP(f_bitxor, u, ^)
BINOP(f_shr, u, >>)
BINOP(f_shl, u, <<)

#define RATIO_FRACTIONAL_BITS 14

void f_toratio() { // a/b ( a b -- r )
  ST1().i = ((long)ST1().i * (1 << RATIO_FRACTIONAL_BITS)) / TOP().i;
  DROP(1);
}

void f_fromratio() { // a*r ( a r -- b )
  ST1().i = ((long)ST1().i * (long)TOP().i) / (1 << RATIO_FRACTIONAL_BITS);
  DROP(1);
}

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_ubget() {
  TOP().u = *((unsigned char*)TOP().p);
}

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

void f_farset() {
  *((cell far *)MK_FP(TOP().u, ST1().u)) = ST2();
  DROP(3);
}

void f_farget() {
  ST1() = *((cell far *)MK_FP(TOP().u, ST1().u));
  DROP(1);
}

void f_farbset() {
  *((char far *)MK_FP(TOP().u, ST1().u)) = ST2().i;
  DROP(3);
}

void f_farbget() {
  ST1().i = *((char far *)MK_FP(TOP().u, ST1().u));
  DROP(1);
}

void f_addset() {
  TOP().p->i += ST1().i;
  DROP(2);
}

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_rput() {
  RPUSH(TOP());
  DROP(1);
}

void f_rtake() {
  PUSHC(*RPOP());
}

void f_rtop() {
  PUSHC(*(rstack - 1));
}

void f_rdrop() {
  RPOP();
}

void f_rswap() {
  cell top = *(rstack - 1);
  cell under = *(rstack - 2);
  *(rstack - 1) = under;
  *(rstack - 2) = top;
}

void f_cexecute();

void f_key_string() {
  cell *INPUT = RUNNING + TASK_USER_KEYSRC;
  if (INPUT->p) {
    PUSHCP(INPUT->p);
    f_bget();
    if (TOP().i != 0) {
      INPUT->p = CELL_OFFSET(INPUT->p, 1);
    } else {
      INPUT->p = NULL;
    }
  } else {
    PUSHI(0);
  }
}

void f_key_file() {
  cell *INPUT = RUNNING + TASK_USER_KEYSRC;
  int val = 0;
  if (INPUT->fp) {
    val = fgetc(INPUT->fp);
    if (val == EOF) {
      fclose(INPUT->fp);
      INPUT->fp = NULL;
      val = 0;
    }
  }
  PUSHI(val);
}

void f_key() {
  cell *keyword = RUNNING + TASK_USER_KEY;
  cell *echoword = RUNNING + TASK_USER_ECHO;
  if (keyword->p) {
    PUSHCP(keyword->p);
    f_cexecute();
  } else {
    PUSHI(0);
  }
  if (!QUIET.i && echoword->p) {
    f_dup();
    PUSHCP(echoword->p);
    f_cexecute();
  }
}

void f_word() {
  static char buf[32] = {0};
  int key = ' ';
  int ibuf = 0;

  while (key == ' ' || key == '\t' || key == '\n' || key == '\r') {
    f_key();
    key = TOP().i;
    DROP(1);
  }

  while (key != ' ' && key != '\t' && 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) {
    cell *echoword = RUNNING + TASK_USER_ECHO;
    cell *emitword = RUNNING + TASK_USER_EMIT;
    if (echoword->p) {
      f_dup();
      PUSHCP(echoword->p);
      f_cexecute();
    }
    if (emitword->p) {
      PUSHCP(emitword->p);
      f_cexecute();
    } else {
      DROP(1);
    }
  } else {
    DROP(1);
  }
}

void f_putc() {
  printf("%c", TOP().i);
  DROP(1);
}

void f_fputc() {
  if (ACTIVE_FILE) {
    fwrite(&TOP().i, 1, 1, ACTIVE_FILE);
  }
  DROP(1);
}

void f_gets() {
  gets(TOP().s);
}

void f_fput() {
  if (ACTIVE_FILE) {
    fwrite(&TOP().u, 2, 1, ACTIVE_FILE);
  }
  DROP(1);
}

void f_fwrite() { // ( length p )
  if (ACTIVE_FILE) {
    fwrite(TOP().p, ST1().u, 1, ACTIVE_FILE);
  }
  DROP(2);
}

void f_fgetc() {
  int result = EOF;
  if (ACTIVE_FILE) {
    result = fgetc(ACTIVE_FILE);
  }
  PUSHI(result);
}

void f_fget() {
  unsigned int result = 0;
  if (ACTIVE_FILE) {
    int low = fgetc(ACTIVE_FILE);
    int high = fgetc(ACTIVE_FILE);
    if (low != EOF && high != EOF) {
      result = low | (high << 8);
    }
  }
  PUSHU(result);
}

void f_fread() { // ( length p )
  if (ACTIVE_FILE) {
    fread(TOP().p, ST1().u, 1, ACTIVE_FILE);
  }
  DROP(2);
}

void f_feof() {
  if (ACTIVE_FILE) {
    PUSHI(feof(ACTIVE_FILE));
  } else {
    PUSHI(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_udot() {
  static char num[16];
  sprintf(num, "%u ", TOP().i);
  TOP().s = num;
  f_puts();
}

void f_printstack() {
  cell *v = RUNNING + STACK_OFFSET;
  while (v != stack) {
    PUSHC(*v++);
    f_dot();
  }
}

void f_printrstack() {
  cell *v = RUNNING + RSTACK_OFFSET;
  while (v != rstack) {
    PUSHC(*v++);
    f_dot();
  }
}

void f_cr() {
  PUSHI('\n');
  f_emit();
}

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

void f_allot() {
  memset(HERE, 0, TOP().u);
  HERE = CELL_OFFSET(HERE, TOP().u);
  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();
  f_comma();
}

void f_revlookup();

#ifdef TRACE
void f_traceon() {
  TRACING = 1;
}
void f_traceoff() {
  TRACING = 0;
}

void f_colondispatch() {
  static int printing = 0;

  if (TRACING && !printing) {
    printing = 1;
    PUSHCP(W.p);
    f_revlookup();
    if (TOP().s) {
      f_puts();
      PUSHU(' ');
      f_emit();
    } else {
      TOP().p = W.p;
      f_dot();
    }
    printing = 0;
  }
  W.p->f();
}
#else
#define f_colondispatch() W.p->f()
#endif

void f_colonloop() {
  while (IP.p) {
    W = *IP.p;
    IP.p++;
    f_colondispatch();
  }
}

// this version of f_execute can be run from a colon word
void f_execute() {
  W = TOP();
  DROP(1);
  f_colondispatch();
}

// C code must always call a colon word through f_cexecute()
void f_cexecute() {
  cell oldW = W;
  cell oldIP = IP;
  IP.p = NULL;
  f_execute();
  f_colonloop();
  W = oldW;
  IP = oldIP;
}

void f_docolon() {
  RPUSH(IP);
  IP.p = W.p + 1;
}

void f_dodeferred() {
  W = *(W.p + 1);
  f_colondispatch();
}

void f_lit_() {
  PUSHC(*IP.p);
  IP.p++;
}

void f_number() { // str -- (num 1 | str 0)
  int num = 0, result;
  result = sscanf(TOP().s, "0x%x", &num);
  if (result != 1) {
    result = sscanf(TOP().s, "%d", &num);
  }
  if (result == 1) {
    TOP().i = num;
    PUSHI(result == 1);
  } else {
    PUSHI(0);
  }
}

void f_streq() {
  int result = strcmp(TOP().s, ST1().s);
  DROP(1);
  TOP().i = result == 0;
}

void f_wordname() {
  TOP().p = TOP().p + 2;
}
void f_wordflags() {
  TOP().p = TOP().p + 1;
}

void f_codepointer() {
  unsigned int flags = TOP().p[1].u;
  TOP().p = CELL_OFFSET(TOP().p + 2, (flags & F_NAMELEN_MASK) + 1);
}

void f_lookup() { // name -- (codepointer flags) | (name 0)
  cell *entry = LATEST;
  char *name = TOP().s;
  int len = strlen(name);
  DROP(1);

  while (entry) {
    PUSHP(entry);
    f_wordflags(); f_get();
    if (len == (TOP().u & F_NAMELEN_MASK)) {
      PUSHS(name);
      PUSHP(entry);
      f_wordname();
      f_streq();
      if (TOP().i) {
	TOP().p = entry;
	f_codepointer();
	f_swap();
	return;
      }
      DROP(2);
    } else {
      DROP(1);
    }
    entry = entry->p;
  }
  PUSHS(name);
  PUSHU(0);
}

void f_revlookup() { // codepointer -- name
  cell *entry = LATEST;
  while (entry) {
    PUSHCP(entry);
    f_codepointer();
    if (TOP().p == ST1().p) {
      DROP(1);
      TOP().p = entry;
      f_wordname();
      return;
    }
    DROP(1);
    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() {
  if (rstack == RUNNING + RSTACK_OFFSET) {
    IP.p = NULL;
  } else {
    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);
    f_cexecute();
  } 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_number(); // n isnum
    if (TOP().i) {
      DROP(1);
      f_interpretnumber();
    } else {
      DROP(1);
      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();
  }
}

void f_close() {
  if (ACTIVE_FILE) {
    fclose(ACTIVE_FILE);
    ACTIVE_FILE = NULL;
  }
}

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

void f_overwrite() {
  f_close();
  ACTIVE_FILE = fopen(TOP().s, "wb+");
  DROP(1);
}

void f_deactivate() {
  PUSHP(ACTIVE_FILE);
  ACTIVE_FILE = NULL;
}

void f_activate() {
  f_close();
  ACTIVE_FILE = TOP().fp;
  DROP(1);
}

void f_seek() {
  fseek(ACTIVE_FILE, TOP().u, SEEK_SET);
  DROP(1);
}

void f_seekend() {
  fseek(ACTIVE_FILE, 0, SEEK_END);
}

void f_tell() {
  PUSHU(ftell(ACTIVE_FILE));
}

void f_exists() {
  struct stat statbuf;
  int rc = stat(TOP().s, &statbuf);
  TOP().i = rc == 0;
}

struct ffblk findfile;
void f_findfirst() {
  int result = findfirst(TOP().s, &findfile, 0);
  if (result == 0) {
    TOP().s = findfile.ff_name;
  } else {
    TOP().u = 0;
  }
}

void f_findnext() {
  int result = findnext(&findfile);
  if (result == 0) {
    PUSHS(findfile.ff_name);
  } else {
    PUSHU(0);
  }
}

void f_chdir() {
  chdir(TOP().s);
  DROP(1);
}

void f_swapinput() {
  cell *key = RUNNING + TASK_USER_KEY;
  cell *keysrc = RUNNING + TASK_USER_KEYSRC;
  cell oldKey = *key;
  cell oldKeysrc = *keysrc;
  *key = TOP();
  *keysrc = ST1();
  TOP() = oldKey;
  ST1() = oldKeysrc;
}

void f_taskemit() {
  PUSHCP(RUNNING + TASK_USER_EMIT);
}

void f_taskecho() {
  PUSHCP(RUNNING + TASK_USER_ECHO);
}

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

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

void f_dovar() {
  PUSHCP(W.p + 1);
}

void f_var() {
  f_word();
  f_create();
  PUSHP(f_dovar);
  f_comma();
  PUSHI(0);
  f_comma();
}

void f_docreate() {
  PUSHCP(W.p + 2);
  RPUSH(IP);
  IP = *(W.p + 1);
}

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_inline_data_() {
  PUSHCP(IP.p + 1);
  IP = *IP.p;
}

void f_memmove() { // ( dst src size -- )
  memmove(ST2().p, ST1().p, TOP().u);
  DROP(3);
}
void f_quote() {
  if (STATE.i) {
    PUSHS("LIT_");
    f_compileword();
  } else {
    f_word();
    f_lookup();
    DROP(1);
  }
}
void f_imagefilename() {
  static char imagefilename[32];
  int i;

  strcpy(imagefilename, TOP().s);
  for (i = 0; i < strlen(imagefilename); i ++) {
    if (imagefilename[i] == '.') break;
  }
  strcpy(&imagefilename[i], ".jim");
  TOP().s = imagefilename;
}

void f_image_up_to_date() {
  struct stat src, img;
  int uptodate = 0;
  f_dup();
  f_imagefilename();
  if (stat(TOP().s, &img) == 0 && stat(ST1().s, &src) == 0) {
    uptodate = img.st_mtime > src.st_mtime;
  }
  DROP(1);
  TOP().i = uptodate;
}

static int imagemagic = -1;
static void f_calc_imagemagic(char *exefilename) {
  struct stat exe;
  if (stat(exefilename, &exe) == 0) {
    imagemagic = exe.st_mtime;
  }
}


void f_loadimage() {
  cell *start, *latestNew, *tasksNew;
  size_t size;
  int magic;

  fread(&magic, sizeof(int), 1, ACTIVE_FILE);
  if (magic != imagemagic) {
    PUSHI(0);
    return;
  }
  fread(&start, sizeof(cell *), 1, ACTIVE_FILE);
  fread(&latestNew, sizeof(cell *), 1, ACTIVE_FILE);
  fread(&tasksNew, sizeof(cell *), 1, ACTIVE_FILE);
  fread(&size, sizeof(size_t), 1, ACTIVE_FILE);
  if (start != HERE) {
    fseek(ACTIVE_FILE, size, SEEK_CUR);
    PUSHI(0);
  } else {
    fread(HERE, 1, size, ACTIVE_FILE);
    HERE = CELL_OFFSET(HERE, size);
    LATEST = latestNew;
    TASKS = tasksNew;
    PUSHI(1);
  }
}

void f_saveimage() {
  size_t size = (size_t)(((char*)HERE) - TOP().s);
  fwrite(&imagemagic, sizeof(int), 1, ACTIVE_FILE);
  fwrite(&TOP().p, sizeof(cell *), 1, ACTIVE_FILE);
  fwrite(&LATEST, sizeof(cell *), 1, ACTIVE_FILE);
  fwrite(&TASKS, sizeof(cell *), 1, ACTIVE_FILE);
  fwrite(&size, sizeof(size_t), 1, ACTIVE_FILE);
  fwrite(TOP().p, 1, size, ACTIVE_FILE);
  DROP(1);
}

void f_loadfile(char *filename) {
  PUSHS(filename);
  PUSHS("loadfile");
  f_lookup();
  DROP(1);
  f_cexecute();
}

void f_loadjor(char *filename) {
  PUSHS(filename);
  PUSHS("loadjor");
  f_lookup();
  DROP(1);
  f_cexecute();
}

// does not use the jorth interpreter defined in boot.jor
void f_loadfile_cterp(char *filename) {
  cell *start = HERE;
  PUSHS(filename);
  f_dup();
  f_image_up_to_date();
  if (TOP().i) {
    DROP(1);
    f_dup();
    f_imagefilename();
    f_open();
    f_loadimage();
    f_close();
    if (TOP().i) {
      DROP(2);
      return;
    }
  }
  DROP(1);
  f_open();
  f_deactivate();
  PUSHS("key-file");
  f_lookup();
  DROP(1);
  f_swapinput();
  f_interpreter();
  f_swapinput();
  DROP(2);

  PUSHS(filename);
  f_imagefilename();
  f_overwrite();
  PUSHCP(start);
  f_saveimage();
  f_close();
}

void f_runstring(char *s) {
  PUSHS(s);
  PUSHS("loadstring");
  f_lookup();
  DROP(1);
  f_cexecute();
}

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

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

// task switching
void f_task() {
  cell *task = HERE;
  HERE += TASK_SIZE;
  memset(task, 0, TASK_SIZE * 2);
  task->p = TASKS;
  TASKS = task;
  PUSHP(task);
}

void f_suspend() {
  cell *registers = RUNNING + TASK_USER_SIZE;
  registers[0] = IP;
  registers[1].p = stack;
  registers[2].p = rstack;
  IP.p = 0;
}

void f_restore() {
  cell *registers = RUNNING + TASK_USER_SIZE;
  IP = registers[0];
  stack = registers[1].p;
  rstack = registers[2].p;
}

// run all tasks once, except the task that triggered the loop
void f_taskloop() {
  cell *task = RUNNING;
  f_suspend();
  RUNNING = TASKS;
  while (RUNNING) {
    if (RUNNING != task) {
      f_restore();
      f_colonloop();
    }
    RUNNING = RUNNING->p;
  }
  RUNNING = task;
  f_restore();
}

void f_stacksize() {
  PUSHU(STACK_SIZE);
}
void f_rstacksize() {
  PUSHU(RSTACK_SIZE);
}
void f_taskusersize() {
  PUSHU(TASK_USER_SIZE);
}

void f_rand() {
  PUSHI(rand());
}

// debugger support - emulate running the given word as if it had been
// executed from inside the part of the definition pointed to by ip
void f_emulate() { // cp ip -- ip
  cell oldIP = IP;
  IP = TOP();
  DROP(1);
  IP.p++;
  f_execute();
  PUSHP(IP.p);
  IP = oldIP;
}

void f_init(char *exe) {
  f_calc_imagemagic(exe);

  CDEF("[", f_compileoff); f_immediate();
  CDEF("]", f_compileon);
  CDEF("key", f_key);
  CDEF("key-string", f_key_string);
  CDEF("key-file", f_key_file);
  CDEF("emit", f_emit);
  CDEF("word", f_word);
  CDEF("immediate", f_immediate);
  CDEF("execute", f_execute);
  CDEF("new-word", f_create);
  CDEF("here", f_here);
  CDEF("here!", f_here_set);
  CDEF("there", f_there);
  CDEF("latest", f_latest);
  CDEF("latest!", f_latest_set);
  CDEF("tasks", f_tasks);
  CDEF("tasks!", f_tasks_set);
  CDEF("state", f_state);
  CDEF("'", f_quote); f_immediate();
  CDEF("`", f_revlookup);
  CDEF("wordname", f_wordname);
  CDEF("wordflags", f_wordflags);
  CDEF("codepointer", f_codepointer);
  CDEF("lookup", f_lookup);
  CDEF(":", f_colon);
  CDEF(";", f_semicolon); f_immediate();
  CDEF("const", f_const);
  CDEF("var", f_var);
  CDEF("allot", f_allot);
  CDEF("+", f_add);
  CDEF("-", f_sub);
  CDEF("*", f_mul);
  CDEF("/", f_div);
  CDEF("%", f_mod);
  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("u>=", f_uge);
  CDEF("u>", f_ugt);
  CDEF("u<", f_ult);
  CDEF("u<=", f_ule);
  CDEF("and", f_and);
  CDEF("or", f_or);
  CDEF("&", f_bitand);
  CDEF("|", f_bitor);
  CDEF("^", f_bitxor);
  CDEF("<<", f_shl);
  CDEF(">>", f_shr);
  CDEF("/>ratio", f_toratio);
  CDEF("*<ratio", f_fromratio);
  CDEF("@", f_get);
  CDEF("!", f_set);
  CDEF("+!", f_addset);
  CDEF("b@", f_bget);
  CDEF("ub@", f_ubget);
  CDEF("b!", f_bset);
  CDEF("!far", f_farset);
  CDEF("@far", f_farget);
  CDEF("b!far", f_farbset);
  CDEF("b@far", f_farbget);
  CDEF("dup", f_dup);
  CDEF("over", f_over);
  CDEF("drop", f_drop);
  CDEF("swap", f_swap);
  CDEF("<rot", f_rot);
  CDEF(">r", f_rput);
  CDEF("<r", f_rtake);
  CDEF("r@", f_rtop);
  CDEF("rdrop", f_rdrop);
  CDEF("rswap", f_rswap);
  CDEF("task-emit", f_taskemit);
  CDEF("task-echo", f_taskecho);
  CDEF("swap-input", f_swapinput);
  CDEF("putc", f_putc);
  CDEF("fputc", f_fputc);
  CDEF("gets", f_gets);
  CDEF("number", f_number);
  CDEF("LIT_", f_lit_);
  CDEF("GOTO_", f_goto_);
  CDEF("BZ_", f_bz_);
  CDEF("BNZ_", f_bnz_);
  CDEF("INLINEDATA_", f_inline_data_);
  CDEF("ret", f_ret);
  CDEF(".", f_dot);
  CDEF("u.", f_udot);
  CDEF("type", f_puts);
  CDEF(".s", f_printstack);
  CDEF(".rs", f_printrstack);
  CDEF(",", f_comma);
  CDEF("b,", f_bcomma);
  CDEF("open", f_open);
  CDEF("overwrite", f_overwrite);
  CDEF("close", f_close);
  CDEF("exists", f_exists);
  CDEF("factivate", f_activate);
  CDEF("fdeactivate", f_deactivate);
  CDEF("seek", f_seek);
  CDEF("seekend", f_seekend);
  CDEF("tell", f_tell);
  CDEF("fputc", f_fputc);
  CDEF("fput", f_fput);
  CDEF("fgetc", f_fgetc);
  CDEF("fget", f_fget);
  CDEF("fwrite", f_fwrite);
  CDEF("fread", f_fread);
  CDEF("findfile", f_findfirst);
  CDEF("nextfile", f_findnext);
  CDEF("chdir", f_chdir);
  CDEF("imagefilename", f_imagefilename);
  CDEF("image-uptodate", f_image_up_to_date);
  CDEF("loadimage", f_loadimage);
  CDEF("saveimage", f_saveimage);
  CDEF("memmove", f_memmove);
  CDEF("quiet", f_quiet);
  CDEF("loud", f_loud);
  CDEF("task", f_task);
  CDEF("suspend", f_suspend);
  CDEF("taskloop", f_taskloop);
  CDEF("running", f_running);
  CDEF("stacksize", f_stacksize);
  CDEF("rstacksize", f_rstacksize);
  CDEF("task-user-size", f_taskusersize);
  CDEF("rand", f_rand);
  CDEF("emulate", f_emulate);
  PCONST("$DOCREATE", f_docreate);
  PCONST("$DOVAR", f_dovar);
  PCONST("$DODEFERRED", f_dodeferred);
  ICONST("imagemagic", imagemagic);
#ifdef TRACE
  CDEF("traceon", f_traceon);
  CDEF("traceoff", f_traceoff);
#endif

  f_loadfile_cterp("boot.jor");
  f_loadfile("defs.jor");
}

cell f_lookupcp(char *name) {
  cell result = {0};
  PUSHS(name);
  f_lookup();
  if (TOP().u) {
    result = ST1();
  }
  DROP(2);
  return result;
}

void f_execcp(cell cp) {
  PUSHC(cp);
  f_cexecute();
}

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

void f_repl() {
  char input[256];

  CDEF("quit", f_quit);
  f_runstring("stdout");
  while (!DIE) {
    f_runstring(gets(input));
  }
}