forth_native.c

/*******************************************************************************
*
* A minimal Forth compiler in C
* By Leif Bruder <leifbruder@gmail.com> http://defineanswer42.wordpress.com
* Release 2014-04-04
*
* Based on Richard W.M. Jones' excellent Jonesforth sources/tutorial
*
* PUBLIC DOMAIN
*
* I, the copyright holder of this work, hereby release it into the public
* domain. This applies worldwide. In case this is not legally possible, I grant
* any entity the right to use this work for any purpose, without any conditions,
* unless such conditions are required by law.
*
*******************************************************************************/

/* Only a single include here; I'll define everything on the fly to keep
* dependencies as low as possible. In this file, the only C standard functions
* used are getchar, putchar and the EOF value. */
#include <stdio.h>

/* Base cell data types. Use short/long on most systems for 16 bit cells. */
/* Experiment here if necessary. */
#define CELL_BASE_TYPE int
#define DOUBLE_CELL_BASE_TYPE long

/* Basic memory configuration */
#define MEM_SIZE 65536     /* main memory size in bytes */
#define STACK_SIZE 192     /* cells reserved for the stack */
#define RSTACK_SIZE 64     /* cells reserved for the return stack */
#define INPUT_LINE_SIZE 32 /* bytes reserved for the WORD buffer */

/******************************************************************************/

/* Our basic data types */
typedef CELL_BASE_TYPE scell;
typedef DOUBLE_CELL_BASE_TYPE dscell;
typedef unsigned CELL_BASE_TYPE cell;
typedef unsigned DOUBLE_CELL_BASE_TYPE dcell;
typedef unsigned char byte;
#define CELL_SIZE sizeof(cell)
#define DCELL_SIZE sizeof(dcell)

/* A few constants that describe the memory layout of this implementation */
#define LATEST_POSITION INPUT_LINE_SIZE
#define HERE_POSITION (LATEST_POSITION + CELL_SIZE)
#define BASE_POSITION (HERE_POSITION + CELL_SIZE)
#define STATE_POSITION (BASE_POSITION + CELL_SIZE)
#define STACK_POSITION (STATE_POSITION + CELL_SIZE)
#define RSTACK_POSITION (STACK_POSITION + STACK_SIZE * CELL_SIZE)
#define HERE_START (RSTACK_POSITION + RSTACK_SIZE * CELL_SIZE)
#define MAX_BUILTIN_ID 71

/* Flags and masks for the dictionary */
#define FLAG_IMMEDIATE 0x80
#define FLAG_HIDDEN 0x40
#define MASK_NAMELENGTH 0x1F

/* This is the main memory to be used by this Forth. There will be no malloc
* in this file. */
byte memory[MEM_SIZE];

/* Pointers to Forth variables stored inside the main memory array */
cell *latest;
cell *here;
cell *base;
cell *state;
cell *sp;
cell *stack;
cell *rsp;
cell *rstack;

/* A few helper variables for the compiler */
int exitReq;
int errorFlag;
cell next;
cell lastIp;
cell quit_address;
cell commandAddress;
cell maxBuiltinAddress;

/* The TIB, stored outside the main memory array for now */
char lineBuffer[128];
int charsInLineBuffer = 0;
int positionInLineBuffer = 0;

/* A basic setup for defining builtins. This Forth uses impossibly low
* adresses as IDs for the builtins so we can define builtins as
* standard C functions. Slower but easier to port. */
#define BUILTIN(id, name, c_name, flags) \
  const int c_name##_id = id;            \
  const char *c_name##_name = name;      \
  const byte c_name##_flags = flags;     \
  void c_name()
#define ADD_BUILTIN(c_name) addBuiltin(c_name##_id, c_name##_name, c_name##_flags, c_name)
typedef void (*builtin)();
builtin builtins[MAX_BUILTIN_ID] = {0};

