dialer/tinyjort.jrt

522 lines
13 KiB
Plaintext
Executable File

dbg" assembling..."
( 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
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 9 @>
( 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
META - word, made up of:
LENGTH - byte
FLAGS - byte
NAME - bytes ending in \0
CODE POINTER - pointer to machine code routine )
0x0f const BUCKETMASK
BUCKETMASK 1+ cells const LATESTOFF
LATESTOFF cell + const DICTSIZE
L: DICTIONARY DICTSIZE ALLOT
L@ DICTIONARY LATESTOFF + const &LATEST
: savelabel ( word -- )
( dup type s" : " type )
here swap begin dup b@ dup while b, 1+ repeat b, drop lastlabel ! ;
: DICTLIST ( word -- tptr ) b@ BUCKETMASK & 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 patch!t w>t ;
: DEF target &LATEST !t
word dup savelabel dup DICTLIST link>t dup strlen w>t str>t
( target cell + .hex cr ) ;
: WORD= ( word len tptr -- f )
cell + dup b@t <rot != if 2drop 0 return then cell + ( 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 ;
: tlookup ( word -- tcp )
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 ;
: t' word tlookup ;
: t& t' cell + ;
: '>t t' w>t ;
s" coredefs.jrt" loadfile
: stch? ( str -- f ) ' @ , key lit ' = , ; immediate
( DOES NOT SUPPORT ARBITRARY IMMEDIATE WORDS.
Supports [], comments, ; and numeric literals ONLY.
You must use [ for anything fancy. )
: compt
begin word dup stch? ; not while
state if dup stch? [ if drop [ ' [ , ] else
dup stch? ( if drop [ ' ( , ] else
dup tlookup dup if w>t drop else drop
number if [ t' LIT_ lit ] w>t w>t else
type s" ?" type cr then then then then else
expileword then
repeat drop [ t' return lit ] w>t [ ' [ , ] ;
: :t DEF [ t& $DOCOLON lit ] w>t ] compt ;
s" logic.jrt" loadfile
dbg" allocation"
BUCKETMASK CONST BUCKETMASK
LATESTOFF CONST LATESTOFF
DICTSIZE CONST DICTSIZE
L@ DICTIONARY CONST primary-dict
DEFERRED dictionary primary-dict
:t &latest dictionary LATESTOFF + ;
0 VAR, &here
:t here &here @ ;
:t here! &here ! ;
0xffff CONST there
:t latest &latest @ ;
:t latest! &latest ! ;
0 VAR, lastseg
:t segalloc lastseg @ 4096 + dup lastseg ! ;
2 CONST cell
:t cells 2* ;
:t allot [ target ] dup BZ_ [ patchpt ] 1-
0 here b! here 1+ here!
GOTO_ [ swap w>t patch!t ] drop ;
:t , here ! here cell + here! ;
:t b, here b! here 1+ here! ;
: t" begin key dup [ key " lit ] != while >t repeat drop 0 >t ;
dbg" i/o"
s" file.jrt" loadfile
:ASM console-emit
MOV AH 2 #
POP DX
INT 0x21 #
NEXT
DEFERRED emit console-emit
:t cr 10 emit 13 emit ;
:t bl LIT_ [ key w>t ] emit ;
:t type
[ target ] dup b@ dup BZ_ [ patchpt ]
emit 1+ GOTO_ [ swap w>t patch!t ]
drop drop ;
:ASM console-key
MOV AH 8 #
INT 0x21 #
XOR AH AH
PUSH AX
NEXT
127 const INBUFSIZE
INBUFSIZE CONST INBUFSIZE
ARRAY inbuf INBUFSIZE 1+ ALLOT
t& inbuf VAR, inptr
:t buf-key inptr @ b@ dup BZ_ [ patchpt ] inptr @ 1+ inptr ! [ patch!t ] ;
0 VAR, infile ( 0 is a predefined file handle meaning stdin )
:t stdin-key
buf-key dup BZ_ [ patchpt ] return [ patch!t ] drop
( if buffer is empty, refresh from file )
INBUFSIZE inbuf 0 fread
( if there's any more data, start returning it )
fcount @ dup BZ_ [ patchpt ] inbuf + 0 swap b! inbuf inptr ! buf-key return
( otherwise, EOF ) [ patch!t ] drop EOF ;
:t file-key infile @ dup BZ_ [ patchpt ] fgetc return
[ patch!t ] drop stdin-key ;
DEFERRED key file-key
dbg" parsing"
L: BASE 10 w>t L: ISNEG? 0 >t
:ASM number ( str -- num 1 | str 0 )
( AX - current number
BH - 0
BL - current character
CX - current digit count, used to detect 0x prefix
DX - clobbered by IMUL
SI - remainder of string to be parsed
DI - saved IP, as SI will be clobbered by LODSB )
MOV DI SI ( save IP )
POP SI
PUSH SI
MOV BASE 10 #
XOR AX AX
XOR BX BX
XOR CX CX
MOV BYTE ISNEG? AL
L: next-digit
MOV BL AL
LODSB
XCHG AL BL
OR BL BL
JZ 1 @> ( string end )
JCXZ 3 @> ( starts with negative? )
L: parse-digit
CMP BL key 9 #
JG 2 @> ( hex or fail )
SUB BL key 0 #
JL 0 @> ( not a number )
L: parsed-digit
IMUL BASE
ADD AX BX
INC CX
JMP next-digit
L: fail-digit 0 <:
MOV SI DI
XOR CX CX
PUSH CX
NEXT
1 <: ( string end )
JCXZ fail-digit ( empty string is not zero )
CMP BYTE ISNEG? 0 #
JZ 1 @>
NEG AX
1 <:
MOV SI DI
POP DX
PUSH AX
PUSH CX ( we know cx is nonzero and will be treated as true )
NEXT
3 <: ( negative? )
CMP BL key - #
JNZ parse-digit
CMP BYTE ISNEG? 0 #
JNZ fail-digit ( only one negative sign allowed )
MOV BYTE ISNEG? BL ( any nonzero value will do )
JMP next-digit
2 <: ( hex or fail )
CMP BL key x # ( lowercase x )
JNZ 0 @>
CMP CX 1 # ( x is second character )
JNZ 1 @>
OR AX AX ( first character was a 0 )
JNZ 2 @>
MOV BASE 16 #
JMP next-digit
0 <: 1 <: 2 <: ( actual parsing of hex digit )
SUB BL key A #
JL fail-digit
ADD BL 10 #
CMP BL BASE
JL parsed-digit
SUB BL key a key A - 10 + #
JL fail-digit
ADD BL 10 #
CMP BL BASE
JL parsed-digit
JMP fail-digit
L: DECDIVISORS 1 w>t 10 w>t 100 w>t 1000 w>t 10000 w>t
L: NUMBUF 7 ALLOT ( 5 digits, - sign, ending null )
:ASM num>str
MOV AX DS
MOV ES AX
MOV DI L@ NUMBUF #
POP AX
OR AX AX
JGE 0 @>
MOV BYTE @[ DI] key - #
NEG AX
INC DI
0 <:
PUSH SI
MOV SI 4 cells #
MOV BX L@ DECDIVISORS #
MOV CX 4 # ( CX=0 when we should write zeros )
L: write-next-digit
XOR DX DX
IDIV @[ BX+SI]
OR AX AX
JNZ 1 @>
JCXZ 0 @> ( unconditionally write a zero )
DEC CX ( if we haven't written any digits this will hit 0 on the ones place )
JMP 2 @>
1 <: 0 <:
XOR CX CX ( we've started outputting digits - set CX to 0 )
ADD AX key 0 #
STOSB
2 <:
MOV AX DX
DEC SI
DEC SI
JNS write-next-digit ( once SI decrements below zero the sign bit will set )
XOR AX AX
STOSB ( trailing 0 )
POP SI
MOV DI L@ NUMBUF #
PUSH DI
NEXT
:t . num>str type bl ;
:ASM whitespace?
POP AX
CMP AX key #
JZ 0 @>
CMP AX 13 # ( newline )
JZ 1 @>
CMP AX 10 # ( linefeed )
JZ 2 @>
CMP AX 9 # ( tab )
JNZ 3 @>
0 <: 1 <: 2 <:
PUSH TRUE
NEXT
3 <:
PUSH FALSE
NEXT
:ASM eoi? ( end of input )
POP AX
OR AX AX ( null )
JZ 0 @>
CMP AX -1 # ( EOF )
JNZ 1 @>
0 <:
PUSH TRUE
NEXT
1 <:
PUSH FALSE
NEXT
:t word,
( consume leading whitespace )
0 [ target ] drop key dup whitespace? not BZ_ [ w>t ]
( consume non-whitespace / eoi characters )
[ target ] dup whitespace? over eoi? or
( if whitespace or eoi, end ) BZ_ [ patchpt ] drop 0 b, return [ patch!t ]
( otherwise, write byte and continue ) b, key GOTO_ [ w>t ] ;
ARRAY wordbuf 48 ALLOT
:t redir-, ( cp buf -- buf ) here >r dup >r here! execute <r <r here! ;
:t tmp-, ( cp -- buf ) here redir-, ;
:t word LIT_ word, wordbuf redir-, ;
dbg" compiler"
:t wordflags cell + ;
:t wordname 2 cells + ;
:t wordlen wordflags ub@ ;
:t codepointer dup wordname swap wordlen + ( trailing null ) 1+ ;
:t dictbucket ( word -- p ) ub@ BUCKETMASK & cells dictionary + ;
:t new-word
( set latest ) here latest!
( create entry ) 0 dup , ,
( save word + calc length ) here word, here swap - 1- ( ignore null )
( save length ) latest wordflags !
( find bucket ) latest wordname dictbucket
( link to prev ) dup @ latest !
( link bucket to new ) latest swap ! ;
:t 2inc ( x y -- x+1 y+1 ) 1+ swap 1+ swap ;
:t strlen ( name -- len )
0 swap [ target ] dup b@ BZ_ [ patchpt ]
2inc GOTO_ [ swap w>t patch!t ] drop ;
:ASM dict-lookup ( name dict -- cp meta | name 0 )
MOV AX DS
MOV ES AX
POP BX ( dictionary )
POP DI ( name )
( strlen - in DI: str, out CX: len, clobbers AX )
XOR CX CX DEC CX ( start CX at -1 so we search until we find the 0 )
XOR AX AX ( search for 0 )
REPNZ SCASB
NEG CX DEC CX
SUB DI CX ( restore DI )
DEC CX ( ignore trailing zero )
( keeping CX + DI, find the next entry pointer and store in BX )
MOV AL @[ DI]
AND AL BUCKETMASK #
SHL AX 1 #
ADD BX AX
( save SI )
MOV DX SI
L: check-next-entry
MOV BX @[ BX]
OR BX BX
JZ 0 @>
CMP CL @[ 2 @+ BX]
JNZ check-next-entry
( we have a matching length; compare the string )
PUSH CX
PUSH DI
MOV SI BX
ADD SI 4 #
REPZ CMPSB
POP DI
POP CX
JNZ check-next-entry
( we have a matching word! return success )
MOV AX @[ 2 @+ BX] ( read flag word )
ADD BX CX ( strlen )
ADD BX 5 # ( header + null byte )
PUSH BX
PUSH AX
MOV SI DX ( restore SI )
NEXT
0 <: ( failure; we've hit a null pointer in our linked list )
PUSH DI ( push word pointer back onto the stack )
PUSH FALSE
MOV SI DX ( restore SI )
NEXT
:t lookup-current dictionary dict-lookup ;
DEFERRED lookup lookup-current
0x100 CONST F_IMMEDIATE
:t immediate latest wordflags dup @ F_IMMEDIATE | swap ! ;
: IMMEDIATE &LATEST @t cell + dup @t 0x100 | swap !t ;
0 VAR, &state
:t state &state @ ;
:t ] 1 &state ! ;
:t [ 0 &state ! ; IMMEDIATE
:t : new-word $DOCOLON , ] ;
:t ; LIT_ return , [ '>t [ ] ; IMMEDIATE
:t const new-word $DOCONST , , ;
:t var new-word $DOVAR , 0 , ;
:t cp, , ;
:t lit LIT_ LIT_ , , ;
DEFERRED compileword cp,
DEFERRED compilenum lit
:t interpretword ( cp meta -- ) F_IMMEDIATE & state not or
BZ_ [ patchpt ] execute return [ patch!t ] compileword ;
:t interpretnumber ( n -- n? ) state BZ_ [ patchpt ] compilenum [ patch!t ] ;
:t ?err ( word -- ) type LIT_ [ key ? w>t ] emit cr ;
DEFERRED err ?err
:ASM sp+ss
PUSH SP
PUSH SS
NEXT
:ASM underflow?
CMP SP 0x100 #
JLE 0 @>
MOV SP 0x100 #
PUSH TRUE
NEXT
0 <:
PUSH FALSE
NEXT
:t checkstack underflow? BZ_ [ patchpt ]
INLINEDATA_ [ patchpt t" underflow!" patch!t ] type cr [ patch!t ] ;
:t expileword ( word -- )
lookup dup BZ_ [ patchpt ] interpretword return [ patch!t ]
drop number BZ_ [ patchpt ] interpretnumber return [ patch!t ]
err ;
:t interpreter
[ target ] word dup b@ BZ_
[ patchpt ] expileword checkstack
GOTO_ [ swap w>t patch!t ] drop ;
dbg" flow control words and misc."
:t if LIT_ BZ_ , here 0 , ; IMMEDIATE
:t else LIT_ GOTO_ , 0 , here swap ! here cell - ; IMMEDIATE
:t then here swap ! ; IMMEDIATE
:t begin here ; IMMEDIATE
:t while LIT_ BZ_ , here 0 , ; IMMEDIATE
:t repeat LIT_ GOTO_ , swap , here swap ! ; IMMEDIATE
:t again LIT_ GOTO_ , , ; IMMEDIATE
:t until LIT_ BZ_ , , ; IMMEDIATE
:t ( [ target ] key LIT_ [ key ) w>t ] = BZ_ [ w>t ] ; IMMEDIATE
:t inline| LIT_ INLINEDATA_ , here 0 , ;
:t |inline then ;
:t :| inline| $DOCOLON , ; IMMEDIATE
:t |; LIT_ return , |inline ; IMMEDIATE
:t s", [ target ] key dup LIT_ [ key " w>t ] != over 0 != and
BZ_ [ patchpt ] b, GOTO_ [ swap w>t patch!t ]
drop 0 b, ;
:t s" state BZ_ [ patchpt ] inline| s", |inline return [ patch!t ]
LIT_ s", tmp-, ; IMMEDIATE
:t ' word lookup drop state BZ_ [ patchpt ] lit [ patch!t ] ; IMMEDIATE
:t loadfp ( fp -- fp )
infile @ >r
infile !
interpreter
infile @
<r infile ! ;
:t loadfile ( filename -- ) open loadfp close ;
:t defer new-word $DODEFERRED , LIT_ noop , ;
:t redefine ( cp cpdeferred ) cell + ! ;
:t definition ( cpdeferred ) cell + @ ;
:t .s sp+ss swap >r 0x100 [ target ] 2 - dup r@ < BZ_
( past top of stack ) [ patchpt ] drop drop rdrop return [ patch!t ]
2dup swap @far . GOTO_ [ w>t ] ;
:t compile-here
LIT_ cp, LIT_ compileword redefine
LIT_ lit LIT_ compilenum redefine ;
0 VAR, initscripts
:t :init initscripts @ here initscripts ! , ] ;
: :INIT [ t& initscripts lit ] dup @t swap target swap !t w>t ] compt ;
:INIT 0 inptr @ b! ; ( ensure input buffer starts empty )
:t doinit initscripts @
[ target ] dup BZ_ [ patchpt ] dup cell + >r @ GOTO_ [ swap w>t ]
[ patch!t ] drop ;
DEFERRED main interpreter
DEFERRED cleanup noop
:t tinyjort doinit main cleanup terminate ;
dbg" boot"
9 <: ( actual entry point )
MOV SI t& tinyjort #
PUSH CS
POP AX
ADD AX 4096 #
MOV SS AX
MOV SP 0x100 #
MOV t& lastseg @+ AX
MOV BP 0x00 #
CLD
NEXT
target t& &here !t
dbg" Program assembled, saving tinyjort.com"
s" tinyjort.com" overwrite
:noname >r 0x100 begin dup target < while dup b@t r@ fputc 1+ repeat drop <r ;
execute close