From d794d27e54a51ce70ab8304dbfa2431bfec6838b Mon Sep 17 00:00:00 2001 From: elioat Date: Wed, 19 Oct 2022 22:06:24 -0400 Subject: * --- c/lbForth.c | 1124 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 1124 insertions(+) create mode 100644 c/lbForth.c diff --git a/c/lbForth.c b/c/lbForth.c new file mode 100644 index 0000000..4295434 --- /dev/null +++ b/c/lbForth.c @@ -0,0 +1,1124 @@ +/******************************************************************************* +* +* A minimal Forth compiler in C +* By Leif Bruder 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 + +/* 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, ¬Read, &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, ¬Read, &isDouble); + if (notRead) + { + tell("Unknown word: "); + for (i=0; i", 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; +} -- cgit 1.4.1-2-gfad0