First correctly-assembled code snippet (printed as hex to stdout)

asm.jrt

@@ -11,9 +11,8 @@ var opargs-remaining
 array oparg1 3 cells allot
 array oparg2 3 cells allot
 
-: arg1 oparg1 current-oparg ! ;
+: arg1 oparg1 current-oparg ! ; arg1
 : arg2 oparg2 current-oparg ! ;
-arg1
 : swap-args current-oparg @ oparg1 = if arg2 else arg1 then ;
 
 : oparg-type ( -- type ) current-oparg @ ;
@@ -36,14 +35,10 @@ arg1
 ( ie. inc [bx] vs inc byte [bx]?? )
 ( or do we just say incb? )
 
-: bytearg? ( -- f )
+: bytearg? ( -- f ) oparg-breg? swap-args oparg-breg? or swap-args ;
-  current-oparg @
+: byteval? ( v -- f ) 0xff00 & dup 0xff00 = swap 0 = or ;
-  arg1 oparg-reg? oparg-breg? and
-  arg2 oparg-reg? oparg-breg? and or
-  swap current-oparg ! ;
-: byteval? ( v -- f ) 0xff00 & dup 0xff00 = swap 0= or ;
 
-: operror ( err -- ) lastop @ wordname type s": " type type cr ;
+: operror ( err -- ) lastop @ wordname type s" : " type type cr ;
 : oparg-complete!
   opargs-remaining @ dup if
     1 - dup opargs-remaining !
@@ -53,17 +48,18 @@ arg1
 
 : # oparg-imm! oparg-complete! ;
 : @[ 0 oparg-mem! ;
-: @] -1 oparg-base ! oparg-complete ! ;
+: @] -1 oparg-base ! oparg-complete! ;
 
 : unexpected-addr ( addr -- ) drop s" unexpected address" operror ;
 : @+ ( disp -- )
   opargs-remaining @ if  
-    oparg-type @ dup 0= if drop oparg-mem! oparg-complete! 
+    oparg-type @ dup 0 = if drop oparg-mem! oparg-complete! 
     else 3 = if oparg-val ! 
     else unexpected-addr then then
   else unexpected-addr then ;
 
 : l: create target @ , does> @ @+ ;
+: l@ [ ' ' , ] cell + @ ;
 
 : memreg create , does> @ oparg-base ! oparg-complete! ;
 0 memreg bx+si] 1 memreg bx+di] 2 memreg bp+si] 3 memreg bp+di]
@@ -100,27 +96,28 @@ arg1
 0xf9 0op stc   0xfa 0op cli   0xfb 0op sti   0xfc 0op cld
 0xfd 0op std   0xf5 0op cmc
 
-: :op ( count -- ) , $DOCOLON , does> 
+: :op ( count -- ) create , $DOCOLON , ] does> 
   dup @ dup start-op cell + op-encode ! ;
 
 : memarg>case ( -- 0|1|2 )
   oparg-base @ dup -1 = if drop 1 ( D16 ) else
-  6 = oparg-val @ 0= if 2 ( [bp]+0 ) else 0 ( standard ) then then ;
+  6 = oparg-val @ 0 = and if 2 ( [bp]+0 ) else 0 ( standard ) then then ;
 : memarg>dispsize ( -- 0|1|2 )
   memarg>case dup 1 = if drop 2 else 2 = if 1 else
-  oparg-val @ dup 0= if drop 0 else byteval? if 1 else 2 
+  oparg-val @ dup 0 = if drop 0 else byteval? if 1 else 2 
   then then then then ; 
 : memarg>mod+rm ( -- mod rm )
   memarg>case dup 1 = if drop 0 6 else 2 = if 2 6 else
   memarg>dispsize oparg-base @ then then ;
 : regarg>mod+rm ( -- mod rm ) 3 oparg-val @ ;
    
-: modrm>t ( reg mod rm -- ) 0x03 & swap 0x02 & 6 << | swap 0x03 & 3 << | >t ;
+: modrm>t ( reg mod rm -- ) 0x07 & swap 0x03 & 6 << | swap 0x07 & 3 << | >t ;
 
 : invalid-args s" invalid argument types" operror ;
 
 ( convention: words ending in * mean "will return if matched" )
-: disp>t memarg>dispsize dup 1= if drop >t else 2 = if w>t else drop then then ;
+: disp>t oparg-val @ memarg>dispsize 
+  dup 1 = if drop >t else 2 = if w>t else drop then then ;
 : imm?>t oparg-imm? if oparg-val @ dup byteval? if >t else w>t then then ;
 
 : >wreg+op* ( base -- )
@@ -149,8 +146,8 @@ arg1
 1 :op inc
   0x40 >wreg+op*
   0 0xfe >byte-regreg*
