#include #include "forp.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; char *INPUT = NULL; FILE *INPUT_FILE = NULL; FILE *OUTPUT_FILE = NULL; #define QUIET (*(RUNNING + TASK_USER_QUIET)) 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_latest() { PUSHCP(LATEST); } void f_state() { PUSHC(STATE); } void f_running() { PUSHCP(RUNNING); } #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_execute(); 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->f) { keyword->f(); } else { PUSHI(0); } if (!QUIET.i && echoword->p) { f_dup(); PUSHCP(echoword->p); f_execute(); } } 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) { cell *echoword = RUNNING + TASK_USER_ECHO; cell *emitword = RUNNING + TASK_USER_EMIT; if (echoword->p) { f_dup(); PUSHCP(echoword->p); f_execute(); } if (emitword->p) { PUSHCP(emitword->p); f_execute(); } } } void f_putc() { printf("%c", TOP().i); DROP(1); } void f_fputc() { fputc(ST1().i, TOP().fp); DROP(2); } 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_printstack() { cell *v = RUNNING + STACK_OFFSET; while (v != stack) { PUSHC(*v++); f_dot(); } } 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_execute() { cell oldW = W; cell oldIP = IP; cell *oldRstack; cell retIP; retIP.p = NULL; RPUSH(retIP); oldRstack = rstack; W = TOP(); DROP(1); W.p->f(); if (oldRstack == rstack) { RPOP(); } W = oldW; IP = oldIP; } void f_docolon(); void f_colonloop() { while (IP.p) { 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_docolon() { IP.p = W.p + 1; f_colonloop(); } 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() { 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); 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(); } } 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() { cell *key = RUNNING + TASK_USER_KEY; cell *keysrc = RUNNING + TASK_USER_KEYSRC; cell oldKey = *key; cell oldKeysrc = *keysrc; key->f = f_key_file; keysrc->fp = TOP().fp; DROP(1); f_interpreter(); if (key->fp != NULL) { fclose(key->fp); } *key = oldKey; *keysrc = oldKeysrc; } void f_loadstring() { cell *key = RUNNING + TASK_USER_KEY; cell *keysrc = RUNNING + TASK_USER_KEYSRC; cell oldKey = *key; cell oldKeysrc = *keysrc; key->f = f_key_string; keysrc->s = TOP().s; DROP(1); f_interpreter(); *key = oldKey; *keysrc = 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_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; } // 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); } #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("task-emit", f_taskemit); CDEF("task-echo", f_taskecho); CDEF("putc", f_putc); CDEF("fputc", f_fputc); 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("type", f_puts); CDEF(".s", f_printstack); 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("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); f_loadfile("defs.frp"); } int DIE = 0; void f_quit() { DIE = 1; } void f_repl() { char inputbuf[256]; CDEF("quit", f_quit); while (!DIE) { int len; gets(inputbuf); len = strlen(inputbuf); inputbuf[len] = '\n'; inputbuf[len + 1] = 0; PUSHS(inputbuf); f_runstring("REPL send"); f_taskloop(); } }