/* This is our initialization script containing all the words we define in
* Forth for convenience. Focus is on simplicity, not speed. Partly copied from
* Jonesforth (see top of file). */
char *initscript_pos;
const char *initScript =
    ": DECIMAL 10 BASE ! ;\n"
    ": HEX 16 BASE ! ;\n"
    ": OCTAL 8 BASE ! ;\n"
    ": 2DUP OVER OVER ;\n"
    ": 2DROP DROP DROP ;\n"
    ": NIP SWAP DROP ;\n"
    ": 2NIP 2SWAP 2DROP ;\n"
    ": TUCK SWAP OVER ;\n"
    ": / /MOD NIP ;\n"
    ": MOD /MOD DROP ;\n"
    ": BL 32 ;\n"
    ": CR 10 EMIT ;\n"
    ": SPACE BL EMIT ;\n"
    ": NEGATE 0 SWAP - ;\n"
    ": DNEGATE 0. 2SWAP D- ;\n"
    ": CELLS CELL * ;\n"
    ": ALLOT HERE @ + HERE ! ;\n"
    ": TRUE -1 ;\n"
    ": FALSE 0 ;\n"
    ": 0= 0 = ;\n"
    ": 0< 0 < ;\n"
    ": 0> 0 > ;\n"
    ": <> = 0= ;\n"
    ": <= > 0= ;\n"
    ": >= < 0= ;\n"
    ": 0<= 0 <= ;\n"
    ": 0>= 0 >= ;\n"
    ": 1+ 1 + ;\n"
    ": 1- 1 - ;\n"
    ": 2+ 2 + ;\n"
    ": 2- 2 - ;\n"
    ": 2/ 2 / ;\n"
    ": 2* 2 * ;\n"
    ": D2/ 2. D/ ;\n"
    ": +! DUP @ ROT + SWAP ! ;\n"
    ": [COMPILE] WORD FIND >CFA , ; IMMEDIATE\n"
    ": [CHAR] key ' LIT , , ; IMMEDIATE\n"
    ": RECURSE LATEST @ >CFA , ; IMMEDIATE\n"
    ": DOCOL 0 ;\n"
    ": CONSTANT CREATE DOCOL , ' LIT , , ' EXIT , ;\n"
    ": 2CONSTANT SWAP CREATE DOCOL , ' LIT , , ' LIT , , ' EXIT , ;\n"
    ": VARIABLE HERE @ CELL ALLOT CREATE DOCOL , ' LIT , , ' EXIT , ;\n"     /* TODO: Allot AFTER the code, not before */
    ": 2VARIABLE HERE @ 2 CELLS ALLOT CREATE DOCOL , ' LIT , , ' EXIT , ;\n" /* TODO: Allot AFTER the code, not before */
    ": IF ' 0BRANCH , HERE @ 0 , ; IMMEDIATE\n"
    ": THEN DUP HERE @ SWAP - SWAP ! ; IMMEDIATE\n"
    ": ELSE ' BRANCH , HERE @ 0 , SWAP DUP HERE @ SWAP - SWAP ! ; IMMEDIATE\n"
    ": BEGIN HERE @ ; IMMEDIATE\n"
    ": UNTIL ' 0BRANCH , HERE @ - , ; IMMEDIATE\n"
    ": AGAIN ' BRANCH , HERE @ - , ; IMMEDIATE\n"
    ": WHILE ' 0BRANCH , HERE @ 0 , ; IMMEDIATE\n"
    ": REPEAT ' BRANCH , SWAP HERE @ - , DUP HERE @ SWAP - SWAP ! ; IMMEDIATE\n"
    ": UNLESS ' 0= , [COMPILE] IF ; IMMEDIATE\n"
    ": DO HERE @ ' SWAP , ' >R , ' >R , ; IMMEDIATE\n"
    ": LOOP ' R> , ' R> , ' SWAP , ' 1+ , ' 2DUP , ' = , ' 0BRANCH , HERE @ - , ' 2DROP , ; IMMEDIATE\n"
    ": +LOOP ' R> , ' R> , ' SWAP , ' ROT , ' + , ' 2DUP , ' <= , ' 0BRANCH , HERE @ - , ' 2DROP , ; IMMEDIATE\n"
    ": I ' R@ , ; IMMEDIATE\n"
    ": SPACES DUP 0> IF 0 DO SPACE LOOP ELSE DROP THEN ;\n"
    ": ABS DUP 0< IF NEGATE THEN ;\n"
    ": DABS 2DUP 0. D< IF DNEGATE THEN ;\n"
    ": .DIGIT DUP 9 > IF 55 ELSE 48 THEN + EMIT ;\n"
    ": .SIGN DUP 0< IF 45 EMIT NEGATE THEN ;\n" /* BUG: 10000000000... will be shown wrong */
    ": .POS BASE @ /MOD ?DUP IF RECURSE THEN .DIGIT ;\n"
    ": . .SIGN DUP IF .POS ELSE .DIGIT THEN ;\n"
    ": COUNTPOS SWAP 1 + SWAP BASE @ / ?DUP IF RECURSE THEN ;\n"
    ": DIGITS DUP 0< IF 1 ELSE 0 THEN SWAP COUNTPOS ;\n"
    ": .R OVER DIGITS - SPACES . ;\n"
    ": . . SPACE ;\n"
    ": ? @ . ;\n"
    ": .S DSP@ BEGIN DUP S0@ > WHILE DUP ? CELL - REPEAT DROP ;\n"
    ": TYPE 0 DO DUP C@ EMIT 1 + LOOP DROP ;\n"
    ": ALIGN BEGIN HERE @ CELL MOD WHILE 0 C, REPEAT ;\n"
    ": s\" ' LITSTRING , HERE @ 0 , BEGIN KEY DUP 34 <> WHILE C, REPEAT DROP DUP HERE @ SWAP - CELL - SWAP ! ALIGN ; IMMEDIATE\n"
    ": .\" [COMPILE] s\" ' TYPE , ; IMMEDIATE\n"
    ": ( BEGIN KEY [CHAR] ) = UNTIL ; IMMEDIATE\n"
    ": COUNT DUP 1+ SWAP C@ ;\n"
    ": MIN 2DUP < IF DROP ELSE NIP THEN ;\n"
    ": MAX 2DUP > IF DROP ELSE NIP THEN ;\n"
    ": D0= OR 0= ;\n"
    ": DMIN 2OVER 2OVER D< IF 2DROP ELSE 2NIP THEN ;\n"
    ": DMAX 2OVER 2OVER D> IF 2DROP ELSE 2NIP THEN ;\n";

