massive refactoring; introduce "zipoff"

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
main
Jeremy Penner 2023-09-12 23:27:46 -04:00
parent 36066a6f93
commit 6521a2127b
19 changed files with 685 additions and 522 deletions

29
asm.jrt
View File

@ -1,14 +1,4 @@
var target
0x100 target !
segalloc const tseg
: @t tseg @far ;
: b@t tseg b@far ;
: !t tseg !far ;
: b!t tseg b!far ;
: +target! ( bytes -- prevtarget ) target @ dup >rot + target ! ;
: >t 1 +target! b!t ;
: w>t 2 +target! !t ;
( REQUIRES: defs.jrt, target.jrt )
var op-encode
var lastop var lastlabel
@ -53,7 +43,7 @@ array oparg2 3 cells allot
: encode-op ( -- ) op-encode @ execute 0 op-encode ! ;
: check-encoded ( -- )
target @ >r encode-op <r target @ =
target >r encode-op <r target =
if s" invalid argument types" operror then ;
: oparg-complete!
opargs-remaining @ dup if
@ -79,18 +69,21 @@ array oparg2 3 cells allot
array patchtable 10 2 cells * allot
: find-patch ( patchid -- patch ) 2 cells * patchtable + ;
: patchpoint ( type -- ) oparg-mempatch? if
oparg-val @ find-patch swap over ! cell + target @ swap !
oparg-val @ find-patch swap over ! cell + target swap !
else drop then ;
: patch-a16 ( tptr targ -- ) swap !t ;
: patch-r16 ( tptr targ -- ) over 2 + - swap !t ;
: patch-r8 ( tptr targ -- ) over 1 + - swap b!t ;
: apply-patch ( tptr type -- ) target @ swap execute ;
: apply-patch ( tptr type -- ) target swap execute ;
: @> ( patchid -- ) 0x13 set-oparg! @] ;
: <: ( patchid -- ) find-patch dup @ swap cell + @ swap apply-patch ;
: L: here create wordname lastlabel ! target @ , does> @ @+ ;
: L: here create wordname lastlabel ! 0 , target here cell - ! does> @ @+ ;
: L@ [ ' ' , ] 2 cells + @ ;
( label redefinition - allows predefining labels when writing inline
assembly in the 'here' arena. )
: L! [ ' ' , ] 2 cells + target swap ! ;
: memreg create , does> @ oparg-base ! oparg-complete! ;
0 memreg BX+SI] 1 memreg BX+DI] 2 memreg BP+SI] 3 memreg BP+DI]
@ -204,7 +197,7 @@ var ignoreimm
oparg-val @ dup 3 = if drop 0xcc >t else 0xcd >t >t then
then ;
: diffaddr ( opsize -- diff ) oparg-val @ swap target @ + - ;
: diffaddr ( opsize -- diff ) oparg-val @ swap target + - ;
: oparg-nearaddr? ( -- f ) oparg-mem? oparg-base @ -1 = and ;
: >short-jmp* ( op -- ) oparg-nearaddr? if
2 diffaddr dup byteval? oparg-mempatch? or
@ -236,14 +229,14 @@ var ignoreimm
1 :op LOOP 0xe2 >short-jmp* ;
1 :op JCXZ 0xe3 >short-jmp* ;
1 :op JMP
farptr? if 0x05 0xff >extmem* then
0xe9 >near-reljmp*
0xeb >short-jmp*
0xea >far-jmp*
farptr? if 0x05 0xff >extmem* then
0x04 0xff >extwreg|mem* ;
1 :op CALL
0xe8 >near-reljmp*
farptr? if 0x03 0xff >extmem* then
0xe8 >near-reljmp*
0x02 0xff >extwreg|mem* ;
( four opcodes laid out next to each other:

BIN
assemble.com Executable file

Binary file not shown.

13
assemble.jrt Executable file
View File

@ -0,0 +1,13 @@
s" defs.jrt" loadfile
s" target.jrt" loadfile
s" asm.jrt" loadfile
:init segalloc ' comseg redefine ;
: writecom ( filename -- )
overwrite >r 0x100
begin dup target < while dup b@t r@ fputc 1+ repeat
drop <r close ;
: writeself overwrite >r here 0x100 - 0x100 r@ fwrite <r close ;
s" assemble.com" writeself

View File

@ -42,7 +42,7 @@ key const sp
: interpretword F_IMMEDIATE & state not or if execute else , then ;
: interpretnumber state if lit then ;
: interpretunknown type s" ?" type cr ;
: compileword lookup dup
: expileword lookup dup
if interpretword
else drop number
if interpretnumber
@ -50,7 +50,7 @@ key const sp
then
then ;
: interpreter
begin word dup b@ while compileword repeat drop ;
begin word dup b@ while expileword repeat drop ;
: loadfp ( fp -- fp )
infile @ >r
infile !
@ -66,3 +66,7 @@ key const sp
: redefine ( cp cpdeferred ) cell + ! ;
: definition ( cpdeferred ) cell + @ ;
( minijort implementations of words defined in assembly in tinyjort )
: >rot <rot <rot ;
: 2dup over over ;
: 3dup >r 2dup r@ >rot <r ;

View File

@ -1,2 +1,2 @@
jort.com < tinyjort.jrt
copy tinyjort.com jort.com
assemble.com < game.jrt

188
coredefs.jrt Executable file
View File

@ -0,0 +1,188 @@
( REQUIRED: defs.jrt, asm.jrt, target.jrt, DEF, '>t )
dbg" core"
: :ASM DEF target 2 + w>t ;
: NEXT
LODSW
MOV BX AX
JMP @[ BX] ;
L: $$CONST
INC BX INC BX
PUSH @[ BX]
NEXT
: CONST DEF [ L@ $$CONST lit ] w>t w>t ;
L@ $$CONST CONST $DOCONST
0 CONST 0 1 CONST 1
L: $$VAR
INC BX INC BX
PUSH BX
NEXT
: ARRAY DEF [ L@ $$VAR lit ] w>t ;
: VAR, ARRAY w>t ;
( "codepointer words" that evaluate to a pointer to the assembly -
useful to define things like $DOCOLON. )
: :CP ARRAY ;
L@ $$VAR CONST $DOVAR
:CP $DOCOLON
MOV @[ BP] SI
INC BP INC BP
INC BX INC BX
MOV SI BX
NEXT
:ASM return
DEC BP DEC BP
MOV SI @[ BP]
NEXT
:CP $DODEFERRED
INC BX INC BX
MOV BX @[ BX]
JMP @[ BX]
:CP $DOCREATE
MOV @[ BP] SI
INC BP INC BP
INC BX INC BX
MOV SI @[ BX]
INC BX INC BX PUSH BX
NEXT
:ASM LIT_
LODSW
PUSH AX
NEXT
:ASM noop NEXT
: DEFERRED DEF [ t& $DODEFERRED lit ] w>t [ ' '>t , ] ;
:ASM INLINEDATA_
LODSW
PUSH SI
MOV SI AX
NEXT
:ASM BZ_
POP CX
JCXZ 0 @>
LODSW
NEXT
L: GOTO_IMPL 0 <:
LODSW
MOV SI AX
NEXT
DEF GOTO_ L@ GOTO_IMPL w>t
:ASM drop
POP AX
NEXT
:ASM dup
POP AX
PUSH AX
PUSH AX
NEXT
:ASM 2dup
POP AX
POP BX
PUSH BX
PUSH AX
PUSH BX
PUSH AX
NEXT
:ASM 3dup
POP AX
POP BX
POP CX
PUSH CX
PUSH BX
PUSH AX
PUSH CX
PUSH BX
PUSH AX
NEXT
:ASM swap
POP AX
POP BX
PUSH AX
PUSH BX
NEXT
:ASM over
( this costs 1 extra byte but should save 20 clock cycles )
MOV BX SP
PUSH @[ 2 @+ SS: BX]
( POP AX
POP BX
PUSH BX
PUSH AX
PUSH BX )
NEXT
:ASM <rot
POP AX
POP BX
POP CX
PUSH BX
PUSH AX
PUSH CX
NEXT
:ASM >rot
POP AX
POP BX
POP CX
PUSH AX
PUSH CX
PUSH BX
NEXT
:ASM terminate
MOV AH 0x4c #
MOV AL 0 # ( todo: pop? )
INT 0x21 #
:ASM execute
POP BX
JMP @[ BX]
dbg" return stack"
:ASM >r
POP @[ BP]
INC BP INC BP
NEXT
:ASM <r
DEC BP DEC BP
PUSH @[ BP]
NEXT
:ASM r@
PUSH @[ -2 @+ BP]
NEXT
:ASM rdrop
DEC BP DEC BP
NEXT
:ASM rswap
MOV AX @[ -2 @+ BP]
MOV BX @[ -4 @+ BP]
MOV @[ -2 @+ BP] BX
MOV @[ -4 @+ BP] AX
NEXT

View File

@ -1,29 +1,10 @@
: >rot <rot <rot ;
: 2dup over over ;
: 3dup >r 2dup r@ >rot <r ;
: 4dup >r >r 2dup r@ >rot rswap r@ >rot <r <r swap ;
: nip swap drop ;
: 2= ( a b c d -- a=c&b=d )
>r <rot = swap <r = and ;
: 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 ;
: ~ -1 ^ ;
: f! ( b v flag -- )
>rot >r r@ @ >rot ( val flag b r: v )
if | else ~ & then <r ! ;
: f@ ( v flag -- b ) swap @ & ;
: fnot! ( v flag -- ) over @ ^ swap ! ;
: @! ( newval v -- oldval ) dup @ >rot ! ;
: expile state if , else execute then ;
: ['] word lookup drop , ; immediate
: :noname here $DOCOLON , ] ;
@ -36,46 +17,7 @@
: does> here 4 cells + lit ' finishcreate , ' return , ] ; immediate
: +towards ( from to -- from+-1 )
over > if 1 + else 1 - then ;
: for ( from to -- )
' >r , [ ' begin , ] ( from r: to )
' dup , ' r@ , ' != , [ ' while , ]
' >r , ; immediate ( r: to from )
: i ' r@ , ; immediate
: next
' <r , ' r@ , ' +towards , ( from+1 r: to )
[ ' repeat , ] ' drop , ' rdrop , ; immediate
: breakfor
' rdrop , ' rdrop , 0 lit ' >r , 1 lit ' >r , ; immediate
: yield rswap ;
: done rdrop 0 >r rswap ;
: ;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
: min ( x y -- x|y ) 2dup > if swap then drop ;
: max ( x y -- x|y ) 2dup < if swap then drop ;
: +!pos ( n var -- ) dup @ <rot + 0 max swap ! ;
: cycle! ( var lim -- )
over @ dup 0 < if drop 1 - swap !
else <= if 0 swap !
else drop then then ;
: +!cycle ( n var lim -- ) >r >r r@ +! <r <r cycle! ;
: intern create latest wordname , does> @ ;
: lazy here $DODEFERRED , ' noop , ;
: >lazy! latest codepointer swap redefine ;
: dbg" [ ' s" , ] :| type bl .s cr |; expile ; immediate
: dbg" ['] s" :| type bl .s cr |; expile ; immediate
: .hexnib ( x -- )
dup 0 >= over 9 <= and if [ key 0 lit ]

