dialer/asm.jrt

var target
0x100 target !
: >t b, 1 target +! ; ( todo: write to target segment )
: w>t , 2 target +! ;

var op-encode
var lastop

var op-memwidth 
: byteptr 1 op-memwidth ! ; : byteptr? op-memwidth @ 1 = ;
: farptr 4 op-memwidth ! ;  : farptr? op-memwidth @ 4 = ;

var current-oparg
var opargs-remaining
array oparg1 3 cells allot
array oparg2 3 cells allot

: arg1 oparg1 current-oparg ! ; arg1
: arg2 oparg2 current-oparg ! ;
: swap-args current-oparg @ oparg1 = if arg2 else arg1 then ;

: oparg-type ( -- type ) current-oparg @ ;
: oparg-val ( -- v ) current-oparg @ cell + ;
: oparg-base ( -- v ) current-oparg @ 2 cells + ;
: set-oparg! ( val type -- ) oparg-type ! oparg-val ! 0 oparg-base ! ;

: oparg-imm! ( val -- ) 1 set-oparg! ;
: oparg-imm? ( -- f ) oparg-type @ 1 = ;
: oparg-reg! ( reg -- ) 2 set-oparg! ;
: oparg-reg? ( -- f ) oparg-type @ 2 = ;
: oparg-regflag? ( flag -- f ) oparg-val @ 0xf0 & = oparg-reg? and ;
: oparg-breg? ( -- f ) 0x10 oparg-regflag? ;
: oparg-wreg? ( -- f ) 0x00 oparg-regflag? ;
: oparg-segreg? ( -- f ) 0x20 oparg-regflag? ;
: oparg-mem! ( disp -- ) 3 set-oparg! ;
: oparg-mem? ( -- f ) oparg-type @ 3 = ;

: byteop? ( -- f ) 
  oparg-breg? swap-args oparg-breg? or swap-args byteptr? or ;
: byteval? ( v -- f ) 0xff00 & dup 0xff00 = swap 0 = or ;
: oparg-bwreg? ( -- f ) byteop? if oparg-breg? else oparg-wreg? then ;

: operror ( err -- ) lastop @ wordname type s" : " type type cr ;
: oparg-complete!
  opargs-remaining @ dup if
    1 - dup opargs-remaining !
    if   arg2
    else arg1 op-encode @ execute 0 op-encode ! then
  else s" too many arguments" operror then ;

: # oparg-imm! oparg-complete! ;
: @[ 0 oparg-mem! ;
: @] -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! 
    else 3 = if oparg-val ! 
    else unexpected-addr then then
  else unexpected-addr then ;
: @far ( offset segment -- ) 4 set-oparg! oparg-base ! ;
: oparg-faraddr? oparg-type @ 4 = ;

: 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]
4 memreg si]    5 memreg di]    6 memreg bp]    7 memreg bx]

: reg create , does> @ oparg-reg! oparg-complete! ;
( data registers: take the bottom four bits and you have the
  REG and R/M encoding for the modr/m byte )
0x00 reg ax 0x01 reg cx 0x02 reg dx 0x03 reg bx 
0x04 reg sp 0x05 reg bp 0x06 reg si 0x07 reg di
( 8-bit data registers, same scheme )
0x10 reg al 0x11 reg cl 0x12 reg dl 0x13 reg bl
0x14 reg ah 0x15 reg ch 0x16 reg dh 0x17 reg bh
( segment registers: take the bottom four bits, left shift 1,
  and you have the PUSH instruction byte. bitwise or 0x01 and
  you have POP.)
0x20 reg es 0x21 reg cs 0x22 reg ss 0x23 reg ds

: start-op ( does-ptr argcount -- )
  0 op-memwidth ! ( start unknown )
  opargs-remaining @ if s" not enough arguments" operror then
  opargs-remaining ! cell - lastop ! arg1 ;
: prefix create , does> @ >t ;
: 0op create , does> dup 0 start-op @ >t ;

0x26 prefix es:   0x36 prefix ss:   0x2e prefix cs:  0x3e prefix ds:
0xf0 prefix lock  0xf2 prefix repnz 0xf3 prefix repz 

0x90 0op nop   0xa4 0op movsb 0xa5 0op movsw 0xa6 0op cmpsb 
0xa7 0op cmpsw 0xc3 0op ret   0xd7 0op xlat  0xf4 0op hlt    
0x98 0op cbw   0x99 0op cwd   0x9c 0op pushf 0x9d 0op popf
0x9e 0op sahf  0x9f 0op lahf  0xaa 0op stosb 0xab 0op stosw
0xac 0op lodsb 0xad 0op lodsw 0xae 0op scasb 0xaf 0op scasw
0xcb 0op retf  0xce 0op into  0xcf 0op iret  0xf8 0op clc
0xf9 0op stc   0xfa 0op cli   0xfb 0op sti   0xfc 0op cld
0xfd 0op std   0xf5 0op cmc

: :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 = 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 
  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 -- ) 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 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 ;

: >wreg+op* ( base -- )
  oparg-wreg? if oparg-val @ | >t rdrop else drop then ;
: >segreg+op* ( base -- ) 
  oparg-segreg? if oparg-val @ 0x0f & 3 << + >t rdrop else drop then ;
: >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 ;
: >mem* oparg-mem? byteop? not and if >mem rdrop else 2drop then ;
: >bmem* oparg-mem? byteop? and if >mem rdrop else 2drop then ;