/******************************************************************************/

/* The primary data output function. This is the place to change if you want
* to e.g. output data on a microcontroller via a serial interface. */
void putkey(char c)
{
  putchar(c);
}

/* The primary data input function. This is where you place the code to e.g.
* read from a serial line. */
int llkey()
{
  if (*initscript_pos)
    return *(initscript_pos++);
  return getchar();
}

/* Anything waiting in the keyboard buffer? */
int keyWaiting()
{
  return positionInLineBuffer < charsInLineBuffer ? -1 : 0;
}

/* Line buffered character input. We're duplicating the functionality of the
* stdio library here to make the code easier to port to other input sources */
int getkey()
{
  int c;

  if (keyWaiting())
    return lineBuffer[positionInLineBuffer++];

  charsInLineBuffer = 0;
  while ((c = llkey()) != EOF)
  {
    if (charsInLineBuffer == sizeof(lineBuffer))
      break;
    lineBuffer[charsInLineBuffer++] = c;
    if (c == '\n')
      break;
  }

  positionInLineBuffer = 1;
  return lineBuffer[0];
}

/* C string output */
void tell(const char *str)
{
  while (*str)
    putkey(*str++);
}

/* The basic (data) stack operations */

cell pop()
{
  if (*sp == 1)
  {
    tell("? Stack underflow\n");
    errorFlag = 1;
    return 0;
  }
  return stack[--(*sp)];
}

cell tos()
{
  if (*sp == 1)
  {
    tell("? Stack underflow\n");
    errorFlag = 1;
    return 0;
  }
  return stack[(*sp) - 1];
}

void push(cell data)
{
  if (*sp >= STACK_SIZE)
  {
    tell("? Stack overflow\n");
    errorFlag = 1;
    return;
  }
  stack[(*sp)++] = data;
}

dcell dpop()
{
  cell tmp[2];
  tmp[1] = pop();
  tmp[0] = pop();
  return *((dcell *)tmp);
}

void dpush(dcell data)
{
  cell tmp[2];
  *((dcell *)tmp) = data;
  push(tmp[0]);
  push(tmp[1]);
}

/* The basic return stack operations */

cell rpop()
{
  if (*rsp == 1)
  {
    tell("? RStack underflow\n");
    errorFlag = 1;
    return 0;
  }
  return rstack[--(*rsp)];
}