9
game.jrt Executable file
View File

@ -0,0 +1,9 @@
s" zipoff.jrt" loadfile
s" text.jrt" loadfile
key fill-page
nextline nextline nextline
t" Hello, inline assembler!" draw-text nextline
t" What a lovely day it is!" draw-text

BIN
jort.com

Binary file not shown.

190
logic.jrt Executable file
View File

@ -0,0 +1,190 @@
dbg" math"
:ASM +
POP AX POP BX
ADD AX BX
PUSH AX
NEXT
:ASM 1+
POP AX INC AX PUSH AX
NEXT
:ASM -
POP BX POP AX
SUB AX BX
PUSH AX
NEXT
:ASM 1-
POP AX DEC AX PUSH AX
NEXT
:ASM *
POP BX POP AX
IMUL BX
PUSH AX
NEXT
:ASM /mod ( n1 n2 -- quotient remainder )
POP BX POP AX
XOR DX DX
IDIV BX
PUSH AX
PUSH DX
NEXT
:t / /mod drop ;
:t % /mod swap drop ;
dbg" comparisons"
L: TRUE 0xffff w>t
L: FALSE 0 w>t
L: RETTRUE
PUSH TRUE
NEXT
L: RETFALSE
PUSH FALSE
NEXT
:ASM not
POP AX
OR AX AX
JZ RETTRUE
JMP RETFALSE
:ASM =
POP AX
POP BX
CMP AX BX
JZ RETTRUE
JMP RETFALSE
:ASM <
POP AX
POP BX
CMP BX AX
JL RETTRUE
JMP RETFALSE
:ASM >
POP AX
POP BX
CMP BX AX
JG RETTRUE
JMP RETFALSE
:ASM and
POP AX
POP BX
OR AX AX
JZ RETFALSE
OR BX BX
JZ RETFALSE
JMP RETTRUE
:ASM or
POP AX
POP BX
OR AX BX
JZ RETFALSE
JMP RETTRUE
:t != = not ;
:t <= > not ;
:t >= < not ;
dbg" bitwise"
:ASM &
POP AX
POP BX
AND AX BX
PUSH AX
NEXT
:ASM |
POP AX
POP BX
OR AX BX
PUSH AX
NEXT
:ASM ^
POP AX
POP BX
XOR AX BX
PUSH AX
NEXT
:ASM << ( val count )
POP CX
POP AX
SHL AX CL
PUSH AX
NEXT
:ASM >> ( val count )
POP CX
POP AX
SHR AX CL
PUSH AX
NEXT
dbg" mem"
:ASM @
POP BX
PUSH @[ BX]
NEXT
:ASM b@
POP BX
MOV AL @[ BX]
CBW
PUSH AX
NEXT
:ASM ub@
POP BX
MOV AL @[ BX]
XOR AH AH
PUSH AX
NEXT
:ASM @far
POP ES POP BX
PUSH @[ ES: BX]
NEXT
:ASM b@far
POP ES POP BX
MOV AL @[ ES: BX]
CBW
PUSH AX
NEXT
:ASM !
POP BX
POP @[ BX]
NEXT
:ASM b!
POP BX POP AX
MOV @[ BX] AL
NEXT
:ASM !far
POP ES POP BX
POP @[ ES: BX]
NEXT
:ASM b!far
POP ES POP BX POP AX
MOV @[ ES: BX] AL
NEXT
:ASM +!
POP BX
POP AX
ADD AX @[ BX]
MOV @[ BX] AX
NEXT