: >regreg ( reg op -- ) >t regarg>mod+rm modrm>t ;
: >byte-regreg* ( reg op -- ) oparg-breg? if >regreg rdrop else 2drop then ;
: >regreg* ( reg op -- ) oparg-wreg? if >regreg rdrop else 2drop then ;

1 :op ret- oparg-imm? if oparg-val @ w>t else invalid-args then ;
1 :op push 
  0x50 >wreg+op*
  0x06 >segreg+op*
  6 0xff >mem*
  invalid-args ;
1 :op pop
  0x58 >wreg+op*
  0x07 >segreg+op*
  0 0x8f >mem*
  invalid-args ;
1 :op inc
  0x40 >wreg+op*
  0 0xfe >byte-regreg*
  0 0xff >regreg* 
  0 0xff >mem* 
  invalid-args ;
1 :op incb
  0 0xfe >byte-regreg*
  0 0xfe >mem*
  invalid-args ;
1 :op dec
  0x48 >wreg+op*
  1 0xfe >byte-regreg*
  1 0xff >regreg*
  0 0xff >mem*
  1 0xfe >bmem*
  invalid-args ;
1 :op int
  oparg-imm? if oparg-val @ dup 3 = if drop 0xcc >t else 0xcd >t >t then
  else invalid-args then ;

: diffaddr ( addr opsize -- diff ) target @ + - ;
: oparg-nearaddr? ( -- f ) oparg-type @ 3 = oparg-base @ -1 = and ;
: >short-jmp* ( op -- ) oparg-nearaddr? if
    oparg-val @ 2 diffaddr dup byteval? if swap >t >t rdrop return else drop
  then then drop ;
: >near-reljmp* ( op -- ) oparg-nearaddr? if
    oparg-val @ 3 diffaddr swap >t w>t rdrop else drop then ;
: >far-jmp* ( op -- ) oparg-faraddr? 
  if >t oparg-base @ w>t oparg-val @ w>t rdrop else drop then ;

1 :op jo  0x70 >short-jmp* invalid-args ;
1 :op jno 0x71 >short-jmp* invalid-args ;
1 :op jb  0x72 >short-jmp* invalid-args ;
1 :op jnb 0x73 >short-jmp* invalid-args ;
1 :op jz  0x74 >short-jmp* invalid-args ;
1 :op jnz 0x75 >short-jmp* invalid-args ;
1 :op jbe 0x76 >short-jmp* invalid-args ;
1 :op ja  0x77 >short-jmp* invalid-args ;
1 :op js  0x78 >short-jmp* invalid-args ;
1 :op jns 0x79 >short-jmp* invalid-args ;
1 :op jpe 0x7a >short-jmp* invalid-args ;
1 :op jpo 0x7b >short-jmp* invalid-args ;
1 :op jl  0x7c >short-jmp* invalid-args ;
1 :op jge 0x7d >short-jmp* invalid-args ;
1 :op jle 0x7e >short-jmp* invalid-args ;
1 :op jg  0x7f >short-jmp* invalid-args ;
1 :op loopnz 0xe0 >short-jmp* invalid-args ;
1 :op loopz  0xe1 >short-jmp* invalid-args ;
1 :op loop   0xe2 >short-jmp* invalid-args ;
1 :op jcxz   0xe3 >short-jmp* invalid-args ;
1 :op jmp
  0xeb >short-jmp*
  0xe9 >near-reljmp*
  0xea >far-jmp*
  invalid-args ;
1 :op call
  0xe8 >near-reljmp*
  invalid-args ;

( four opcodes laid out next to each other:
  byte mem, reg | word mem, reg | byte reg, mem | word reg, mem )
: memreg? ( -- f ) oparg-mem? swap-args oparg-bwreg? swap-args and ;
: >bmr-wmr? ( base -- f )
  memreg? if byteop? not if 1 + then >memreg 1 else drop 0 then ;
: >bmr-wmr-brm-wrm* ( base -- )
  dup >bmr-wmr? if drop rdrop return then
  2 + swap-args >bmr-wmr? swap-args if rdrop 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 + 
  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
  0x00 = if 1 + >t swap-args imm?>t swap-args rdrop return else drop then ;

2 :op xchg
  arg2 oparg-reg? oparg-val @ 0x00 = arg1 oparg-wreg? and 
  if 0x90 >wreg+op* then
  invalid-args ;
2 :op mov
  0x88 >bmr-wmr-brm-wrm*
  arg2 oparg-imm? arg1 if
    oparg-wreg? if oparg-val @ 0xb8 | >t arg2 oparg-val @ w>t return then
    oparg-breg? if oparg-val @ 0x0f & 0xb0 | >t arg2 oparg-val @ >t return then
    0 0xc6 >bmem*
    0 0xc7 >mem*
  then
  invalid-args ;
2 :op add 0x00 >6group-math* invalid-args ;
2 :op adc 0x10 >6group-math* invalid-args ;
2 :op AND 0x20 >6group-math* invalid-args ;
2 :op xor 0x30 >6group-math* invalid-args ;
2 :op OR  0x08 >6group-math* invalid-args ;
2 :op sbb 0x18 >6group-math* invalid-args ;
2 :op sub 0x28 >6group-math* invalid-args ;
2 :op cmp 0x38 >6group-math* invalid-args ;