void rpush(cell data)
{
  if (*rsp >= RSTACK_SIZE)
  {
    tell("? RStack overflow\n");
    errorFlag = 1;
    return;
  }
  rstack[(*rsp)++] = data;
}

/* Secure memory access */

cell readMem(cell address)
{
  if (address > MEM_SIZE)
  {
    tell("Internal error in readMem: Invalid addres\n");
    errorFlag = 1;
    return 0;
  }
  return *((cell *)(memory + address));
}

void writeMem(cell address, cell value)
{
  if (address > MEM_SIZE)
  {
    tell("Internal error in writeMem: Invalid address\n");
    errorFlag = 1;
    return;
  }
  *((cell *)(memory + address)) = value;
}

/* Reading a word into the input line buffer */
byte readWord()
{
  char *line = (char *)memory;
  byte len = 0;
  int c;

  while ((c = getkey()) != EOF)
  {
    if (c == ' ')
      continue;
    if (c == '\n')
      continue;
    if (c != '\\')
      break;

    while ((c = getkey()) != EOF)
      if (c == '\n')
        break;
  }

  while (c != ' ' && c != '\n' && c != EOF)
  {
    if (len >= (INPUT_LINE_SIZE - 1))
      break;
    line[++len] = c;
    c = getkey();
  }
  line[0] = len;
  return len;
}

/* toupper() clone so we don't have to pull in ctype.h */
char up(char c)
{
  return (c >= 'a' && c <= 'z') ? c - 'a' + 'A' : c;
}

/* Dictionary lookup */
cell findWord(cell address, cell len)
{
  cell ret = *latest;
  char *name = (char *)&memory[address];
  cell i;
  int found;

  for (ret = *latest; ret; ret = readMem(ret))
  {
    if ((memory[ret + CELL_SIZE] & MASK_NAMELENGTH) != len)
      continue;
    if (memory[ret + CELL_SIZE] & FLAG_HIDDEN)
      continue;

    found = 1;
    for (i = 0; i < len; i++)
    {
      if (up(memory[ret + i + 1 + CELL_SIZE]) != up(name[i]))
      {
        found = 0;
        break;
      }
    }
    if (found)
      break;
  }
  return ret;
}

/* Basic number parsing, base <= 36 only atm */
void parseNumber(byte *word, cell len, dcell *number, cell *notRead, byte *isDouble)
{
  int negative = 0;
  cell i;
  char c;
  cell current;

  *number = 0;
  *isDouble = 0;

  if (len == 0)
  {
    *notRead = 0;
    return;
  }

  if (word[0] == '-')
  {
    negative = 1;
    len--;
    word++;
  }
  else if (word[0] == '+')
  {
    len--;
    word++;
  }

  for (i = 0; i < len; i++)
  {
    c = *word;
    word++;
    if (c == '.')
    {
      *isDouble = 1;
      continue;
    }
    else if (c >= '0' && c <= '9')
      current = c - '0';
    else if (c >= 'A' && c <= 'Z')
      current = 10 + c - 'A';
    else if (c >= 'a' && c <= 'z')
      current = 10 + c - 'a';
    else
      break;

    if (current >= *base)
      break;

    *number = *number * *base + current;
  }

  *notRead = len - i;
  if (negative)
    *number = (-((scell)*number));
}

/*******************************************************************************
*
* Builtin definitions
*
*******************************************************************************/

BUILTIN(0, "RUNDOCOL", docol, 0)
{
  rpush(lastIp);
  next = commandAddress + CELL_SIZE;
}

