SpindleyQ/dialer
1
1
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

Assemble to dedicated segment by default, start of Forth kernel

Browse source 
rename assembly words to be ALL CAPS
This commit is contained in:
Jeremy Penner 2023-09-01 19:10:52 -04:00
parent 8439de78e9
commit 4575706684
3 changed files with 208 additions and 99 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

198
asm.jrt
View file

@ -1,14 +1,21 @@
var target var target
0x100 target ! 0x100 target !
: >t b, 1 target +! ; ( todo: write to target segment ) segalloc const tseg
: w>t , 2 target +! ;
: @t tseg @far ;
: b@t tseg b@far ;
: !t tseg !far ;
: b!t tseg b!far ;
: +target! ( bytes -- prevtarget ) target @ dup >rot + target ! ;
: >t 1 +target! b!t ;
: w>t 2 +target! !t ;
var op-encode var op-encode
var lastop var lastop var lastlabel
var op-memwidth var op-memwidth
: byteptr 1 op-memwidth ! ; : byteptr? op-memwidth @ 1 = ; : BYTE 1 op-memwidth ! ; : byteptr? op-memwidth @ 1 = ;
: farptr 4 op-memwidth ! ; : farptr? op-memwidth @ 4 = ; : FAR 4 op-memwidth ! ; : farptr? op-memwidth @ 4 = ;
var current-oparg var current-oparg
var opargs-remaining var opargs-remaining
@ -40,7 +47,7 @@ array oparg2 3 cells allot
: byteval? ( v -- f ) 0xff00 & dup 0xff00 = swap 0 = or ; : byteval? ( v -- f ) 0xff00 & dup 0xff00 = swap 0 = or ;
: oparg-bwreg? ( -- f ) byteop? if oparg-breg? else oparg-wreg? then ; : oparg-bwreg? ( -- f ) byteop? if oparg-breg? else oparg-wreg? then ;
: operror ( err -- ) lastop @ wordname type s" : " type type cr ; : operror ( err -- ) lastop @ type s" near " type lastlabel @ type s" : " type type cr ;
: oparg-complete! : oparg-complete!
opargs-remaining @ dup if opargs-remaining @ dup if
1 - dup opargs-remaining ! 1 - dup opargs-remaining !
@ -55,54 +62,52 @@ array oparg2 3 cells allot
: unexpected-addr ( addr -- ) drop s" unexpected address" operror ; : unexpected-addr ( addr -- ) drop s" unexpected address" operror ;
: @+ ( disp -- ) : @+ ( disp -- )
opargs-remaining @ if opargs-remaining @ if
oparg-type @ dup 0 = if drop oparg-mem! oparg-complete! oparg-type @ dup 0 = if drop oparg-mem! @]
else 3 = if oparg-val ! else 3 = if oparg-val !
else unexpected-addr then then else unexpected-addr then then
else unexpected-addr then ; else unexpected-addr then ;
: @far ( offset segment -- ) 4 set-oparg! oparg-base ! ; : @FAR ( offset segment -- ) 4 set-oparg! oparg-base ! ;
: oparg-faraddr? oparg-type @ 4 = ; : oparg-faraddr? oparg-type @ 4 = ;
: l: create target @ , does> @ @+ ; : L: here create wordname lastlabel ! target @ , does> @ @+ ;
: l@ [ ' ' , ] cell + @ ; : L@ [ ' ' , ] 2 cells + @ ;
: memreg create , does> @ oparg-base ! oparg-complete! ; : memreg create , does> @ oparg-base ! oparg-complete! ;
0 memreg bx+si] 1 memreg bx+di] 2 memreg bp+si] 3 memreg bp+di] 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] 4 memreg SI] 5 memreg DI] 6 memreg BP] 7 memreg BX]
: reg create , does> @ oparg-reg! oparg-complete! ; : reg create , does> @ oparg-reg! oparg-complete! ;
( data registers: take the bottom four bits and you have the ( data registers: take the bottom four bits and you have the
REG and R/M encoding for the modr/m byte ) REG and R/M encoding for the modr/m byte )
0x00 reg ax 0x01 reg cx 0x02 reg dx 0x03 reg bx 0x00 reg AX 0x01 reg CX 0x02 reg DX 0x03 reg BX
0x04 reg sp 0x05 reg bp 0x06 reg si 0x07 reg di 0x04 reg SP 0x05 reg BP 0x06 reg SI 0x07 reg DI
( 8-bit data registers, same scheme ) ( 8-bit data registers, same scheme )
0x10 reg al 0x11 reg cl 0x12 reg dl 0x13 reg bl 0x10 reg AL 0x11 reg CL 0x12 reg DL 0x13 reg BL
0x14 reg ah 0x15 reg ch 0x16 reg dh 0x17 reg bh 0x14 reg AH 0x15 reg CH 0x16 reg DH 0x17 reg BH
( segment registers: take the bottom four bits, left shift 1, ( segment registers; same scheme, )
and you have the PUSH instruction byte. bitwise or 0x01 and 0x20 reg ES 0x21 reg CS 0x22 reg SS 0x23 reg DS
you have POP.)
0x20 reg es 0x21 reg cs 0x22 reg ss 0x23 reg ds
: start-op ( does-ptr argcount -- ) : start-op ( dictentry argcount -- )
0 op-memwidth ! ( start unknown ) 0 op-memwidth ! ( start unknown )
opargs-remaining @ if s" not enough arguments" operror then opargs-remaining @ if s" not enough arguments" operror then
opargs-remaining ! cell - lastop ! arg1 ; opargs-remaining ! lastop ! arg1 ;
: prefix create , does> @ >t ; : prefix create , does> @ >t ;
: 0op create , does> dup 0 start-op @ >t ; : 0op here create wordname , b, does> dup @ 0 start-op cell + b@ >t ;
0x26 prefix es: 0x36 prefix ss: 0x2e prefix cs: 0x3e prefix ds: 0x26 prefix ES: 0x36 prefix SS: 0x2e prefix CS: 0x3e prefix DS:
0xf0 prefix lock 0xf2 prefix repnz 0xf3 prefix repz 0xf0 prefix LOCK 0xf2 prefix REPNZ 0xf3 prefix REPZ
0x90 0op nop 0xa4 0op movsb 0xa5 0op movsw 0xa6 0op cmpsb 0x90 0op NOP 0xa4 0op MOVSB 0xa5 0op MOVSW 0xa6 0op CMPSB
0xa7 0op cmpsw 0xc3 0op ret 0xd7 0op xlat 0xf4 0op hlt 0xa7 0op CMPSW 0xc3 0op RET 0xd7 0op XLAT 0xf4 0op HLT
0x98 0op cbw 0x99 0op cwd 0x9c 0op pushf 0x9d 0op popf 0x98 0op CBW 0x99 0op CWD 0x9c 0op PUSHF 0x9d 0op POPF
0x9e 0op sahf 0x9f 0op lahf 0xaa 0op stosb 0xab 0op stosw 0x9e 0op SAHF 0x9f 0op LAHF 0xaa 0op STOSB 0xab 0op STOSW
0xac 0op lodsb 0xad 0op lodsw 0xae 0op scasb 0xaf 0op scasw 0xac 0op LODSB 0xad 0op LODSW 0xae 0op SCASB 0xaf 0op SCASW
0xcb 0op retf 0xce 0op into 0xcf 0op iret 0xf8 0op clc 0xcb 0op RETF 0xce 0op INTO 0xcf 0op IRET 0xf8 0op CLC
0xf9 0op stc 0xfa 0op cli 0xfb 0op sti 0xfc 0op cld 0xf9 0op STC 0xfa 0op CLI 0xfb 0op STI 0xfc 0op CLD
0xfd 0op std 0xf5 0op cmc 0xfd 0op STD 0xf5 0op CMC
: :op ( count -- ) create , $DOCOLON , ] does> : :op ( count -- ) here create wordname , , $DOCOLON , ] does>
dup @ dup start-op cell + op-encode ! ; dup @ over cell + @ start-op 2 cells + op-encode ! ;
: memarg>case ( -- 0|1|2 ) : memarg>case ( -- 0|1|2 )
oparg-base @ dup -1 = if drop 1 ( D16 ) else oparg-base @ dup -1 = if drop 1 ( D16 ) else
@ -112,7 +117,7 @@ array oparg2 3 cells allot
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 ; then then then then ;
: memarg>mod+rm ( -- mod rm ) : memarg>mod+rm ( -- mod rm )
memarg>case dup 1 = if drop 0 6 else 2 = if 2 6 else memarg>case dup 1 = if drop 0 6 else 2 = if 1 6 else
memarg>dispsize oparg-base @ then then ; memarg>dispsize oparg-base @ then then ;
: regarg>mod+rm ( -- mod rm ) 3 oparg-val @ ; : regarg>mod+rm ( -- mod rm ) 3 oparg-val @ ;
@ -131,42 +136,39 @@ array oparg2 3 cells allot
oparg-segreg? if oparg-val @ 0x0f & 3 << + >t rdrop else drop then ; 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 ; : >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 ; : >memreg ( op -- ) swap-args oparg-val @ swap-args swap >mem ;
: >mem* oparg-mem? byteop? not and if >mem rdrop else 2drop then ; : >extmem* oparg-mem? byteop? not and if >mem rdrop else 2drop then ;
: >bmem* oparg-mem? byteop? and if >mem rdrop else 2drop then ; : >extbmem* oparg-mem? byteop? and if >mem rdrop else 2drop then ;
: >regreg ( reg op -- ) >t regarg>mod+rm modrm>t ; : >extreg ( reg op -- ) >t regarg>mod+rm modrm>t ;
: >byte-regreg* ( reg op -- ) oparg-breg? if >regreg rdrop else 2drop then ; : >extbreg* ( ext op -- ) oparg-breg? if >extreg rdrop else 2drop then ;
: >regreg* ( reg op -- ) oparg-wreg? if >regreg rdrop else 2drop then ; : >extreg* ( ext op -- ) oparg-wreg? if >extreg rdrop else 2drop then ;
1 :op ret- oparg-imm? if oparg-val @ w>t else invalid-args then ; 1 :op RET- oparg-imm? if oparg-val @ w>t else invalid-args then ;
1 :op push 1 :op PUSH
0x50 >wreg+op* 0x50 >wreg+op*
0x06 >segreg+op* 0x06 >segreg+op*
6 0xff >mem* 6 0xff >extmem*
invalid-args ; invalid-args ;
1 :op pop 1 :op POP
0x58 >wreg+op* 0x58 >wreg+op*
0x07 >segreg+op* 0x07 >segreg+op*
0 0x8f >mem* 0 0x8f >extmem*
invalid-args ; invalid-args ;
1 :op inc 1 :op INC
0x40 >wreg+op* 0x40 >wreg+op*
0 0xfe >byte-regreg* 0 0xfe >extbreg*
0 0xff >regreg* 0 0xff >extreg*
0 0xff >mem* 0 0xff >extmem*
1 0xff >extmem*
invalid-args ; invalid-args ;
1 :op incb 1 :op DEC
0 0xfe >byte-regreg*
0 0xfe >mem*
invalid-args ;
1 :op dec
0x48 >wreg+op* 0x48 >wreg+op*
1 0xfe >byte-regreg* 1 0xfe >extbreg*
1 0xff >regreg* 1 0xff >extreg*
0 0xff >mem* 1 0xff >extmem*
1 0xfe >bmem* 1 0xfe >extbmem*
invalid-args ; invalid-args ;
1 :op int 1 :op INT
oparg-imm? if oparg-val @ dup 3 = if drop 0xcc >t else 0xcd >t >t then oparg-imm? if oparg-val @ dup 3 = if drop 0xcc >t else 0xcd >t >t then
else invalid-args then ; else invalid-args then ;
@ -180,33 +182,37 @@ array oparg2 3 cells allot
: >far-jmp* ( op -- ) oparg-faraddr? : >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 rdrop else drop then ;
1 :op jo 0x70 >short-jmp* invalid-args ; 1 :op JO 0x70 >short-jmp* invalid-args ;
1 :op jno 0x71 >short-jmp* invalid-args ; 1 :op JNO 0x71 >short-jmp* invalid-args ;
1 :op jb 0x72 >short-jmp* invalid-args ; 1 :op JB 0x72 >short-jmp* invalid-args ;
1 :op jnb 0x73 >short-jmp* invalid-args ; 1 :op JNB 0x73 >short-jmp* invalid-args ;
1 :op jz 0x74 >short-jmp* invalid-args ; 1 :op JZ 0x74 >short-jmp* invalid-args ;
1 :op jnz 0x75 >short-jmp* invalid-args ; 1 :op JNZ 0x75 >short-jmp* invalid-args ;
1 :op jbe 0x76 >short-jmp* invalid-args ; 1 :op JBE 0x76 >short-jmp* invalid-args ;
1 :op ja 0x77 >short-jmp* invalid-args ; 1 :op JA 0x77 >short-jmp* invalid-args ;
1 :op js 0x78 >short-jmp* invalid-args ; 1 :op JS 0x78 >short-jmp* invalid-args ;
1 :op jns 0x79 >short-jmp* invalid-args ; 1 :op JNS 0x79 >short-jmp* invalid-args ;
1 :op jpe 0x7a >short-jmp* invalid-args ; 1 :op JPE 0x7a >short-jmp* invalid-args ;
1 :op jpo 0x7b >short-jmp* invalid-args ; 1 :op JPO 0x7b >short-jmp* invalid-args ;
1 :op jl 0x7c >short-jmp* invalid-args ; 1 :op JL 0x7c >short-jmp* invalid-args ;
1 :op jge 0x7d >short-jmp* invalid-args ; 1 :op JGE 0x7d >short-jmp* invalid-args ;
1 :op jle 0x7e >short-jmp* invalid-args ; 1 :op JLE 0x7e >short-jmp* invalid-args ;
1 :op jg 0x7f >short-jmp* invalid-args ; 1 :op JG 0x7f >short-jmp* invalid-args ;
1 :op loopnz 0xe0 >short-jmp* invalid-args ; 1 :op LOOPNZ 0xe0 >short-jmp* invalid-args ;
1 :op loopz 0xe1 >short-jmp* invalid-args ; 1 :op LOOPZ 0xe1 >short-jmp* invalid-args ;
1 :op loop 0xe2 >short-jmp* invalid-args ; 1 :op LOOP 0xe2 >short-jmp* invalid-args ;
1 :op jcxz 0xe3 >short-jmp* invalid-args ; 1 :op JCXZ 0xe3 >short-jmp* invalid-args ;
1 :op jmp 1 :op JMP
0xeb >short-jmp* 0xeb >short-jmp*
0xe9 >near-reljmp* 0xe9 >near-reljmp*
0xea >far-jmp* 0xea >far-jmp*
farptr? if 0x05 0xff >extmem* then
0x04 0xff >extmem* ( todo: JMP to reg allowed )
invalid-args ; invalid-args ;
1 :op call 1 :op CALL
0xe8 >near-reljmp* 0xe8 >near-reljmp*
farptr? if 0x03 0xff >extmem* then
0x02 0xff >extmem* ( todo: CALL reg allowed )
invalid-args ; invalid-args ;
( four opcodes laid out next to each other: ( four opcodes laid out next to each other:
@ -214,8 +220,16 @@ array oparg2 3 cells allot
: memreg? ( -- f ) oparg-mem? swap-args oparg-bwreg? swap-args and ; : memreg? ( -- f ) oparg-mem? swap-args oparg-bwreg? swap-args and ;
: >bmr-wmr? ( base -- f ) : >bmr-wmr? ( base -- f )
memreg? if byteop? not if 1 + then >memreg 1 else drop 0 then ; memreg? if byteop? not if 1 + then >memreg 1 else drop 0 then ;
: regreg? oparg-wreg? swap-args oparg-wreg? swap-args and ;
: bregbreg? oparg-breg? swap-args oparg-breg? swap-args and ;
: >regreg ( op -- f ) swap-args oparg-val @ swap swap-args >extreg ;
: >brr-wrr? ( base -- f )
regreg? if 1 + else bregbreg? not if drop 0 return then then >regreg 1 ;
: >bmr-wmr-brm-wrm* ( base -- ) : >bmr-wmr-brm-wrm* ( base -- )
dup >bmr-wmr? if drop rdrop return then 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 ; 2 + swap-args >bmr-wmr? swap-args if rdrop then ;
: >bmr-wmr-brm-wrm? ( base -- f ) : >bmr-wmr-brm-wrm? ( base -- f )
1 swap >bmr-wmr-brm-wrm* drop 0 ; 1 swap >bmr-wmr-brm-wrm* drop 0 ;
@ -226,25 +240,25 @@ array oparg2 3 cells allot
oparg-val @ dup 0x10 = if drop >t swap-args imm?>t swap-args rdrop 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 ; 0x00 = if 1 + >t swap-args imm?>t swap-args rdrop return else drop then ;
2 :op xchg 2 :op XCHG
arg2 oparg-reg? oparg-val @ 0x00 = arg1 oparg-wreg? and arg2 oparg-reg? oparg-val @ 0x00 = arg1 oparg-wreg? and
if 0x90 >wreg+op* then if 0x90 >wreg+op* then
invalid-args ; invalid-args ;
2 :op mov 2 :op MOV
0x88 >bmr-wmr-brm-wrm* 0x88 >bmr-wmr-brm-wrm*
arg2 oparg-imm? arg1 if arg2 oparg-imm? arg1 if
oparg-wreg? if oparg-val @ 0xb8 | >t arg2 oparg-val @ w>t return then 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 oparg-breg? if oparg-val @ 0x0f & 0xb0 | >t arg2 oparg-val @ >t return then
0 0xc6 >bmem* 0 0xc6 >extbmem*
0 0xc7 >mem* 0 0xc7 >extmem*
then then
invalid-args ; invalid-args ;
2 :op add 0x00 >6group-math* invalid-args ; 2 :op ADD 0x00 >6group-math* invalid-args ;
2 :op adc 0x10 >6group-math* invalid-args ; 2 :op ADC 0x10 >6group-math* invalid-args ;
2 :op AND 0x20 >6group-math* invalid-args ; 2 :op AND 0x20 >6group-math* invalid-args ;
2 :op xor 0x30 >6group-math* invalid-args ; 2 :op XOR 0x30 >6group-math* invalid-args ;
2 :op OR 0x08 >6group-math* invalid-args ; 2 :op OR 0x08 >6group-math* invalid-args ;
2 :op sbb 0x18 >6group-math* invalid-args ; 2 :op SBB 0x18 >6group-math* invalid-args ;
2 :op sub 0x28 >6group-math* invalid-args ; 2 :op SUB 0x28 >6group-math* invalid-args ;
2 :op cmp 0x38 >6group-math* invalid-args ; 2 :op CMP 0x38 >6group-math* invalid-args ;

BIN
tinyjort.com
View file

Binary file not shown.

109
tinyjort.jrt
View file

@ -1,14 +1,109 @@
s" defs.jrt" loadfile s" defs.jrt" loadfile
s" asm.jrt" loadfile s" asm.jrt" loadfile
here ( tinyjort calling convention:
SP - data stack pointer, grows down
BP - return stack pointer, grows up
SI - instruction pointer
BX - W register - code pointer for current word
mov ah 0x02 # all other registers can and will be clobbered
mov dl key ! # )
int 0x21 #
ret JMP 0x1000 @+
: NEXT
LODSW
MOV BX AX
JMP @[ BX] ;
( dictionary format:
DICTIONARY - an array of 16 pointers to linked lists of entries.
The dictlist for a given word is chosen by taking the
first character of the word and taking its first 4
bits.
Entry:
LINK - pointer to next word in the dictionary
FLAGS - byte
LENGTH - byte
NAME - bytes ending in \0
CODE POINTER - pointer to machine code routine )
L: DICTIONARY
0 w>t 0 w>t 0 w>t 0 w>t 0 w>t 0 w>t 0 w>t 0 w>t
0 w>t 0 w>t 0 w>t 0 w>t 0 w>t 0 w>t 0 w>t 0 w>t
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 ] + ;
: 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 ;
: DEF word dup savelabel dup DICTLIST link>t 0 >t dup strlen >t str>t ;
: WORD= ( word len tptr -- f ) ;
: t' word dup strlen over DICTLIST @t ( word len tptr )
begin dup @t while 3dup WORD= if 5 + + swap drop return then repeat
drop drop drop 0 ;
;
: :ASM DEF target @ 2 + w>t ;
L: $$CONST
INC BX INC BX
PUSH @[ BX]
NEXT
: CONST DEF [ L@ $$CONST lit ] w>t w>t ;
L@ DICTIONARY CONST dictionary
L@ LATEST CONST latest
L: $$VAR
INC BX INC BX
PUSH BX
NEXT
: ARRAY DEF [ L@ $$VAR lit ] w>t ;
: VAR, ARRAY w>t ;
( "codepointer words" that evaluate to a pointer to the assembly -
useful to define things like $DOCOLON. )
: :CP ARRAY ;
L@ $$VAR CONST $DOVAR
:CP $DOCOLON
L: $$COLON
MOV @[ BP] SI
INC BP INC BP
INC BX INC BX
MOV SI BX
NEXT
:ASM return
DEC BP DEC BP
MOV @[ BP] SI
NEXT
:CP $DODEFERRED
INC BX INC BX
MOV BX @[ BX]
JMP @[ BX]
:ASM LIT_
LODSW
PUSH AX
NEXT
:ASM GOTO_
LODSW
MOV SI AX
NEXT
( 0x1000 target ! )
.s
here
s" tinyjort.com" overwrite s" tinyjort.com" overwrite
:noname for i b@ fputc next ; execute 0x100 target @ :noname for i tseg b@far fputc next ; execute
close close