#include #include "jorth.h" #include "serial.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; #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_latest() { PUSHCP(LATEST); } 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, i, %) 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_bset() { char *p = (char*)TOP().p; DROP(1); (*p) = TOP().i; 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_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) { char byte = 0; if (fread(&byte, 1, 1, ACTIVE_FILE) == 1) { result = byte; } } PUSHI(result); } void f_fget() { if (ACTIVE_FILE) { int result = 0; fread(&result, 2, 1, ACTIVE_FILE); PUSHU(result); } else { PUSHU(0); // no way to signal EOF } } 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_cr() { PUSHI('\n'); f_emit(); } void f_comma() { *HERE++ = TOP(); DROP(1); } void f_allot() { 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_docolon(); // C code must always call a colon word through f_cexecute() void f_cexecute() { cell oldW = W; cell oldIP = IP; cell retIP; retIP.p = NULL; W = TOP(); DROP(1); if (W.p->f == f_docolon) { RPUSH(retIP); } W.p->f(); W = oldW; IP = oldIP; } void f_colondispatch() { cell codeptr; codeptr = *W.p; if (codeptr.f == f_docolon) { RPUSH(IP); IP.p = W.p + 1; } else { codeptr.f(); } } void f_colonloop() { while (IP.p) { W = *IP.p; IP.p++; f_colondispatch(); } } void f_docolon() { IP.p = W.p + 1; f_colonloop(); } void f_dodeferred() { W = *(W.p + 1); f_colondispatch(); } // this version of f_execute can be run from a colon word void f_execute() { W = TOP(); DROP(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, "%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().u = TOP().p[1].u; } void f_codepointer() { unsigned int flags = TOP().p[1].u; TOP().p = CELL_OFFSET(TOP().p + 2, (flags & ~F_IMMEDIATE) + 1); } void f_lookup() { // name -- (codepointer flags) | (name 0) cell *entry = LATEST; while (entry) { f_dup(); PUSHP(entry); f_wordname(); f_streq(); if (TOP().i) { TOP().p = entry; f_codepointer(); f_swap(); TOP().p = entry; f_wordflags(); return; } DROP(1); entry = entry->p; } 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; f_close(); 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_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_loadfile(char *filename) { PUSHS(filename); f_open(); PUSHS("loadfile"); f_lookup(); DROP(1); f_cexecute(); } 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_init() { 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("latest", f_latest); 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("*", 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("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(",", f_comma); CDEF("b,", f_bcomma); CDEF("open", f_open); CDEF("overwrite", f_overwrite); CDEF("close", f_close); 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("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); PCONST("$DOCREATE", f_docreate); PCONST("$DOVAR", f_dovar); PCONST("$DODEFERRED", f_dodeferred); PUSHS("boot.jor"); f_open(); f_deactivate(); PUSHS("key-file"); f_lookup(); DROP(1); f_swapinput(); f_interpreter(); f_swapinput(); DROP(2); f_loadfile("defs.jor"); } 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)); } }