/* The first few builtins are very simple, not need to waste vertical space here */
BUILTIN(1, "CELL", doCellSize, 0) { push(CELL_SIZE); }
BUILTIN(2, "@", memRead, 0) { push(readMem(pop())); }
BUILTIN(3, "C@", memReadByte, 0) { push(memory[pop()]); }
BUILTIN(4, "KEY", key, 0) { push(getkey()); }
BUILTIN(5, "EMIT", emit, 0) { putkey(pop() & 255); }
BUILTIN(6, "DROP", drop, 0) { pop(); }
BUILTIN(7, "EXIT", doExit, 0) { next = rpop(); }
BUILTIN(8, "BYE", bye, 0) { exitReq = 1; }
BUILTIN(9, "LATEST", doLatest, 0) { push(LATEST_POSITION); }
BUILTIN(10, "HERE", doHere, 0) { push(HERE_POSITION); }
BUILTIN(11, "BASE", doBase, 0) { push(BASE_POSITION); }
BUILTIN(12, "STATE", doState, 0) { push(STATE_POSITION); }
BUILTIN(13, "[", gotoInterpreter, FLAG_IMMEDIATE) { *state = 0; }
BUILTIN(14, "]", gotoCompiler, 0) { *state = 1; }
BUILTIN(15, "HIDE", hide, 0) { memory[*latest + CELL_SIZE] ^= FLAG_HIDDEN; }
BUILTIN(16, "R>", rtos, 0) { push(rpop()); }
BUILTIN(17, ">R", stor, 0) { rpush(pop()); }
BUILTIN(18, "KEY?", key_p, 0) { push(keyWaiting()); }
BUILTIN(19, "BRANCH", branch, 0) { next += readMem(next); }
BUILTIN(20, "0BRANCH", zbranch, 0) { next += pop() ? CELL_SIZE : readMem(next); }
BUILTIN(21, "IMMEDIATE", toggleImmediate, FLAG_IMMEDIATE) { memory[*latest + CELL_SIZE] ^= FLAG_IMMEDIATE; }
BUILTIN(22, "FREE", doFree, 0) { push(MEM_SIZE - *here); }
BUILTIN(23, "S0@", s0_r, 0) { push(STACK_POSITION + CELL_SIZE); }
BUILTIN(24, "DSP@", dsp_r, 0) { push(STACK_POSITION + *sp * CELL_SIZE); }
BUILTIN(25, "NOT", not, 0) { push(~pop()); }
BUILTIN(26, "DUP", dup, 0) { push(tos()); }

BUILTIN(27, "!", memWrite, 0)
{
  cell address = pop();
  cell value = pop();
  writeMem(address, value);
}

BUILTIN(28, "C!", memWriteByte, 0)
{
  cell address = pop();
  cell value = pop();
  memory[address] = value & 255;
}

BUILTIN(29, "SWAP", swap, 0)
{
  cell a = pop();
  cell b = pop();
  push(a);
  push(b);
}

BUILTIN(30, "OVER", over, 0)
{
  cell a = pop();
  cell b = tos();
  push(a);
  push(b);
}

BUILTIN(31, ",", comma, 0)
{
  push(*here);
  memWrite();
  *here += CELL_SIZE;
}

BUILTIN(32, "C,", commaByte, 0)
{
  push(*here);
  memWriteByte();
  *here += sizeof(byte);
}

BUILTIN(33, "WORD", word, 0)
{
  byte len = readWord();
  push(1);
  push(len);
}

BUILTIN(34, "FIND", find, 0)
{
  cell len = pop();
  cell address = pop();
  cell ret = findWord(address, len);
  push(ret);
}

cell getCfa(cell address)
{
  byte len = (memory[address + CELL_SIZE] & MASK_NAMELENGTH) + 1;
  while ((len & (CELL_SIZE - 1)) != 0)
    len++;
  return address + CELL_SIZE + len;
}

BUILTIN(35, ">CFA", cfa, 0)
{
  cell address = pop();
  cell ret = getCfa(address);
  if (ret < maxBuiltinAddress)
    push(readMem(ret));
  else
    push(ret);
}

BUILTIN(36, "NUMBER", number, 0)
{
  dcell num;
  cell notRead;
  byte isDouble;
  cell len = pop();
  byte *address = &memory[pop()];
  parseNumber(address, len, &num, &notRead, &isDouble);
  if (isDouble)
    dpush(num);
  else
    push((cell)num);
  push(notRead);
}

BUILTIN(37, "LIT", lit, 0)
{
  push(readMem(next));
  next += CELL_SIZE;
}

