implement anonymous forward labels

asm.jrt

@@ -31,6 +31,7 @@ array oparg2 3 cells allot
 : oparg-base ( -- v ) current-oparg @ 2 cells + ;
 : set-oparg! ( val type -- ) oparg-type ! oparg-val ! 0 oparg-base ! ;
 
+: oparg-unset? ( -- f ) oparg-type @ 0 = ;
 : oparg-imm! ( val -- ) 1 set-oparg! ;
 : oparg-imm? ( -- f ) oparg-type @ 1 = ;
 : oparg-reg! ( reg -- ) 2 set-oparg! ;
@@ -40,7 +41,8 @@ array oparg2 3 cells allot
 : oparg-wreg? ( -- f ) 0x00 oparg-regflag? ;
 : oparg-segreg? ( -- f ) 0x20 oparg-regflag? ;
 : oparg-mem! ( disp -- ) 3 set-oparg! ;
-: oparg-mem? ( -- f ) oparg-type @ 3 = ;
+: oparg-mem? ( -- f ) oparg-type @ 0x0f & 3 = ;
+: oparg-mempatch? ( -- f ) oparg-type @ 0x13 = ;
 
 : byteop? ( -- f ) 
   oparg-breg? swap-args oparg-breg? or swap-args byteptr? or ;
@@ -48,11 +50,16 @@ array oparg2 3 cells allot
 : oparg-bwreg? ( -- f ) byteop? if oparg-breg? else oparg-wreg? then ;
 
 : operror ( err -- ) lastop @ type s"  near " type lastlabel @ type s" : " type type cr ;
+
+: encode-op ( -- ) op-encode @ execute 0 op-encode ! ;
+: check-encoded ( -- )
+  target @ >r encode-op <r target @ = 
+  if s" invalid argument types" operror then ; 
 : oparg-complete!
   opargs-remaining @ dup if
     1 - dup opargs-remaining !
     if   arg2
-    else arg1 op-encode @ execute 0 op-encode ! then
+    else arg1 check-encoded then
   else s" too many arguments" operror then ;
 
 : # oparg-imm! oparg-complete! ;
@@ -62,13 +69,26 @@ array oparg2 3 cells allot
 : unexpected-addr ( addr -- ) drop s" unexpected address" operror ;
 : @+ ( disp -- )
   opargs-remaining @ if
-    oparg-type @ dup 0 = if drop oparg-mem! @] 
+    oparg-unset? if oparg-mem! @] return then 
-    else 3 = if oparg-val ! 
+    oparg-mem? if oparg-val ! return then
-    else unexpected-addr then then
+  then drop unexpected-addr ;
-  else unexpected-addr then ;
+
 : @FAR ( offset segment -- ) 4 set-oparg! oparg-base ! ;
 : oparg-faraddr? oparg-type @ 4 = ;
 
+array patchtable 10 2 cells * allot
+: find-patch ( patchid -- patch ) 2 cells * patchtable + ;
+: patchpoint ( type -- ) oparg-mempatch? if
+    oparg-val @ find-patch swap over ! cell + target @ swap ! 
+  else drop then ;
+: patch-a16 ( tptr targ -- ) swap !t ;
+: patch-r16 ( tptr targ -- ) over 2 + - swap !t ;
+: patch-r8  ( tptr targ -- ) over 1 + - swap b!t ;
+: apply-patch ( tptr type -- ) target @ swap execute ;
+
+: @> ( patchid -- ) 0x13 set-oparg! @] ;
+: <: ( patchid -- ) find-patch dup @ swap cell + @ swap apply-patch ;
+
 : L: here create wordname lastlabel ! target @ , does> @ @+ ;
 : L@ [ ' ' , ] 2 cells + @ ;
 
@@ -122,98 +142,102 @@ array oparg2 3 cells allot
 : regarg>mod+rm ( -- mod rm ) 3 oparg-val @ ;
    
 : modrm>t ( reg mod rm -- ) 0x07 & swap 0x03 & 6 << | swap 0x07 & 3 << | >t ;
-
+: pre-disp-write memarg>case 2 = if ' patch-a16 patchpoint then ;
-: invalid-args s" invalid argument types" operror ;
 
 ( convention: words ending in * mean "will return if matched" )
