SpindleyQ/pete286
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

Implement Jorth interpreter in Jorth so its task can be suspended

Browse source
This commit is contained in:
Jeremy Penner 2019-02-09 21:52:12 -05:00
parent 6552c1498b
commit c8331edece
7 changed files with 150 additions and 84 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

42
boot.jor Executable file
View file

@ -0,0 +1,42 @@
2 const cell
: cells cell * ;
key ) const ')'
10 const '\n'
key const sp
128 const F_IMMEDIATE
: cr '\n' emit ;
: bl sp emit ;
: if ' BZ_ , here 0 , ; immediate
: else ' GOTO_ , 0 , here swap ! here cell - ; immediate
: then here swap ! ; immediate
: begin here ; immediate
: while ' BZ_ , here 0 , ; immediate
: repeat ' GOTO_ , swap , here swap ! ; immediate
: again ' GOTO_ , , ; immediate
: until ' BZ_ , , ; immediate
: ( begin key ')' = until ; immediate
: lit ' LIT_ , , ;
: interpretword F_IMMEDIATE & state not or if execute else , then ;
: interpretnumber state if lit then ;
: interpretunknown type s" ?" type cr ;
: compileword lookup dup
if interpretword
else drop number
if interpretnumber
else interpretunknown
then
then ;
: interpreter
begin word dup b@ while compileword repeat
s" ok" type cr drop ;
: load-input swap-input r> r> interpreter r< r< swap-input ;
: loadstring ' key-string load-input drop drop ;
: loadfile ' key-file load-input drop close ;

25
defs.jor
View file

@ -2,29 +2,6 @@
s" jorth.log" open const LOGFILE
: log-emit LOGFILE fputc ;
2 const cell
: cells cell * ;
key ) const ')'
10 const '\n'
key const sp
: cr '\n' emit ;
: bl sp emit ;
: if ' BZ_ , here 0 , ; immediate
: else ' GOTO_ , 0 , here swap ! here cell - ; immediate
: then here swap ! ; immediate
: begin here ; immediate
: while ' BZ_ , here 0 , ; immediate
: repeat ' GOTO_ , swap , here swap ! ; immediate
: again ' GOTO_ , , ; immediate
: until ' BZ_ , , ; immediate
: ( begin key ')' = until ; immediate
' cells @ const docolon ( get the colon execution token )
: :noname here docolon , ] ;
@ -39,8 +16,6 @@ key const sp
1 + ( cp i+1 )
repeat drop drop then drop ;
: lit ' LIT_ , , ;
( tasks )
: mailbox 2 cells + ;
: task-ip task-user-size cells + ;

BIN
game.exe
View file

Binary file not shown.

BIN
game.prj
View file

Binary file not shown.

151
jorth.c
View file

