implement anonymous forward labels
This commit is contained in:
parent
4575706684
commit
e6f7b14413
175
asm.jrt
175
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! ;
|
||||
|
|
@ -61,14 +68,27 @@ 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! @]
|
||||
else 3 = if oparg-val !
|
||||
else unexpected-addr then then
|
||||
else unexpected-addr then ;
|
||||
opargs-remaining @ if
|
||||
oparg-unset? if oparg-mem! @] return then
|
||||
oparg-mem? if oparg-val ! return then
|
||||
then drop unexpected-addr ;
|
||||
|
||||
: @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 ;
|
||||
|
||||
: invalid-args s" invalid argument types" operror ;
|
||||
: pre-disp-write memarg>case 2 = if ' patch-a16 patchpoint then ;
|
||||
|
||||
( 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 ;
|
||||
: >extbmem* oparg-mem? byteop? 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 2ret then 2drop ;
|
||||
|
||||
: >extreg ( reg op -- ) >t regarg>mod+rm modrm>t ;
|
||||
: >extbreg* ( ext op -- ) oparg-breg? if >extreg rdrop else 2drop then ;
|
||||
: >extreg* ( ext op -- ) oparg-wreg? if >extreg rdrop else 2drop then ;
|
||||
: >extbreg* ( ext op -- ) oparg-breg? if >extreg 2ret then 2drop ;
|
||||
: >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*
|
||||
invalid-args ;
|
||||
6 0xff >extmem* ;
|
||||
1 :op POP
|
||||
0x58 >wreg+op*
|
||||
0x07 >segreg+op*
|
||||
0 0x8f >extmem*
|
||||
invalid-args ;
|
||||
0 0x8f >extmem* ;
|
||||
1 :op INC
|
||||
0x40 >wreg+op*
|
||||
0 0xfe >extbreg*
|
||||
0 0xff >extreg*
|
||||
0 0xff >extmem*
|
||||
1 0xff >extmem*
|
||||
invalid-args ;
|
||||
1 0xff >extmem* ;
|
||||
1 :op DEC
|
||||
0x48 >wreg+op*
|
||||
1 0xfe >extbreg*
|
||||
1 0xff >extreg*
|
||||
1 0xff >extmem*
|
||||
1 0xfe >extbmem*
|
||||
invalid-args ;
|
||||
1 0xfe >extbmem* ;
|
||||
1 :op INT
|
||||
oparg-imm? if oparg-val @ dup 3 = if drop 0xcc >t else 0xcd >t >t then
|
||||
else invalid-args then ;
|
||||
oparg-imm? if
|
||||
oparg-val @ dup 3 = if drop 0xcc >t else 0xcd >t >t then
|
||||
then ;
|
||||
|
||||
: diffaddr ( addr opsize -- diff ) target @ + - ;
|
||||
: oparg-nearaddr? ( -- f ) oparg-type @ 3 = oparg-base @ -1 = and ;
|
||||
: diffaddr ( opsize -- diff ) oparg-val @ swap target @ + - ;
|
||||
: 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
|
||||
then then drop ;
|
||||
2 diffaddr dup byteval? oparg-mempatch? or
|
||||
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 ;
|
||||
: >far-jmp* ( op -- ) oparg-faraddr?
|
||||
if >t oparg-base @ w>t oparg-val @ 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 2ret 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 ;
|
||||
1 :op JO 0x70 >short-jmp* ;
|
||||
1 :op JNO 0x71 >short-jmp* ;
|
||||
1 :op JB 0x72 >short-jmp* ;
|
||||
1 :op JNB 0x73 >short-jmp* ;
|
||||
1 :op JZ 0x74 >short-jmp* ;
|
||||
1 :op JNZ 0x75 >short-jmp* ;
|
||||
1 :op JBE 0x76 >short-jmp* ;
|
||||
1 :op JA 0x77 >short-jmp* ;
|
||||
1 :op JS 0x78 >short-jmp* ;
|
||||
1 :op JNS 0x79 >short-jmp* ;
|
||||
1 :op JPE 0x7a >short-jmp* ;
|
||||
1 :op JPO 0x7b >short-jmp* ;
|
||||
1 :op JL 0x7c >short-jmp* ;
|
||||
1 :op JGE 0x7d >short-jmp* ;
|
||||
1 :op JLE 0x7e >short-jmp* ;
|
||||
1 :op JG 0x7f >short-jmp* ;
|
||||
1 :op LOOPNZ 0xe0 >short-jmp* ;
|
||||
1 :op LOOPZ 0xe1 >short-jmp* ;
|
||||
1 :op LOOP 0xe2 >short-jmp* ;
|
||||
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 )
|
||||
invalid-args ;
|
||||
0x04 0xff >extmem* ( todo: JMP to reg allowed ) ;
|
||||
1 :op CALL
|
||||
0xe8 >near-reljmp*
|
||||
farptr? if 0x03 0xff >extmem* then
|
||||
0x02 0xff >extmem* ( todo: CALL reg allowed )
|
||||
invalid-args ;
|
||||
0x02 0xff >extmem* ( todo: CALL reg allowed ) ;
|
||||
|
||||
( 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 >brr-wrr? if drop rdrop return then
|
||||
2 + swap-args >bmr-wmr? swap-args if rdrop then ;
|
||||
dup >bmr-wmr? if drop 2ret then
|
||||
dup >brr-wrr? if drop 2ret 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
|
||||
0x00 = if 1 + >t swap-args imm?>t swap-args rdrop return else drop then ;
|
||||
oparg-val @ dup
|
||||
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
|
||||
invalid-args ;
|
||||
if 0x90 >wreg+op* then ;
|
||||
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
|
||||
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 ;
|
||||
then ;
|
||||
2 :op ADD 0x00 >6group-math* ;
|
||||
2 :op ADC 0x10 >6group-math* ;
|
||||
2 :op AND 0x20 >6group-math* ;
|
||||
2 :op XOR 0x30 >6group-math* ;
|
||||
2 :op OR 0x08 >6group-math* ;
|
||||
2 :op SBB 0x18 >6group-math* ;
|
||||
2 :op SUB 0x28 >6group-math* ;
|
||||
2 :op CMP 0x38 >6group-math* ;
|
||||
|
||||
|
|
|
|||
BIN
tinyjort.com
BIN
tinyjort.com
Binary file not shown.
11
tinyjort.jrt
11
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
|
||||
|
|
|
|||
Loading…
Reference in a new issue