/* Outer and inner interpreter, TODO split up */
BUILTIN(38, "QUIT", quit, 0)
{
  cell address;
  dcell number;
  cell notRead;
  cell command;
  int i;
  byte isDouble;
  cell tmp[2];

  int immediate;

  for (exitReq = 0; exitReq == 0;)
  {
    lastIp = next = quit_address;
    errorFlag = 0;

    word();
    find();

    address = pop();
    if (address)
    {
      immediate = (memory[address + CELL_SIZE] & FLAG_IMMEDIATE);
      commandAddress = getCfa(address);
      command = readMem(commandAddress);
      if (*state && !immediate)
      {
        if (command < MAX_BUILTIN_ID && command != docol_id)
          push(command);
        else
          push(commandAddress);
        comma();
      }
      else
      {
        while (!errorFlag && !exitReq)
        {
          if (command == quit_id)
            break;
          else if (command < MAX_BUILTIN_ID)
            builtins[command]();
          else
          {
            lastIp = next;
            next = command;
          }

          commandAddress = next;
          command = readMem(commandAddress);
          next += CELL_SIZE;
        }
      }
    }
    else
    {
      parseNumber(&memory[1], memory[0], &number, &notRead, &isDouble);
      if (notRead)
      {
        tell("Unknown word: ");
        for (i = 0; i < memory[0]; i++)
          putkey(memory[i + 1]);
        putkey('\n');

        *sp = *rsp = 1;
        continue;
      }
      else
      {
        if (*state)
        {
          *((dcell *)tmp) = number;
          push(lit_id);
          comma();

          if (isDouble)
          {
            push(tmp[0]);
            comma();
            push(lit_id);
            comma();
            push(tmp[1]);
            comma();
          }
          else
          {
            push((cell)number);
            comma();
          }
        }
        else
        {
          if (isDouble)
            dpush(number);
          else
            push((cell)number);
        }
      }
    }

    if (errorFlag)
      *sp = *rsp = 1;
    else if (!keyWaiting() && !(*initscript_pos))
      tell(" OK\n");
  }
}

BUILTIN(39, "+", plus, 0)
{
  scell n1 = pop();
  scell n2 = pop();
  push(n1 + n2);
}

BUILTIN(40, "-", minus, 0)
{
  scell n1 = pop();
  scell n2 = pop();
  push(n2 - n1);
}

BUILTIN(41, "*", mul, 0)
{
  scell n1 = pop();
  scell n2 = pop();
  push(n1 * n2);
}

BUILTIN(42, "/MOD", divmod, 0)
{
  scell n1 = pop();
  scell n2 = pop();
  push(n2 % n1);
  push(n2 / n1);
}

BUILTIN(43, "ROT", rot, 0)
{
  cell a = pop();
  cell b = pop();
  cell c = pop();
  push(b);
  push(a);
  push(c);
}

void createWord(const char *name, byte len, byte flags);
BUILTIN(44, "CREATE", doCreate, 0)
{
  byte len;
  cell address;
  word();
  len = pop() & 255;
  address = pop();
  createWord((char *)&memory[address], len, 0);
}

BUILTIN(45, ":", colon, 0)
{
  doCreate();
  push(docol_id);
  comma();
  hide();
  *state = 1;
}

BUILTIN(46, ";", semicolon, FLAG_IMMEDIATE)
{
  push(doExit_id);
  comma();
  hide();
  *state = 0;
}

BUILTIN(47, "R@", rget, 0)
{
  cell tmp = rpop();
  rpush(tmp);
  push(tmp);
}

BUILTIN(48, "J", doJ, 0)
{
  cell tmp1 = rpop();
  cell tmp2 = rpop();
  cell tmp3 = rpop();
  rpush(tmp3);
  rpush(tmp2);
  rpush(tmp1);
  push(tmp3);
}

BUILTIN(49, "'", tick, FLAG_IMMEDIATE)
{
  word();
  find();
  cfa();

  if (*state)
  {
    push(lit_id);
    comma();
    comma();
  }
}

BUILTIN(50, "=", equals, 0)
{
  cell a1 = pop();
  cell a2 = pop();
  push(a2 == a1 ? -1 : 0);
}

BUILTIN(51, "<", smaller, 0)
{
  scell a1 = pop();
  scell a2 = pop();
  push(a2 < a1 ? -1 : 0);
}

BUILTIN(52, ">", larger, 0)
{
  scell a1 = pop();
  scell a2 = pop();
  push(a2 > a1 ? -1 : 0);
}

BUILTIN(53, "AND", doAnd, 0)
{
  cell a1 = pop();
  cell a2 = pop();
  push(a2 & a1);
}

BUILTIN(54, "OR", doOr, 0)
{
  cell a1 = pop();
  cell a2 = pop();
  push(a2 | a1);
}

BUILTIN(55, "?DUP", p_dup, 0)
{
  cell a = tos();
  if (a)
    push(a);
}