-: disp>t oparg-val @ memarg>dispsize 
+: disp>t pre-disp-write 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 @ byteop? if >t else w>t then then ;
 
+( 2ret: return immediately from this word and calling word.
+  equivalent to rdrop return. )
+: 2ret rdrop rdrop ;
+
 : >wreg+op* ( base -- )
-  oparg-wreg? if oparg-val @ | >t rdrop else drop then ;
+  oparg-wreg? if oparg-val @ | >t 2ret then drop ;
 : >segreg+op* ( base -- ) 
-  oparg-segreg? if oparg-val @ 0x0f & 3 << + >t rdrop else drop then ;
+  oparg-segreg? if oparg-val @ 0x0f & 3 << + >t 2ret then drop ;
 : >mem ( reg op -- ) >t memarg>mod+rm modrm>t disp>t swap-args imm?>t ;
 : >memreg ( op -- ) swap-args oparg-val @ swap-args swap >mem ;
-: >extmem* oparg-mem? byteop? not and if >mem rdrop else 2drop then ;
+: >extmem* oparg-mem? byteop? not and if >mem 2ret then 2drop ;
-: >extbmem* oparg-mem? byteop? and if >mem rdrop else 2drop then ;
+: >extbmem* oparg-mem? byteop? and if >mem 2ret then 2drop ;
 
 : >extreg ( reg op -- ) >t regarg>mod+rm modrm>t ;
-: >extbreg* ( ext op -- ) oparg-breg? if >extreg rdrop else 2drop then ;
+: >extbreg* ( ext op -- ) oparg-breg? if >extreg 2ret then 2drop ;
-: >extreg* ( ext op -- ) oparg-wreg? if >extreg rdrop else 2drop then ;
+: >extreg* ( ext op -- ) oparg-wreg? if >extreg 2ret then 2drop ;
 
-1 :op RET- oparg-imm? if oparg-val @ w>t else invalid-args then ;
+: >extwreg|mem* ( ext op -- ) byteop? not if 
+    oparg-wreg? if >extreg 2ret then
+    oparg-mem? if >mem 2ret then
+  then 2drop ;
+
+1 :op RET- oparg-imm? if oparg-val @ w>t then ;
 1 :op PUSH 
   0x50 >wreg+op*
   0x06 >segreg+op*
-  6 0xff >extmem*
+  6 0xff >extmem* ;
-  invalid-args ;
 1 :op POP
   0x58 >wreg+op*
   0x07 >segreg+op*
-  0 0x8f >extmem*
+  0 0x8f >extmem* ;
-  invalid-args ;
 1 :op INC
   0x40 >wreg+op*
   0 0xfe >extbreg*
   0 0xff >extreg* 
   0 0xff >extmem* 
-  1 0xff >extmem*
+  1 0xff >extmem* ;
-  invalid-args ;
 1 :op DEC
   0x48 >wreg+op*
   1 0xfe >extbreg*
   1 0xff >extreg*
   1 0xff >extmem*
-  1 0xfe >extbmem*
+  1 0xfe >extbmem* ;
-  invalid-args ;
 1 :op INT
-  oparg-imm? if oparg-val @ dup 3 = if drop 0xcc >t else 0xcd >t >t then
+  oparg-imm? if 
-  else invalid-args then ;
+    oparg-val @ dup 3 = if drop 0xcc >t else 0xcd >t >t then 
+  then ;
 
-: diffaddr ( addr opsize -- diff ) target @ + - ;
+: diffaddr ( opsize -- diff ) oparg-val @ swap target @ + - ;
-: oparg-nearaddr? ( -- f ) oparg-type @ 3 = oparg-base @ -1 = and ;
+: oparg-nearaddr? ( -- f ) oparg-mem? oparg-base @ -1 = and ;
 : >short-jmp* ( op -- ) oparg-nearaddr? if
-    oparg-val @ 2 diffaddr dup byteval? if swap >t >t rdrop return else drop
+    2 diffaddr dup byteval? oparg-mempatch? or
-  then then drop ;
+    if swap >t ' patch-r8 patchpoint cr >t 2ret then drop
+  then drop ;
 : >near-reljmp* ( op -- ) oparg-nearaddr? if
