First correctly-assembled code snippet (printed as hex to stdout)

This commit is contained in:
Jeremy Penner 2023-09-01 19:10:52 -04:00
parent 102751b342
commit 73ffd53c68
6 changed files with 34 additions and 98 deletions

29
asm.jrt
View file

@ -11,9 +11,8 @@ var opargs-remaining
array oparg1 3 cells allot
array oparg2 3 cells allot
: arg1 oparg1 current-oparg ! ;
: arg1 oparg1 current-oparg ! ; arg1
: arg2 oparg2 current-oparg ! ;
arg1
: swap-args current-oparg @ oparg1 = if arg2 else arg1 then ;
: oparg-type ( -- type ) current-oparg @ ;
@ -36,14 +35,10 @@ arg1
( ie. inc [bx] vs inc byte [bx]?? )
( or do we just say incb? )
: bytearg? ( -- f )
current-oparg @
arg1 oparg-reg? oparg-breg? and
arg2 oparg-reg? oparg-breg? and or
swap current-oparg ! ;
: byteval? ( v -- f ) 0xff00 & dup 0xff00 = swap 0= or ;
: bytearg? ( -- f ) oparg-breg? swap-args oparg-breg? or swap-args ;
: byteval? ( v -- f ) 0xff00 & dup 0xff00 = swap 0 = or ;
: operror ( err -- ) lastop @ wordname type s": " type type cr ;
: operror ( err -- ) lastop @ wordname type s" : " type type cr ;
: oparg-complete!
opargs-remaining @ dup if
1 - dup opargs-remaining !
@ -53,17 +48,18 @@ arg1
: # oparg-imm! oparg-complete! ;
: @[ 0 oparg-mem! ;
: @] -1 oparg-base ! oparg-complete ! ;
: @] -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!
oparg-type @ dup 0 = if drop oparg-mem! oparg-complete!
else 3 = if oparg-val !
else unexpected-addr then then
else unexpected-addr then ;
: 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]
@ -100,27 +96,28 @@ arg1
0xf9 0op stc 0xfa 0op cli 0xfb 0op sti 0xfc 0op cld
0xfd 0op std 0xf5 0op cmc
: :op ( count -- ) , $DOCOLON , does>
: :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= if 2 ( [bp]+0 ) else 0 ( standard ) then then ;
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
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 -- ) 0x03 & swap 0x02 & 6 << | swap 0x03 & 3 << | >t ;
: 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 memarg>dispsize dup 1= if drop >t else 2 = if w>t else drop then then ;
: 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 @ dup byteval? if >t else w>t then then ;
: >wreg+op* ( base -- )

View file

@ -9,6 +9,7 @@
: 2swap ( a b c d -- c d a b )
>r >rot <r >rot ;
: 2drop drop drop ;
: negate 0 swap - ;
: abs dup 0 < if negate then ;
@ -51,13 +52,12 @@
: yield rswap ;
: done rdrop 0 >r rswap ;
: ;done ' done , ] ; immediate
: ;done ' done , [ ' [ , ] ; immediate
: each [ ' begin , ] ' r@ , [ ' while , ] ; immediate
: more ' yield , [ ' repeat , ] ' rdrop , ; immediate
: break rswap rdrop :| yield done |; execute rswap ;
: links begin yield @ dup not until drop ;done
: files findfile begin dup while yield nextfile repeat drop ;done
: .files files each type s" " type more ;
@ -74,86 +74,13 @@
: intern create latest wordname , does> @ ;
: preserving ( cp 0 vars... -- )
0 >r begin dup while dup @ >r >r repeat drop
execute
begin r@ while <r <r swap ! repeat rdrop ;
: preserve ( cp var -- ) 0 swap preserves ;
: decompile-from ( ip -- )
begin dup @ ' return != while
dup @ dup ` dup if type drop else drop . then bl
cell +
repeat drop ;
: decompile word lookup if cell + decompile-from else drop then ; userword
: words
latest links each
dup wordflags F_USERWORD f@ if
dup wordname type bl
then
more ;
: lazy here $DODEFERRED , ' noop , ;
: >lazy! latest codepointer swap redefine ;
: dbg" [ ' s" , ] :| type bl .s cr |; expile ; immediate
( tasks )
: mailbox 2 cells + ;
: task-ip task-user-size cells + ;
: task-sp task-user-size 1 + cells + ;
: task-rsp task-user-size 2 + cells + ;
: task-stack task-user-size 3 + cells + ;
: task-rstack task-stack stacksize cells + ;
: .wordin ( ptr -- )
latest links each
2dup > if wordname type drop 0 break then
more dup if . else drop then ; userword
: tasks.s
tasks links each
dup dup . .wordin s" : " type
dup task-sp @ over task-stack ( task stackLim stack )
2dup . . s" : " type
begin 2dup > while dup @ . cell + repeat
cr drop drop more ; userword
: task.bt ( task -- )
dup task-rsp @ swap task-rstack ( rstackLim rstack )
begin 2dup > while dup @ dup . .wordin cr cell + repeat
drop drop ; userword
: doactivate ( task ip -- )
over task-ip !
dup task-stack over task-sp !
dup task-rstack over task-rsp !
drop
;
: activate
here 4 cells + lit
' doactivate ,
' return ,
; immediate
: >task ( val task -- )
task-sp >r r@ @ ! r@ @ cell + r> ! ;
: try-send ( val task -- b )
mailbox dup @ if drop drop 0 else ! 1 then ;
: wait-send ( val task -- )
mailbox
begin dup @ while suspend repeat ( wait for empty mailbox )
! ;
: send ( val task -- ) try-send drop ;
: receive ( -- val )
running mailbox
begin dup @ not while suspend repeat ( wait for mail )
dup @ 0 <rot ! ;
: .hexnib ( x -- )
dup 0 >= over 9 <= and if [ key 0 lit ]
else 10 - [ key A lit ] then + emit ;
: .hex dup 0xf0 & 4 >> .hexnib 0x0f & .hexnib bl ;

2
main.c
View file

@ -6,6 +6,6 @@ int main(int argc, char *argv[]) {
f_interpreter();
fclose(IN_FILE);
IN_FILE = stdin;
f_execcp( f_lookupcp("interpreter"));
f_execcp(f_lookupcp("interpreter"));
return 0;
}

Binary file not shown.

Binary file not shown.

12
tinyjort.jrt Executable file
View file

@ -0,0 +1,12 @@
s" defs.jrt" loadfile
s" asm.jrt" loadfile
here
push ax
pop bx
inc @[ bx]
here
:noname for i b@ .hex next ; execute