SpindleyQ/dialer
1
1
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

massive refactoring; introduce "zipoff"

Browse source 
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
This commit is contained in:
Jeremy Penner 2023-09-12 23:27:46 -04:00
parent 36066a6f93
commit 6521a2127b
19 changed files with 685 additions and 522 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

8
boot.jor
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 ;

4
build.bat
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

62
defs.jrt
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
View file

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

14
lookup.jrt
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

BIN
tinyjort.com
View file

Binary file not shown.

494
tinyjort.jrt
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