-    oparg-val @ 3 diffaddr swap >t w>t rdrop else drop then ;
+    3 diffaddr swap >t ' patch-r16 patchpoint w>t 2ret then drop ;
 : >far-jmp* ( op -- ) oparg-faraddr?
-  if >t oparg-base @ w>t oparg-val @ w>t rdrop else drop then ;
+  if >t oparg-base @ w>t oparg-val @ w>t 2ret then drop ;
 
-1 :op JO  0x70 >short-jmp* invalid-args ;
+1 :op JO  0x70 >short-jmp* ;
-1 :op JNO 0x71 >short-jmp* invalid-args ;
+1 :op JNO 0x71 >short-jmp* ;
-1 :op JB  0x72 >short-jmp* invalid-args ;
+1 :op JB  0x72 >short-jmp* ;
-1 :op JNB 0x73 >short-jmp* invalid-args ;
+1 :op JNB 0x73 >short-jmp* ;
-1 :op JZ  0x74 >short-jmp* invalid-args ;
+1 :op JZ  0x74 >short-jmp* ;
-1 :op JNZ 0x75 >short-jmp* invalid-args ;
+1 :op JNZ 0x75 >short-jmp* ;
-1 :op JBE 0x76 >short-jmp* invalid-args ;
+1 :op JBE 0x76 >short-jmp* ;
-1 :op JA  0x77 >short-jmp* invalid-args ;
+1 :op JA  0x77 >short-jmp* ;
-1 :op JS  0x78 >short-jmp* invalid-args ;
+1 :op JS  0x78 >short-jmp* ;
-1 :op JNS 0x79 >short-jmp* invalid-args ;
+1 :op JNS 0x79 >short-jmp* ;
-1 :op JPE 0x7a >short-jmp* invalid-args ;
+1 :op JPE 0x7a >short-jmp* ;
-1 :op JPO 0x7b >short-jmp* invalid-args ;
+1 :op JPO 0x7b >short-jmp* ;
-1 :op JL  0x7c >short-jmp* invalid-args ;
+1 :op JL  0x7c >short-jmp* ;
-1 :op JGE 0x7d >short-jmp* invalid-args ;
+1 :op JGE 0x7d >short-jmp* ;
-1 :op JLE 0x7e >short-jmp* invalid-args ;
+1 :op JLE 0x7e >short-jmp* ;
-1 :op JG  0x7f >short-jmp* invalid-args ;
+1 :op JG  0x7f >short-jmp* ;
-1 :op LOOPNZ 0xe0 >short-jmp* invalid-args ;
+1 :op LOOPNZ 0xe0 >short-jmp* ;
-1 :op LOOPZ  0xe1 >short-jmp* invalid-args ;
+1 :op LOOPZ  0xe1 >short-jmp* ;
-1 :op LOOP   0xe2 >short-jmp* invalid-args ;
+1 :op LOOP   0xe2 >short-jmp* ;
-1 :op JCXZ   0xe3 >short-jmp* invalid-args ;
+1 :op JCXZ   0xe3 >short-jmp* ;
 1 :op JMP
   0xeb >short-jmp*
   0xe9 >near-reljmp*
   0xea >far-jmp*
   farptr? if 0x05 0xff >extmem* then
-  0x04 0xff >extmem* ( todo: JMP to reg allowed )
+  0x04 0xff >extmem* ( todo: JMP to reg allowed ) ;
-  invalid-args ;
 1 :op CALL
   0xe8 >near-reljmp*
   farptr? if 0x03 0xff >extmem* then
-  0x02 0xff >extmem* ( todo: CALL reg allowed )
+  0x02 0xff >extmem* ( todo: CALL reg allowed ) ;
-  invalid-args ;
 
 ( four opcodes laid out next to each other:
   byte mem, reg | word mem, reg | byte reg, mem | word reg, mem )
@@ -228,22 +252,22 @@ array oparg2 3 cells allot
   regreg? if 1 + else bregbreg? not if drop 0 return then then >regreg 1 ;
 
 : >bmr-wmr-brm-wrm* ( base -- )