@ -88,6 +88,11 @@ 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, ^)
void f_eq0() {
TOP().i = (TOP().i == 0);
@ -146,6 +151,15 @@ void f_rot() { // a b c -- b c a
ST2() = b;
}
void f_rput() {
RPUSH(TOP());
DROP(1);
}
void f_rtake() {
PUSHC(*RPOP());
}
void f_cexecute();
void f_key_string() {
@ -180,8 +194,9 @@ void f_key_file() {
void f_key() {
cell *keyword = RUNNING + TASK_USER_KEY;
cell *echoword = RUNNING + TASK_USER_ECHO;
if (keyword->f) {
keyword->f();
if (keyword->p) {
PUSHCP(keyword->p);
f_cexecute();
} else {
PUSHI(0);
}
@ -368,11 +383,15 @@ void f_lit_() {
IP.p++;
}
void f_number() { // str -- num isnum
void f_number() { // str -- (num 1 | str 0)
int num = 0, result;
result = sscanf(TOP().s, "%d", &num);
TOP().i = num;
PUSHI(result == 1);
if (result == 1) {
TOP().i = num;
PUSHI(result == 1);
} else {
PUSHI(0);
}
}
void f_streq() {
@ -381,16 +400,30 @@ void f_streq() {
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 + 2);
PUSHP(entry);
f_wordname();
f_streq();
if (TOP().i) {
unsigned int flags = entry[1].u;
TOP().u = flags;
ST1().p = CELL_OFFSET(entry + 2, (flags & ~F_IMMEDIATE) + 1);
TOP().p = entry;
f_codepointer();
f_swap();
TOP().p = entry;
f_wordflags();
return;
}
DROP(1);
@ -402,13 +435,15 @@ void f_lookup() { // name -- (codepointer flags) | (name 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;
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;
@ -477,14 +512,12 @@ void f_compileword() { // name --
f_lookup();
if (!TOP().u) { // name 0
DROP(1); // name
f_dup(); // name name
f_number(); // name n isnum
f_number(); // n isnum
if (TOP().i) {
f_rot(); // name n isnum -- n isnum name
DROP(2); // n isnum w -- n
DROP(1);
f_interpretnumber();
} else {
DROP(2); // name
DROP(1);
f_interpretunknown();
}
} else { // codepointer flags
@ -512,37 +545,21 @@ void f_open() {
}
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);
if (TOP().fp) {
fclose(TOP().fp);
}
*key = oldKey;
*keysrc = oldKeysrc;
DROP(1);
}
void f_loadstring() {
void f_swapinput() {
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;
*key = TOP();
*keysrc = ST1();
TOP() = oldKey;
ST1() = oldKeysrc;
}
void f_taskemit() {
@ -650,12 +667,18 @@ void f_quote() {
void f_loadfile(char *filename) {
PUSHS(filename);
f_open();
f__loadfile();
PUSHS("loadfile");
f_lookup();
DROP(1);
f_cexecute();
}
void f_runstring(char *s) {
PUSHS(s);
f_loadstring();
PUSHS("loadstring");
f_lookup();
DROP(1);
f_cexecute();
}
void f_quiet() {
@ -716,11 +739,13 @@ void f_rstacksize() {
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("key-string", f_key_string);
CDEF("key-file", f_key_file);
CDEF("emit", f_emit);
CDEF("word", f_word);
CDEF("immediate", f_immediate);
@ -753,6 +778,11 @@ void f_init() {
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_get);
CDEF("!", f_set);
CDEF("b@", f_bget);
@ -762,9 +792,12 @@ void f_init() {
CDEF("drop", f_drop);
CDEF("swap", f_swap);
CDEF("rot", f_rot);
CDEF("r>", f_rput);
CDEF("r<", f_rtake);
CDEF("emit", f_emit);
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);
@ -784,8 +817,6 @@ void f_init() {
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);
@ -796,6 +827,16 @@ void f_init() {
CDEF("rstacksize", f_rstacksize);
CDEF("task-user-size", f_taskusersize);
PUSHS("boot.jor");
f_open();
PUSHS("key-file");
f_lookup();
DROP(1);
f_swapinput();
f_interpreter();
f_swapinput();
DROP(2);
f_loadfile("defs.jor");
}
@ -805,17 +846,11 @@ void f_quit() {
}
void f_repl() {
char inputbuf[256];
CDEF("quit", f_quit);
char input[256];
CDEF("quit", f_quit);
f_runstring("stdout");
while (!DIE) {
int len;
gets(inputbuf);
len = strlen(inputbuf);
inputbuf[len] = '\n';
inputbuf[len + 1] = 0;
PUSHS(inputbuf);
f_runstring("REPL send");
f_taskloop();
f_runstring(gets(input));
}
}

1
jorth.h
View file

@ -6,6 +6,7 @@
void f_init();
void f_cdef();
#define CDEF(name, def) PUSHP(def); PUSHS(name); f_cdef()
void f_immediate();

13
temp.jor Executable file
View file

@ -0,0 +1,13 @@
: interpretword F_IMMEDIATE & state not or if execute else , then ;
: compileword lookup dup
if interpretword
else drop dup number
if swap drop interpretnumber
else drop interpretunknown
then
then ;
: interpreter
begin word dup b@ while compileword repeat
s" ok\n" type drop ;
: loadstring
: loadfile