BUILTIN(56, "LITSTRING", litstring, 0)
{
  cell length = readMem(next);
  next += CELL_SIZE;
  push(next);
  push(length);
  next += length;
  while (next & (CELL_SIZE - 1))
    next++;
}

BUILTIN(57, "XOR", xor, 0)
{
  cell a = pop();
  cell b = pop();
  push(a ^ b);
}

BUILTIN(58, "*/", timesDivide, 0)
{
  cell n3 = pop();
  dcell n2 = pop();
  dcell n1 = pop();
  dcell r = (n1 * n2) / n3;
  push((cell)r);
  if ((cell)r != r)
  {
    tell("Arithmetic overflow\n");
    errorFlag = 1;
  }
}

BUILTIN(59, "*/MOD", timesDivideMod, 0)
{
  cell n3 = pop();
  dcell n2 = pop();
  dcell n1 = pop();
  dcell r = (n1 * n2) / n3;
  dcell m = (n1 * n2) % n3;
  push((cell)m);
  push((cell)r);
  if ((cell)r != r)
  {
    tell("Arithmetic overflow\n");
    errorFlag = 1;
  }
}

BUILTIN(60, "D=", dequals, 0)
{
  dcell a1 = dpop();
  dcell a2 = dpop();
  push(a2 == a1 ? -1 : 0);
}

BUILTIN(61, "D<", dsmaller, 0)
{
  dscell a1 = dpop();
  dscell a2 = dpop();
  push(a2 < a1 ? -1 : 0);
}

BUILTIN(62, "D>", dlarger, 0)
{
  dscell a1 = dpop();
  dscell a2 = dpop();
  push(a2 > a1 ? -1 : 0);
}

BUILTIN(63, "DU<", dusmaller, 0)
{
  dcell a1 = dpop();
  dcell a2 = dpop();
  push(a2 < a1 ? -1 : 0);
}

BUILTIN(64, "D+", dplus, 0)
{
  dscell n1 = dpop();
  dscell n2 = dpop();
  dpush(n1 + n2);
}

BUILTIN(65, "D-", dminus, 0)
{
  dscell n1 = dpop();
  dscell n2 = dpop();
  dpush(n2 - n1);
}

BUILTIN(66, "D*", dmul, 0)
{
  dscell n1 = dpop();
  dscell n2 = dpop();
  dpush(n1 * n2);
}

BUILTIN(67, "D/", ddiv, 0)
{
  dscell n1 = dpop();
  dscell n2 = dpop();
  dpush(n2 / n1);
}

BUILTIN(68, "2SWAP", dswap, 0)
{
  dcell a = dpop();
  dcell b = dpop();
  dpush(a);
  dpush(b);
}

BUILTIN(69, "2OVER", dover, 0)
{
  dcell a = dpop();
  dcell b = dpop();
  dpush(b);
  dpush(a);
  dpush(b);
}

BUILTIN(70, "2ROT", drot, 0)
{
  dcell a = dpop();
  dcell b = dpop();
  dcell c = dpop();
  dpush(b);
  dpush(a);
  dpush(c);
}

/*******************************************************************************
*
* Loose ends
*
*******************************************************************************/

/* Create a word in the dictionary */
void createWord(const char *name, byte len, byte flags)
{
  cell newLatest = *here;
  push(*latest);
  comma();
  push(len | flags);
  commaByte();
  while (len--)
  {
    push(*name);
    commaByte();
    name++;
  }
  while (*here & (CELL_SIZE - 1))
  {
    push(0);
    commaByte();
  }
  *latest = newLatest;
}

/* A simple strlen clone so we don't have to pull in string.h */
byte slen(const char *str)
{
  byte ret = 0;
  while (*str++)
    ret++;
  return ret;
}

/* Add a builtin to the dictionary */
void addBuiltin(cell code, const char *name, const byte flags, builtin f)
{
  if (errorFlag)
    return;

  if (code >= MAX_BUILTIN_ID)
  {
    tell("Error adding builtin ");
    tell(name);
    tell(": Out of builtin IDs\n");
    errorFlag = 1;
    return;
  }

  if (builtins[code] != 0)
  {
    tell("Error adding builtin ");
    tell(name);
    tell(": ID given twice\n");
    errorFlag = 1;
    return;
  }

  builtins[code] = f;
  createWord(name, slen(name), flags);
  push(code);
  comma();
  push(doExit_id);
  comma();
}

