Implement Jorth interpreter in Jorth so its task can be suspended

boot.jor

@@ -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 ;

defs.jor

@@ -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 + ;

jorth.c

@@ -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) {
+  if (keyword->p) {
-    keyword->f();
+    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;
+  if (result == 1) {
-  PUSHI(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().p = entry;
-      TOP().u = flags;
+      f_codepointer();
-      ST1().p = CELL_OFFSET(entry + 2, (flags & ~F_IMMEDIATE) + 1);
+      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;
+    PUSHCP(entry);
-    cell *name = entry + 2;
+    f_codepointer();
-    cell *cp = CELL_OFFSET(name, length + 1);
+    if (TOP().p == ST1().p) {
-    if (cp == TOP().p) {
+      DROP(1);
-      TOP().p = name;
+      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(); // n isnum
-    f_number(); // name n isnum
     if (TOP().i) {
-      f_rot(); // name n isnum -- n isnum name
+      DROP(1);
-      DROP(2); // n isnum w -- n
       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);
+  if (TOP().fp) {
-  DROP(1);
+    fclose(TOP().fp);
-}
-
-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;
+  DROP(1);
-  *keysrc = oldKeysrc;
 }
 
-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;
+  *key = TOP();
-  keysrc->s = TOP().s;
+  *keysrc = ST1();
-  DROP(1);
+  TOP() = oldKey;
-  f_interpreter();
+  ST1() = oldKeysrc;
-  *key = oldKey;
-  *keysrc = 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];
+  char input[256];
-  CDEF("quit", f_quit);
 
+  CDEF("quit", f_quit);
+  f_runstring("stdout");
   while (!DIE) {
-    int len;
+    f_runstring(gets(input));
-    gets(inputbuf);
-    len = strlen(inputbuf);
-    inputbuf[len] = '\n';
-    inputbuf[len + 1] = 0;
-    PUSHS(inputbuf);
-    f_runstring("REPL send");
-    f_taskloop();
   }
 }

jorth.h

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

temp.jor

@@ -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