Expanded Forth kernel with simple test program
This commit is contained in:
parent
e6f7b14413
commit
63ee66a8e5
1
.gitignore
vendored
1
.gitignore
vendored
|
@ -1,4 +1,5 @@
|
|||
*.bak
|
||||
*.obj
|
||||
*.dsk
|
||||
errors.txt
|
||||
|
||||
|
|
BIN
tinyjort.com
BIN
tinyjort.com
Binary file not shown.
136
tinyjort.jrt
136
tinyjort.jrt
|
@ -7,10 +7,12 @@ s" asm.jrt" loadfile
|
|||
SI - instruction pointer
|
||||
BX - W register - code pointer for current word
|
||||
|
||||
all other registers can and will be clobbered
|
||||
all other registers can and will be clobbered.
|
||||
DF must be cleared before calling NEXT, as LODSW is used to
|
||||
increment the instruction pointer.
|
||||
)
|
||||
|
||||
JMP 0x1000 @+
|
||||
JMP 9 @>
|
||||
|
||||
: NEXT
|
||||
LODSW
|
||||
|
@ -42,11 +44,17 @@ L: LATEST 0 w>t
|
|||
: 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
|
||||
: WORD= ( word len tptr -- f )
|
||||
3 + dup b@t <rot != if 2drop 0 return then 1 + ( word tword )
|
||||
begin over b@ over b@t = while
|
||||
over b@ not if 2drop 1 return then ( 0 byte, matched )
|
||||
1 + swap 1 + swap
|
||||
repeat 2drop 0 ;
|
||||
|
||||
: t' word dup strlen over DICTLIST ( word len tptr-next-entry )
|
||||
begin dup while 3dup WORD= if 5 + + swap drop return then @t repeat
|
||||
drop drop drop 0 ;
|
||||
;
|
||||
|
||||
: :ASM DEF target @ 2 + w>t ;
|
||||
|
||||
L: $$CONST
|
||||
|
@ -107,7 +115,121 @@ L: GOTO_IMPL 0 <:
|
|||
|
||||
DEF GOTO_ L@ GOTO_IMPL w>t
|
||||
|
||||
( 0x1000 target ! )
|
||||
L: BASE 10 w>t
|
||||
:ASM number ( str -- num 1 | str 0 )
|
||||
( AX - current number
|
||||
BX - saved IP, as SI will be clobbered by LODSB
|
||||
CX - current digit count, used to detect 0x prefix
|
||||
DX - clobbered by IMUL
|
||||
SI - remainder of string to be parsed )
|
||||
MOV BX SI ( save IP )
|
||||
POP SI
|
||||
PUSH SI
|
||||
MOV BASE 10 #
|
||||
|
||||
XOR AX AX
|
||||
XOR CX CX
|
||||
L: next-digit
|
||||
IMUL BASE
|
||||
MOV BL AL
|
||||
LODSB
|
||||
CMP AL 0 #
|
||||
JZ 1 @> ( string end )
|
||||
CMP AL key 9 #
|
||||
JG 2 @> ( hex or fail )
|
||||
SUB AL key 0 #
|
||||
JL 0 @> ( not a number )
|
||||
L: parsed-digit
|
||||
ADD BL AL
|
||||
ADC AH 0 #
|
||||
INC CX
|
||||
JMP next-digit
|
||||
L: fail-digit 0 <:
|
||||
MOV SI BX
|
||||
PUSH 0 #
|
||||
NEXT
|
||||
1 <: ( string end )
|
||||
JCXZ fail-digit ( empty string is not zero )
|
||||
MOV SI BX
|
||||
POP DX
|
||||
PUSH AX
|
||||
PUSH 1 #
|
||||
NEXT
|
||||
2 <: ( hex or fail )
|
||||
CMP AL key x ( lowercase x )
|
||||
JNZ 0 @>
|
||||
CMP CX 1 # ( x is second character )
|
||||
JNZ 1 @>
|
||||
CMP BL 0 # ( first character was a 0 )
|
||||
JNZ 2 @>
|
||||
MOV BASE 16 #
|
||||
JMP next-digit
|
||||
0 <: 1 <: 2 <: ( actual parsing of hex digit )
|
||||
SUB AL key A #
|
||||
JL fail-digit
|
||||
ADD AL 10 #
|
||||
CMP AL BASE
|
||||
JL parsed-digit
|
||||
SUB AL key a key A - 10 - #
|
||||
JL fail-digit
|
||||
ADD AL 10 #
|
||||
CMP AL BASE
|
||||
JL parsed-digit
|
||||
JMP fail-digit
|
||||
|
||||
:ASM drop
|
||||
POP AX
|
||||
NEXT
|
||||
|
||||
:ASM dup
|
||||
POP AX
|
||||
PUSH AX
|
||||
PUSH AX
|
||||
NEXT
|
||||
|
||||
:ASM swap
|
||||
POP AX
|
||||
POP BX
|
||||
PUSH AX
|
||||
PUSH BX
|
||||
NEXT
|
||||
|
||||
:ASM over
|
||||
POP AX
|
||||
POP BX
|
||||
POP BX
|
||||
POP AX
|
||||
POP BX
|
||||
NEXT
|
||||
|
||||
:ASM <rot
|
||||
POP AX
|
||||
POP BX
|
||||
POP CX
|
||||
PUSH BX
|
||||
PUSH AX
|
||||
PUSH CX
|
||||
NEXT
|
||||
|
||||
:ASM emit
|
||||
MOV AH 5 #
|
||||
POP DX
|
||||
INT 0x21 #
|
||||
NEXT
|
||||
|
||||
:ASM terminate
|
||||
MOV AH 0x4c #
|
||||
MOV AL 0 # ( todo: pop )
|
||||
INT 0x21 #
|
||||
|
||||
( test program )
|
||||
ARRAY hex65 key 0 >t key x >t key 6 >t key 5 >t 0 >t
|
||||
L: test-word L@ $$COLON w>t t' hex65 w>t t' emit w>t t' terminate w>t
|
||||
|
||||
9 <: ( actual entry point )
|
||||
LEA SI test-word
|
||||
( TODO: configure stacks )
|
||||
NEXT
|
||||
|
||||
.s
|
||||
|
||||
|
|
Loading…
Reference in a new issue