View File

@ -1,14 +0,0 @@
:t entry= ( name len entry -- f )
dup wordname swap wordlen <rot = BZ_ [ ( p1 - fail ) patchpt ]
[ ( l1 ) target @ ] over b@ dup BZ_ [ ( p2 - success ) patchpt ]
over b@ = BZ_ [ ( p3 - fail ) patchpt ]
2inc GOTO_ [ ( l1 ) <rot w>t ]
( fail ) [ patch!t swap patch!t ] drop drop 0 return
( success ) [ patch!t ] drop drop 1 ;
:t lookup ( name -- cp meta | name 0 )
dup strlen over dictbucket
[ target @ ] @ dup . dup BZ_ [ patchpt ]
3dup entry= BZ_ [ swap w>t ]
( entry found ) >rot drop drop dup codepointer swap wordflags @ return
( end of list ) [ patch!t ] drop drop 0 ;

2
reasm.bat Executable file
View File

@ -0,0 +1,2 @@
assemble.com < tinyjort.jrt
tinyjort.com < assemble.jrt

6
rebuild.bat Executable file
View File

@ -0,0 +1,6 @@
minijort.exe < tinyboot.jrt
copy tinyjort.com jort.com
jort < assemble.jrt
assemble < tinyjort.jrt
fc /b jort.com tinyjort.com

