2023-09-01 23:10:52 +00:00
|
|
|
var target
|
|
|
|
0x100 target !
|
|
|
|
: >t b, 1 target +! ; ( todo: write to target segment )
|
|
|
|
: w>t , 2 target +! ;
|
|
|
|
|
|
|
|
var op-encode
|
|
|
|
var lastop
|
|
|
|
|
2023-09-01 23:10:52 +00:00
|
|
|
var is-byteptr : byteptr 1 is-byteptr ! ;
|
|
|
|
|
2023-09-01 23:10:52 +00:00
|
|
|
var current-oparg
|
|
|
|
var opargs-remaining
|
|
|
|
array oparg1 3 cells allot
|
|
|
|
array oparg2 3 cells allot
|
|
|
|
|
2023-09-01 23:10:52 +00:00
|
|
|
: arg1 oparg1 current-oparg ! ; arg1
|
2023-09-01 23:10:52 +00:00
|
|
|
: 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 = ;
|
|
|
|
|
|
|
|
( TODO: support explicit byte ptr word )
|
|
|
|
( ie. inc [bx] vs inc byte [bx]?? )
|
|
|
|
( or do we just say incb? )
|
|
|
|
|
2023-09-01 23:10:52 +00:00
|
|
|
: byteop? ( -- f )
|
|
|
|
oparg-breg? swap-args oparg-breg? or swap-args is-byteptr @ or ;
|
2023-09-01 23:10:52 +00:00
|
|
|
: byteval? ( v -- f ) 0xff00 & dup 0xff00 = swap 0 = or ;
|
2023-09-01 23:10:52 +00:00
|
|
|
|
2023-09-01 23:10:52 +00:00
|
|
|
: operror ( err -- ) lastop @ wordname type s" : " type type cr ;
|
2023-09-01 23:10:52 +00:00
|
|
|
: 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! ;
|
2023-09-01 23:10:52 +00:00
|
|
|
: @] -1 oparg-base ! oparg-complete! ;
|
2023-09-01 23:10:52 +00:00
|
|
|
|
|
|
|
: unexpected-addr ( addr -- ) drop s" unexpected address" operror ;
|
|
|
|
: @+ ( disp -- )
|
|
|
|
opargs-remaining @ if
|
2023-09-01 23:10:52 +00:00
|
|
|
oparg-type @ dup 0 = if drop oparg-mem! oparg-complete!
|
2023-09-01 23:10:52 +00:00
|
|
|
else 3 = if oparg-val !
|
|
|
|
else unexpected-addr then then
|
|
|
|
else unexpected-addr then ;
|
|
|
|
|
|
|
|
: l: create target @ , does> @ @+ ;
|
2023-09-01 23:10:52 +00:00
|
|
|
: l@ [ ' ' , ] cell + @ ;
|
2023-09-01 23:10:52 +00:00
|
|
|
|
|
|
|
: 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.)
|
|
|
|
0x25 reg es 0x27 reg ss 0x2d reg cs 0x2f reg ds
|
|
|
|
|
|
|
|
: start-op ( does-ptr argcount -- )
|
2023-09-01 23:10:52 +00:00
|
|
|
0 is-byteptr !
|
2023-09-01 23:10:52 +00:00
|
|
|
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
|
|
|
|
|
2023-09-01 23:10:52 +00:00
|
|
|
: :op ( count -- ) create , $DOCOLON , ] does>
|
2023-09-01 23:10:52 +00:00
|
|
|
dup @ dup start-op cell + op-encode ! ;
|
|
|
|
|
|
|
|
: memarg>case ( -- 0|1|2 )
|
|
|
|
oparg-base @ dup -1 = if drop 1 ( D16 ) else
|
2023-09-01 23:10:52 +00:00
|
|
|
6 = oparg-val @ 0 = and if 2 ( [bp]+0 ) else 0 ( standard ) then then ;
|
2023-09-01 23:10:52 +00:00
|
|
|
: memarg>dispsize ( -- 0|1|2 )
|
|
|
|
memarg>case dup 1 = if drop 2 else 2 = if 1 else
|
2023-09-01 23:10:52 +00:00
|
|
|
oparg-val @ dup 0 = if drop 0 else byteval? if 1 else 2
|
2023-09-01 23:10:52 +00:00
|
|
|
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 @ ;
|
|
|
|
|
2023-09-01 23:10:52 +00:00
|
|
|
: modrm>t ( reg mod rm -- ) 0x07 & swap 0x03 & 6 << | swap 0x07 & 3 << | >t ;
|
2023-09-01 23:10:52 +00:00
|
|
|
|
|
|
|
: invalid-args s" invalid argument types" operror ;
|
|
|
|
|
|
|
|
( convention: words ending in * mean "will return if matched" )
|
2023-09-01 23:10:52 +00:00
|
|
|
: disp>t oparg-val @ memarg>dispsize
|
|
|
|
dup 1 = if drop >t else 2 = if w>t else drop then then ;
|
2023-09-01 23:10:52 +00:00
|
|
|
: imm?>t oparg-imm? if oparg-val @ byteop? if >t else w>t then then ;
|
2023-09-01 23:10:52 +00:00
|
|
|
|
|
|
|
: >wreg+op* ( base -- )
|
|
|
|
oparg-wreg? if oparg-val @ | >t rdrop else drop then ;
|
|
|
|
: >segreg+op* ( off -- )
|
|
|
|
oparg-segreg? if oparg-val @ 0x0f & 1 << + >t rdrop else drop then ;
|
2023-09-01 23:10:52 +00:00
|
|
|
: >mem ( reg op -- ) >t memarg>mod+rm modrm>t disp>t swap-args imm?>t ;
|
|
|
|
: >mem* oparg-mem? byteop? not and if >mem rdrop else 2drop then ;
|
|
|
|
: >bmem* oparg-mem? byteop? and if >mem rdrop else 2drop then ;
|
|
|
|
|
2023-09-01 23:10:52 +00:00
|
|
|
: >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*
|
|
|
|
0 >segreg+op*
|
|
|
|
6 0xff >mem*
|
|
|
|
invalid-args ;
|
|
|
|
1 :op pop
|
|
|
|
0x58 >wreg+op*
|
|
|
|
1 >segreg+op*
|
|
|
|
0 0x8f >mem*
|
|
|
|
invalid-args ;
|
|
|
|
1 :op inc
|
|
|
|
0x40 >wreg+op*
|
|
|
|
0 0xfe >byte-regreg*
|
2023-09-01 23:10:52 +00:00
|
|
|
0 0xff >regreg*
|
|
|
|
0 0xff >mem*
|
2023-09-01 23:10:52 +00:00
|
|
|
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*
|
2023-09-01 23:10:52 +00:00
|
|
|
1 0xfe >bmem*
|
2023-09-01 23:10:52 +00:00
|
|
|
invalid-args ;
|
2023-09-01 23:10:52 +00:00
|
|
|
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 @ + - ;
|
|
|
|
: >short-jmp* ( op -- ) oparg-type @ 3 = if oparg-base @ -1 = if
|
|
|
|
oparg-val @ 2 diffaddr dup byteval? if swap >t >t rdrop return else drop
|
|
|
|
then then then drop ;
|
|
|
|
|
|
|
|
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 ;
|
|
|
|
|
|
|
|
2 :op xchg
|
|
|
|
arg2 oparg-reg? oparg-val @ 0x00 = arg1 oparg-wreg? and
|
|
|
|
if 0x90 >wreg+op* then
|
2023-09-01 23:10:52 +00:00
|
|
|
invalid-args ;
|
2023-09-01 23:10:52 +00:00
|
|
|
2 :op mov
|
|
|
|
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 ;
|