-  dup >bmr-wmr? if drop rdrop return then
+  dup >bmr-wmr? if drop 2ret then
-  dup >brr-wrr? if drop rdrop return then
+  dup >brr-wrr? if drop 2ret then
-  2 + swap-args >bmr-wmr? swap-args if rdrop then ;
+  2 + swap-args >bmr-wmr? swap-args if 2ret then ;
 : >bmr-wmr-brm-wrm? ( base -- f )
   1 swap >bmr-wmr-brm-wrm* drop 0 ;
 : >6group-math* ( base -- )
-  dup >bmr-wmr-brm-wrm? if drop rdrop then 4 + 
+  dup >bmr-wmr-brm-wrm? if drop 2ret then 4 + 
   swap-args oparg-imm? swap-args not if drop return then
   oparg-reg? not if drop return then
-  oparg-val @ dup 0x10 = if drop >t swap-args imm?>t swap-args rdrop return then
+  oparg-val @ dup 
-  0x00 = if 1 + >t swap-args imm?>t swap-args rdrop return else drop then ;
+    0x10 = if drop >t swap-args imm?>t swap-args 2ret then
+    0x00 = if 1 + >t swap-args imm?>t swap-args 2ret then drop ;
 
 2 :op XCHG
   arg2 oparg-reg? oparg-val @ 0x00 = arg1 oparg-wreg? and 
-  if 0x90 >wreg+op* then
+  if 0x90 >wreg+op* then ;
-  invalid-args ;
 2 :op MOV
   0x88 >bmr-wmr-brm-wrm*
   arg2 oparg-imm? arg1 if
@@ -251,14 +275,13 @@ array oparg2 3 cells allot
     oparg-breg? if oparg-val @ 0x0f & 0xb0 | >t arg2 oparg-val @ >t return then
     0 0xc6 >extbmem*
     0 0xc7 >extmem*
-  then
+  then ;
-  invalid-args ;
+2 :op ADD 0x00 >6group-math* ;
-2 :op ADD 0x00 >6group-math* invalid-args ;
+2 :op ADC 0x10 >6group-math* ;
-2 :op ADC 0x10 >6group-math* invalid-args ;
+2 :op AND 0x20 >6group-math* ;
-2 :op AND 0x20 >6group-math* invalid-args ;
+2 :op XOR 0x30 >6group-math* ;
-2 :op XOR 0x30 >6group-math* invalid-args ;
+2 :op OR  0x08 >6group-math* ;
-2 :op OR  0x08 >6group-math* invalid-args ;
+2 :op SBB 0x18 >6group-math* ;
-2 :op SBB 0x18 >6group-math* invalid-args ;
+2 :op SUB 0x28 >6group-math* ;
-2 :op SUB 0x28 >6group-math* invalid-args ;
+2 :op CMP 0x38 >6group-math* ;
-2 :op CMP 0x38 >6group-math* invalid-args ;
 

tinyjort.jrt

@@ -36,7 +36,7 @@ L: LATEST 0 w>t
 
 : savelabel ( word -- )
   here swap begin dup b@ dup while b, 1 + repeat b, drop lastlabel ! ;
-: DICTLIST ( word -- tptr ) b@ 0x0f & dup . cells [ L@ DICTIONARY lit ] + ;
+: DICTLIST ( word -- tptr ) b@ 0x0f & cells [ L@ DICTIONARY lit ] + ;
 : strlen ( word -- len ) 0 swap begin dup b@ while swap 1 + swap 1 + repeat drop ;
 : str>t ( word -- ) begin dup b@ dup while >t 1 + repeat >t drop ;
 : link>t ( tptr-head -- ) dup @t swap target @ swap !t w>t ;
@@ -95,11 +95,18 @@ L: $$COLON
   PUSH AX
   NEXT
 
-:ASM GOTO_
+:ASM BZ_
+  POP CX
+  JCXZ 0 @>
+  LODSW
+  NEXT
+L: GOTO_IMPL 0 <:
   LODSW
   MOV SI AX
   NEXT
 
+DEF GOTO_ L@ GOTO_IMPL w>t
+
 ( 0x1000 target ! )
 
 .s