37
target.jrt Executable file
View File

@ -0,0 +1,37 @@
defer target
defer target!
defer @t
defer b@t
defer !t
defer b!t
: asm-here
' here ' target redefine
' here! ' target! redefine
' @ ' @t redefine
' b@ ' b@t redefine
' ! ' !t redefine
' b! ' b!t redefine ;
segalloc const comseg
var comaddr
0x100 comaddr !
: asm-com
:| comaddr @ |; ' target redefine
:| comaddr ! |; ' target! redefine
:| comseg @far |; ' @t redefine
:| comseg b@far |; ' b@t redefine
:| comseg !far |; ' !t redefine
:| comseg b!far |; ' b!t redefine ;
: +target! ( bytes -- prevtarget ) target dup >rot + target! ;
: >t 1 +target! b!t ;
: w>t 2 +target! !t ;
asm-com
: ALLOT ( n -- ) begin dup while 1- 0 >t repeat drop ;
: patchpt ( -- tptr ) target 0 w>t ;
: patch!t ( tptr -- ) target swap !t ;

47
text.jrt Executable file
View File

@ -0,0 +1,47 @@
0 VAR, textpage
0x0f VAR, textpen
80 const pagew
25 const pageh
0xb800 CONST TEXTMEM
: PREP-TEXTCOPY
MOV ES t& TEXTMEM @+
MOV AH textpen @+
MOV DI textpage @+ ;
:ASM fill-page ( char -- )
POP AX
PREP-TEXTCOPY
MOV CX pagew pageh * #
REPZ STOSW
NEXT
0 VAR, textpos
: textx textpos @ pagew % ;
: texty textpos @ pagew / ;
: textx! texty pagew * + textpos ! ;
: texty! pagew * textx + textpos ! ;
: nextline texty 1+ pagew * textpos ! ;
: PREP-TEXTCOPY-XY
PREP-TEXTCOPY
ADD SI textpos @+ ;
:ASM draw-text ( s -- )
MOV BX SI
POP SI
PREP-TEXTCOPY-XY
L: draw-next-char
LODSB
OR AL AL
JZ 0 @>
STOSW
JMP draw-next-char
0 <:
SUB DI textpage @+
INC DI
MOV textpos @+ DI
MOV SI BX
NEXT