-  0 0xff >regreg*
+  0 0xff >regreg* 
-  0 0xff >mem*
+  0 0xff >mem* 
   invalid-args ;
 1 :op incb
   0 0xfe >byte-regreg*

defs.jrt

@@ -9,6 +9,7 @@
 
 : 2swap ( a b c d -- c d a b )
   >r >rot <r >rot ;
+: 2drop drop drop ;
 
 : negate 0 swap - ;
 : abs dup 0 < if negate then ;
@@ -51,13 +52,12 @@
 
 : yield rswap ;
 : done rdrop 0 >r rswap ;
-: ;done ' done , ] ; immediate
+: ;done ' done , [ ' [ , ] ; immediate
 : each [ ' begin , ] ' r@ , [ ' while , ] ; immediate
 : more ' yield , [ ' repeat , ] ' rdrop , ; immediate
 : break rswap rdrop :| yield done |; execute rswap ;
 
 : links begin yield @ dup not until drop ;done
-
 : files findfile begin dup while yield nextfile repeat drop ;done
 : .files files each type s"  " type more ;
 
@@ -74,86 +74,13 @@
 
 : intern create latest wordname , does> @ ;
 
-: preserving ( cp 0 vars... -- )
-  0 >r begin dup while dup @ >r >r repeat drop
-  execute
-  begin r@ while <r <r swap ! repeat rdrop ;
-: preserve ( cp var -- ) 0 swap preserves ;
-
-: decompile-from ( ip -- )
-  begin dup @ ' return != while
-    dup @ dup ` dup if type drop else drop . then bl
-    cell +
-  repeat drop ;
-
-: decompile word lookup if cell + decompile-from else drop then ; userword
-
-: words
-  latest links each
-    dup wordflags F_USERWORD f@ if
-      dup wordname type bl
-    then
-  more ;
-
 : lazy here $DODEFERRED , ' noop , ;
 : >lazy! latest codepointer swap redefine ;
 
 : dbg" [ ' s" , ] :| type bl .s cr |; expile ; immediate
 
-( tasks )
+: .hexnib ( x -- )
-: mailbox 2 cells + ;
+  dup 0 >= over 9 <= and if [ key 0 lit ] 
-: task-ip task-user-size cells + ;
+  else 10 - [ key A lit ] then + emit ;
-: task-sp task-user-size 1 + cells + ;
+: .hex dup 0xf0 & 4 >> .hexnib 0x0f & .hexnib bl ;
-: task-rsp task-user-size 2 + cells + ;
-: task-stack task-user-size 3 + cells + ;
-: task-rstack task-stack stacksize cells + ;
-
-: .wordin ( ptr -- )
-  latest links each
-    2dup > if wordname type drop 0 break then
-  more dup if . else drop then ; userword
-
-: tasks.s
-  tasks links each
-    dup dup . .wordin s" : " type
-    dup task-sp @ over task-stack ( task stackLim stack )
-    2dup . . s" : " type
-    begin 2dup > while dup @ . cell + repeat
-    cr drop drop more ; userword
-
-: task.bt ( task -- )
-  dup task-rsp @ swap task-rstack ( rstackLim rstack )
-  begin 2dup > while dup @ dup . .wordin cr cell + repeat
-  drop drop ; userword
-
-: doactivate ( task ip -- )
-  over task-ip !
-  dup task-stack over task-sp !
-  dup task-rstack over task-rsp !
-  drop
-;
-
-: activate
-  here 4 cells + lit
-  ' doactivate ,
-  ' return ,
-; immediate
-
-: >task ( val task -- )
-  task-sp >r r@ @ ! r@ @ cell + r> ! ;
-
-: try-send ( val task -- b )
-  mailbox dup @ if drop drop 0 else ! 1 then ;
-
-: wait-send ( val task -- )
-  mailbox
-  begin dup @ while suspend repeat ( wait for empty mailbox )
-  ! ;
-
-: send ( val task -- ) try-send drop ;
-
-: receive ( -- val )
-  running mailbox
-  begin dup @ not while suspend repeat ( wait for mail )
-  dup @ 0 <rot ! ;
 

main.c

@@ -6,6 +6,6 @@ int main(int argc, char *argv[]) {
   f_interpreter();
   fclose(IN_FILE);
   IN_FILE = stdin;
-  f_execcp( f_lookupcp("interpreter"));
+  f_execcp(f_lookupcp("interpreter"));
   return 0;
 }

tinyjort.jrt

@@ -0,0 +1,12 @@
+s" defs.jrt" loadfile
+s" asm.jrt" loadfile
+
+here 
+
+push ax 
+pop bx
+inc @[ bx]
+
+here
+:noname for i b@ .hex next ; execute
+