Jeremy Penner
6521a2127b
assemble.jrt for creating assemble.com which has asm.jrt preloaded rebuild.bat for re-bootstrapping tinyjort from scratch and verifying that minijort and assemble produce the same binary small CGA textmode vocabulary with test program
564 lines
14 KiB
Plaintext
Executable file
564 lines
14 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 cell * ;
|
|
: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"
|
|
:ASM overwrite
|
|
MOV AH 0x3c #
|
|
XOR CX CX ( non-system, non-hidden )
|
|
POP DX ( filename ptr )
|
|
INT 0x21 #
|
|
PUSH AX
|
|
NEXT
|
|
|
|
:ASM open
|
|
MOV AH 0x3d #
|
|
MOV AL 2 # ( read/write access, allow child inheritance )
|
|
POP DX ( filename ptr )
|
|
INT 0x21 #
|
|
PUSH AX
|
|
NEXT
|
|
|
|
:ASM close
|
|
MOV AH 0x3e #
|
|
POP BX
|
|
INT 0x21 #
|
|
NEXT
|
|
|
|
0 VAR, fcount
|
|
:ASM fread
|
|
MOV AH 0x3f #
|
|
POP BX ( fp )
|
|
POP DX ( buffer )
|
|
POP CX ( length )
|
|
INT 0x21 #
|
|
MOV t& fcount @+ AX ( save number of bytes read )
|
|
NEXT
|
|
|
|
:ASM fwrite
|
|
MOV AH 0x40 #
|
|
POP BX ( fp )
|
|
POP DX ( buffer )
|
|
POP CX ( length )
|
|
INT 0x21 #
|
|
MOV t& fcount @+ AX ( save number of bytes written )
|
|
NEXT
|
|
|
|
-1 CONST EOF
|
|
0 VAR, fbuffer
|
|
:t fgetc ( fp -- c )
|
|
1 fbuffer <rot fread fbuffer ub@
|
|
fcount @ not BZ_ [ patchpt ] drop EOF [ patch!t ] ;
|
|
:t fputc ( c fp -- ) swap fbuffer b! 1 fbuffer <rot fwrite ;
|
|
|
|
: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 ;
|
|
|
|
:t doinit initscripts @
|
|
[ target ] dup BZ_ [ patchpt ] dup cell + >r @ GOTO_ [ swap w>t ]
|
|
[ patch!t ] drop ;
|
|
|
|
DEFERRED main interpreter
|
|
:t tinyjort doinit main terminate ;
|
|
|
|
dbg" boot"
|
|
|
|
9 <: ( actual entry point )
|
|
MOV SI t& tinyjort #
|
|
PUSH CS
|
|
POP AX
|
|
ADD AX 4096 #
|
|
MOV SS AX
|
|
MOV t& lastseg @+ AX
|
|
MOV SP 0x100 #
|
|
MOV BP 0x00 #
|
|
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
|