Expanded Forth kernel with simple test program

This commit is contained in:
Jeremy Penner 2023-09-01 19:10:54 -04:00
parent e6f7b14413
commit 63ee66a8e5
3 changed files with 130 additions and 7 deletions

1
.gitignore vendored
View file

@ -1,4 +1,5 @@
*.bak
*.obj
*.dsk
errors.txt

Binary file not shown.

View file

@ -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