8
tinyboot.jrt Executable file
View File

@ -0,0 +1,8 @@
s" defs.jrt" loadfile
dbg" loading target.jrt"
s" target.jrt" loadfile
dbg" loading asm.jrt"
s" asm.jrt" loadfile
dbg" loading tinyjort.jrt"
s" tinyjort.jrt" loadfile

Binary file not shown.

View File

@ -1,8 +1,5 @@
s" defs.jrt" loadfile
dbg" loading asm.jrt"
s" asm.jrt" loadfile
dbg" assembling..."
( tinyjort calling convention:
SP - data stack pointer, grows down
BP - return stack pointer, grows up
@ -16,11 +13,6 @@ dbg" assembling..."
JMP 9 @>
: NEXT
LODSW
MOV BX AX
JMP @[ BX] ;
( dictionary format:
DICTIONARY - an array of 16 pointers to linked lists of entries.
The dictlist for a given word is chosen by taking the
@ -34,12 +26,12 @@ JMP 9 @>
NAME - bytes ending in \0
CODE POINTER - pointer to machine code routine )
: ALLOT ( n -- ) 0 for 0 >t next ;
L: DICTIONARY 0x10 cells ALLOT
L: LATEST 0 w>t
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 )
@ -47,12 +39,10 @@ L: LATEST 0 w>t
: 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 ;
: patchpt ( -- tptr ) target @ 0 w>t ;
: patch!t ( tptr -- ) target @ swap !t ;
: link>t ( tptr-head -- ) dup @t swap patch!t w>t ;
: DEF target @ [ L@ LATEST lit ] !t
: DEF target &LATEST !t
word dup savelabel dup DICTLIST link>t dup strlen w>t str>t
( target @ cell + .hex cr ) ;
( target cell + .hex cr ) ;
: WORD= ( word len tptr -- f )
cell + dup b@t <rot != if 2drop 0 return then cell + ( word tword )
@ -66,404 +56,36 @@ L: LATEST 0 w>t
drop drop drop 0 ;
: t' word tlookup ;
: t& t' cell + ;
: :ASM DEF target @ 2 + w>t ;
dbg" core"
L: $$CONST
INC BX INC BX
PUSH @[ BX]
NEXT
: CONST DEF [ L@ $$CONST lit ] w>t w>t ;
L@ $$CONST CONST $DOCONST
L@ DICTIONARY CONST dictionary
L@ LATEST CONST &latest
0 CONST 0 1 CONST 1
L: $$VAR
INC BX INC BX
PUSH BX
NEXT
: ARRAY DEF [ L@ $$VAR lit ] w>t ;
: VAR, ARRAY w>t ;
( "codepointer words" that evaluate to a pointer to the assembly -
useful to define things like $DOCOLON. )
: :CP ARRAY ;
L@ $$VAR CONST $DOVAR
:CP $DOCOLON
MOV @[ BP] SI
INC BP INC BP
INC BX INC BX
MOV SI BX
NEXT
:ASM return
DEC BP DEC BP
MOV SI @[ BP]
NEXT
:CP $DODEFERRED
INC BX INC BX
MOV BX @[ BX]
JMP @[ BX]
:CP $DOCREATE
MOV @[ BP] SI
INC BP INC BP
INC BX INC BX
MOV SI @[ BX]
INC BX INC BX PUSH BX
NEXT
:ASM LIT_
LODSW
PUSH AX
NEXT
:ASM noop NEXT
( some helpers for making manually defining colon words less ugly )
: '>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. )
: :t DEF [ t& $DOCOLON lit ] w>t ]
: 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
compileword then
expileword then
repeat drop [ t' return lit ] w>t [ ' [ , ] ;
: :t DEF [ t& $DOCOLON lit ] w>t ] compt ;
: DEFERRED DEF [ t& $DODEFERRED lit ] w>t '>t ;
s" logic.jrt" loadfile
:ASM INLINEDATA_
LODSW
PUSH SI
MOV SI AX
NEXT
:ASM BZ_
POP CX
JCXZ 0 @>
LODSW
NEXT
L: GOTO_IMPL 0 <:
LODSW
MOV SI AX
NEXT
DEF GOTO_ L@ GOTO_IMPL w>t
:ASM drop
POP AX
NEXT
:ASM dup
POP AX
PUSH AX
PUSH AX
NEXT
:ASM 2dup
POP AX
POP BX
PUSH BX
PUSH AX
PUSH BX
PUSH AX
NEXT
:ASM 3dup
POP AX
POP BX
POP CX
PUSH CX
PUSH BX
PUSH AX
PUSH CX
PUSH BX
PUSH AX
NEXT
:ASM swap
POP AX
POP BX
PUSH AX
PUSH BX
NEXT
:ASM over
( this costs 1 extra byte but should save 20 clock cycles )
MOV BX SP
PUSH @[ 2 @+ SS: BX]
( POP AX
POP BX
PUSH BX
PUSH AX
PUSH BX )
NEXT
:ASM <rot
POP AX
POP BX
POP CX
PUSH BX
PUSH AX
PUSH CX
NEXT
:ASM >rot
POP AX
POP BX
POP CX
PUSH AX
PUSH CX
PUSH BX
NEXT
:ASM terminate
MOV AH 0x4c #
MOV AL 0 # ( todo: pop? )
INT 0x21 #
:ASM execute
POP BX
JMP @[ BX]
dbg" math"
:ASM +
POP AX POP BX
ADD AX BX
PUSH AX
NEXT
:ASM 1+
POP AX INC AX PUSH AX
NEXT
:ASM -
POP BX POP AX
SUB AX BX
PUSH AX
NEXT
:ASM 1-
POP AX DEC AX PUSH AX
NEXT
:ASM *
POP BX POP AX
IMUL BX
PUSH AX
NEXT
dbg" comparisons"
L: TRUE 0xffff w>t
L: FALSE 0 w>t
L: RETTRUE
PUSH TRUE
NEXT
L: RETFALSE
PUSH FALSE
NEXT
:ASM not
POP AX
OR AX AX
JZ RETTRUE
JMP RETFALSE
:ASM =
POP AX
POP BX
CMP AX BX
JZ RETTRUE
JMP RETFALSE
:ASM <
POP AX
POP BX
CMP BX AX
JL RETTRUE
JMP RETFALSE
:ASM >
POP AX
POP BX
CMP BX AX
JG RETTRUE
JMP RETFALSE
:ASM and
POP AX
POP BX
OR AX AX
JZ RETFALSE
OR BX BX
JZ RETFALSE
JMP RETTRUE
:ASM or
POP AX
POP BX
OR AX BX
JZ RETFALSE
JMP RETTRUE
:t != = not ;
:t <= > not ;
:t >= < not ;
dbg" bitwise"
:ASM &
POP AX
POP BX
AND AX BX
PUSH AX
NEXT
:ASM |
POP AX
POP BX
OR AX BX
PUSH AX
NEXT
:ASM ^
POP AX
POP BX
XOR AX BX
PUSH AX
NEXT
:ASM << ( val count )
POP CX
POP AX
SHL AX CL
PUSH AX
NEXT
:ASM >> ( val count )
POP CX
POP AX
SHR AX CL
PUSH AX
NEXT
dbg" mem"
:ASM @
POP BX
PUSH @[ BX]
NEXT
:ASM b@
POP BX
MOV AL @[ BX]
CBW
PUSH AX
NEXT
:ASM ub@
POP BX
MOV AL @[ BX]
XOR AH AH
PUSH AX
NEXT
:ASM @far
POP ES POP BX
PUSH @[ ES: BX]
NEXT
:ASM b@far
POP ES POP BX
MOV AL @[ ES: BX]
CBW
PUSH AX
NEXT
:ASM !
POP BX
POP @[ BX]
NEXT
:ASM b!
POP BX POP AX
MOV @[ BX] AL
NEXT
:ASM !far
POP ES POP BX
POP @[ ES: BX]
NEXT
:ASM b!far
POP ES POP BX POP AX
MOV @[ ES: BX] AL
NEXT
:ASM +!
POP BX
POP AX
ADD AX @[ BX]
MOV @[ BX] AX
NEXT
dbg" return stack"
:ASM >r
POP @[ BP]
INC BP INC BP
NEXT
:ASM <r
DEC BP DEC BP
PUSH @[ BP]
NEXT
:ASM r@
PUSH @[ -2 @+ BP]
NEXT
:ASM rdrop
DEC BP DEC BP
NEXT
:ASM rswap
MOV AX @[ -2 @+ BP]
MOV BX @[ -4 @+ BP]
MOV @[ -2 @+ BP] BX
MOV @[ -4 @+ BP] AX
NEXT
dbg" ASMEXEC"
( usage: push a CP onto the stack, then CALL ASMEXEC.
will execute the word and then return to your assembly code.
note that this will clobber AX and BX and possibly all other registers!! )
( does not work - I think LEA @> is broken
L: ASMEXEC
LEA BX 1 @> dbg" forward label?"
JMP @[ BX]
:ASM asmret
DEC BP DEC BP
MOV @[ BP] SI
RET
1 find-patch @ . 1 find-patch cell + @ .
1 <:
dbg" patched"
t& $DOCOLON w>t '>t >r '>t execute '>t <r '>t asmret
)
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 ! ;
@ -477,9 +99,11 @@ dbg" allocation"
2 CONST cell
:t cells cell * ;
:t allot here + here! ;
:t , here ! cell allot ;
:t b, here b! 1 allot ;
: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"
@ -542,7 +166,7 @@ DEFERRED emit console-emit
:t bl LIT_ [ key w>t ] emit ;
:t type
[ target @ ] dup b@ dup BZ_ [ patchpt ]
[ target ] dup b@ dup BZ_ [ patchpt ]
emit 1+ GOTO_ [ swap w>t patch!t ]
drop drop ;
@ -727,9 +351,9 @@ L: write-next-digit
:t word,
( consume leading whitespace )
0 [ target @ ] drop key dup whitespace? not BZ_ [ w>t ]
0 [ target ] drop key dup whitespace? not BZ_ [ w>t ]
( consume non-whitespace / eoi characters )
[ target @ ] dup whitespace? over eoi? or
[ 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
@ -742,7 +366,7 @@ dbg" compiler"
:t wordname 2 cells + ;
:t wordlen wordflags ub@ ;
:t codepointer dup wordname swap wordlen + ( trailing null ) 1+ ;
:t dictbucket ( word -- p ) ub@ LIT_ [ BUCKETMASK w>t ] & cells dictionary + ;
:t dictbucket ( word -- p ) ub@ BUCKETMASK & cells dictionary + ;
:t new-word
( set latest ) here latest!
( create entry ) 0 dup , ,
@ -753,7 +377,7 @@ dbg" compiler"
( 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 ]
0 swap [ target ] dup b@ BZ_ [ patchpt ]
2inc GOTO_ [ swap w>t patch!t ] drop ;
:ASM dict-lookup ( name dict -- cp meta | name 0 )
@ -810,11 +434,12 @@ L: check-next-entry
MOV SI DX ( restore SI )
NEXT
:t lookup dictionary dict-lookup ;
:t lookup-current dictionary dict-lookup ;
DEFERRED lookup lookup-current
0x100 CONST F_IMMEDIATE
:t immediate latest wordflags dup @ F_IMMEDIATE | swap ! ;
: IMMEDIATE [ L@ LATEST lit ] @t cell + dup @t 0x100 | swap !t ;
: IMMEDIATE &LATEST @t cell + dup @t 0x100 | swap !t ;
0 VAR, &state
:t state &state @ ;
@ -824,9 +449,13 @@ L: check-next-entry
: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 ] , ;
:t interpretnumber ( n -- n? ) state BZ_ [ patchpt ] LIT_ LIT_ , , [ patch!t ] ;
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
@ -847,14 +476,14 @@ DEFERRED err ?err
:t checkstack underflow? BZ_ [ patchpt ]
INLINEDATA_ [ patchpt t" underflow!" patch!t ] type cr [ patch!t ] ;
:t compileword ( word -- )
:t expileword ( word -- )
lookup dup BZ_ [ patchpt ] interpretword return [ patch!t ]
drop number BZ_ [ patchpt ] interpretnumber return [ patch!t ]
err ;
:t interpreter
[ target @ ] noop ( f28 ) word noop ( f2c ) dup b@ BZ_
[ patchpt ] noop ( f36 ) compileword checkstack
GOTO_ [ swap w>t patch!t ] noop ( f40 ) drop ;
[ 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
@ -867,8 +496,7 @@ dbg" flow control words and misc."
:t again LIT_ GOTO_ , , ; IMMEDIATE
:t until LIT_ BZ_ , , ; IMMEDIATE
:t lit LIT_ LIT_ , , ;
:t ( [ target @ ] key LIT_ [ key ) w>t ] = BZ_ [ w>t ] ; IMMEDIATE
:t ( [ target ] key LIT_ [ key ) w>t ] = BZ_ [ w>t ] ; IMMEDIATE
:t inline| LIT_ INLINEDATA_ , here 0 , ;
:t |inline then ;
@ -876,12 +504,12 @@ dbg" flow control words and misc."
:t :| inline| $DOCOLON , ; IMMEDIATE
:t |; LIT_ return , |inline ; IMMEDIATE
:t s", [ target @ ] key dup LIT_ [ key " w>t ] != over 0 != and
: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 return [ patch!t ] ; IMMEDIATE
:t ' word lookup drop state BZ_ [ patchpt ] lit [ patch!t ] ; IMMEDIATE
:t loadfp ( fp -- fp )
infile @ >r
@ -895,12 +523,26 @@ dbg" flow control words and misc."
:t redefine ( cp cpdeferred ) cell + ! ;
:t definition ( cpdeferred ) cell + @ ;
:t .s sp+ss swap >r 0x100 [ target @ ] 2 - dup r@ < BZ_
: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 ] ;
dbg" boot stub"
:t tinyjort interpreter terminate ;
: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 #
@ -913,9 +555,9 @@ dbg" boot stub"
MOV BP 0x00 #
NEXT
target @ t& &here !t
target t& &here !t
dbg" Program assembled, saving tinyjort.com"
s" tinyjort.com" overwrite
0x100 target @ :noname for i tseg b@far over fputc next ; execute
close
:noname >r 0x100 begin dup target < while dup b@t r@ fputc 1+ repeat drop <r ;
execute close