/* Program setup and jump to outer interpreter */
int main()
{
  errorFlag = 0;

  if (DCELL_SIZE != 2 * CELL_SIZE)
  {
    tell("Configuration error: DCELL_SIZE != 2*CELL_SIZE\n");
    return 1;
  }

  state = (cell *)&memory[STATE_POSITION];
  base = (cell *)&memory[BASE_POSITION];
  latest = (cell *)&memory[LATEST_POSITION];
  here = (cell *)&memory[HERE_POSITION];
  sp = (cell *)&memory[STACK_POSITION];
  stack = (cell *)&memory[STACK_POSITION + CELL_SIZE];
  rsp = (cell *)&memory[RSTACK_POSITION];
  rstack = (cell *)&memory[RSTACK_POSITION + CELL_SIZE];

  *sp = *rsp = 1;
  *state = 0;
  *base = 10;
  *latest = 0;
  *here = HERE_START;

  ADD_BUILTIN(docol);
  ADD_BUILTIN(doCellSize);
  ADD_BUILTIN(memRead);
  ADD_BUILTIN(memWrite);
  ADD_BUILTIN(memReadByte);
  ADD_BUILTIN(memWriteByte);
  ADD_BUILTIN(key);
  ADD_BUILTIN(emit);
  ADD_BUILTIN(swap);
  ADD_BUILTIN(dup);
  ADD_BUILTIN(drop);
  ADD_BUILTIN(over);
  ADD_BUILTIN(comma);
  ADD_BUILTIN(commaByte);
  ADD_BUILTIN(word);
  ADD_BUILTIN(find);
  ADD_BUILTIN(cfa);
  ADD_BUILTIN(doExit);
  ADD_BUILTIN(quit);
  quit_address = getCfa(*latest);
  ADD_BUILTIN(number);
  ADD_BUILTIN(bye);
  ADD_BUILTIN(doLatest);
  ADD_BUILTIN(doHere);
  ADD_BUILTIN(doBase);
  ADD_BUILTIN(doState);
  ADD_BUILTIN(plus);
  ADD_BUILTIN(minus);
  ADD_BUILTIN(mul);
  ADD_BUILTIN(divmod);
  ADD_BUILTIN(rot);
  ADD_BUILTIN(gotoInterpreter);
  ADD_BUILTIN(gotoCompiler);
  ADD_BUILTIN(doCreate);
  ADD_BUILTIN(hide);
  ADD_BUILTIN(lit);
  ADD_BUILTIN(colon);
  ADD_BUILTIN(semicolon);
  ADD_BUILTIN(rtos);
  ADD_BUILTIN(stor);
  ADD_BUILTIN(rget);
  ADD_BUILTIN(doJ);
  ADD_BUILTIN(tick);
  ADD_BUILTIN(key_p);
  ADD_BUILTIN(equals);
  ADD_BUILTIN(smaller);
  ADD_BUILTIN(larger);
  ADD_BUILTIN(doAnd);
  ADD_BUILTIN(doOr);
  ADD_BUILTIN(branch);
  ADD_BUILTIN(zbranch);
  ADD_BUILTIN(toggleImmediate);
  ADD_BUILTIN(doFree);
  ADD_BUILTIN(p_dup);
  ADD_BUILTIN(s0_r);
  ADD_BUILTIN(dsp_r);
  ADD_BUILTIN(litstring);
  ADD_BUILTIN(not);
  ADD_BUILTIN (xor);
  ADD_BUILTIN(timesDivide);
  ADD_BUILTIN(timesDivideMod);
  ADD_BUILTIN(dequals);
  ADD_BUILTIN(dsmaller);
  ADD_BUILTIN(dlarger);
  ADD_BUILTIN(dusmaller);
  ADD_BUILTIN(dplus);
  ADD_BUILTIN(dminus);
  ADD_BUILTIN(dmul);
  ADD_BUILTIN(ddiv);
  ADD_BUILTIN(dswap);
  ADD_BUILTIN(dover);
  ADD_BUILTIN(drot);

  maxBuiltinAddress = (*here) - 1;

  if (errorFlag)
    return 1;

  initscript_pos = (char *)initScript;
  quit();
  return 0;
}