pete286/forp.c

632 lines
11 KiB
C
Executable file

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