96
zipoff.jrt Executable file
View File

@ -0,0 +1,96 @@
JMP 9 @>
L: RETFAR
target cell + w>t
target cell + w>t
MOV SI @[ -2 @+ BP]
PUSH @[ -4 @+ BP]
PUSH @[ -6 @+ BP]
SUB BP 6 #
RETF
L: DOFAR
POP @[ 0 @+ BP]
POP @[ 2 @+ BP]
MOV @[ 4 @+ BP] SI
ADD BP 6 #
PUSH CS
POP DS
MOV SI L@ RETFAR #
POP BX
JMP @[ BX]
array tdict DICTSIZE allot
array &FARCALL L@ DOFAR , comseg ,
asm-here
array $DOFAR
INC BX INC BX
PUSH @[ BX]
CALL FAR &FARCALL @+
PUSH CS
POP DS
( NEXT isn't defined yet ;_; )
LODSW
MOV BX AX
JMP @[ BX]
asm-com
: te word tdict dict-lookup interpretword ; immediate
: tlookup ( -- tcp ) word tdict dict-lookup drop cell + @ ;
: t' tlookup interpretnumber ; immediate
: t& tlookup cell + interpretnumber ; immediate
: t, tlookup state if lit ' w>t , else w>t then ; immediate
: '>t tlookup w>t ;
: chained-lookup
primary-dict dict-lookup dup if return then drop tdict dict-lookup ;
: tcomp|
' lookup-current ' lookup redefine
' tdict ' dictionary redefine
:| cell + @ w>t |; ' compileword redefine
:| t, LIT_ w>t |; ' compilenum redefine ;
: |tcomp
' chained-lookup ' lookup redefine
' primary-dict ' dictionary redefine
' , ' compileword redefine
' lit ' compilenum redefine ;
|tcomp
: DEF tcomp| new-word latest wordname lastlabel ! |tcomp $DOFAR , target , ;
s" coredefs.jrt" loadfile
: :timm tcomp| new-word immediate |tcomp $DOCOLON , ] ;
:timm [[ |tcomp ['] [ ; : ]] tcomp| ] ;
:timm ; t, return |tcomp ['] [ ;
:timm ( ['] ( ;
:timm if t, BZ_ patchpt ;
:timm else t, GOTO_ patchpt swap patch!t ;
:timm then patch!t ;
:timm begin target ;
:timm while t, BZ_ patchpt ;
:timm repeat t, GOTO_ swap w>t patch!t ;
:timm again t, GOTO_ w>t ;
:timm until t, BZ_ w>t ;
:timm s" t' INLINEDATA_ w>t patchpt
begin key dup [ key " lit ] != while >t repeat drop patch!t ;
:timm :| t, INLINEDATA_ patchpt t, $DOCOLON ;
:timm |; t, return patch!t ;
: :t DEF [ t& $DOCOLON lit ] w>t ]] ;
: CREATE DEF [ t& $DOCREATE lit ] w>t 0 w>t ;
: FINISHCREATE tcomp| latest |tcomp codepointer cell + @ cell + !t ;
: DOES> target lit ' FINISHCREATE , ' return , tcomp| ; immediate
: t" target begin key dup [ key " lit ] != while >t repeat ;
s" logic.jrt" loadfile