dialer/zipoff.jrt

193 lines
4.6 KiB
Plaintext
Executable File

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 ,
:init comseg &FARCALL cell + ! ; ( comseg can change! )
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
: tdict-lookup word tdict dict-lookup ;
: T] tdict-lookup not if err return then state if , then ; immediate
: te tdict-lookup interpretword ; immediate
: tlookup ( -- tcp ) tdict-lookup not if dup err then 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 ;
: with-dict ( cp dictcp )
' dictionary definition >r
' dictionary redefine
execute
<r ' dictionary redefine ;
: DEF asm-com
:| new-word latest wordname lastlabel ! |; ' tdict with-dict
$DOFAR , target , ;
: :asm asm-here new-word here cell + , ;
s" coredefs.jrt" loadfile
( now we have LIT_ and can hook the full compiler )
: pri-targ-lookup
primary-dict dict-lookup dup if return then drop tdict dict-lookup ;
: targ-pri-lookup
( only allow lookup from primary dict if not compiling - this allows
using assembly words without duplicating them in the target dictionary )
tdict dict-lookup dup state or if return then
drop primary-dict dict-lookup ;
: { ' primary-dict ' dictionary redefine
' pri-targ-lookup ' lookup redefine
' , ' compileword redefine
' lit ' compilenum redefine ;
: } asm-com
' tdict ' dictionary redefine
' targ-pri-lookup ' lookup redefine
:| cell + @ w>t |; ' compileword redefine
:| t, LIT_ w>t |; ' compilenum redefine ;
( we mark all target words with no associated code in the target segment
as immediate, as it is impossible to compile a reference to them. )
: :timm } new-word immediate { $DOCOLON , ] ;
:timm [ ['] [ ; :timm ] ] ;
:timm ; t, return ['] [ ;
: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 ;
: t", begin key dup [ key " lit ] != while >t repeat drop 0 >t ;
: t" t, INLINEDATA_ patchpt t", patch!t ;
:timm s" state if t" else target t", then ;
: gencolon t& $DOCOLON w>t ;
: startcolon gencolon ] ;
: t:| t, INLINEDATA_ patchpt startcolon ;
: t|; t, return patch!t ;
:timm :| t:| ;
:timm |; t|; ;
:noname DEF startcolon ;
:timm : [ dup , ] ; :timm :t [ , ] ;
:timm ' ['] t' ;
:timm :noname target startcolon ;
:timm const CONST ;
:timm var, VAR, ;
:timm var 0 VAR, ;
:timm bvar, ARRAY >t ;
:timm array ARRAY ;
:timm allot ALLOT ;
:timm :asm :ASM ;
:timm , w>t ; :timm b, >t ;
:timm lit compilenum ;
:timm deferred DEFERRED ;
: :chain ( cpdeferred -- )
cell + dup @t target <rot !t startcolon w>t ;
dbg" CREATE"
: CREATE DEF t& $DOCREATE w>t 0 w>t ;
: entry>tcp codepointer cell + @ ;
: FINISHCREATE ' latest ' tdict with-dict entry>tcp cell + !t ;
: DOES} target lit ' FINISHCREATE , ' return , } ; immediate
( s" blah.jrt" loadfile doesn't work in target mode because s" writes
to the target segment. You'd have to write { s" blah.jrt" } loadfile
which kind of stinks. We provide a simple, clean alternative. )
: import word loadfile ;
} import logic.jrt
2 const cell
: cells 2* ;
: redefine ( cp cpdeferred -- ) cell + ! ; {
var comfilename
: readcom ( filename ) open >r
0x100 0xffff over r@ comseg farfread
fcount @ + target! <r close ;
DEFERRED init noop
DEFERRED main noop
DEFERRED cleanup noop
T] cleanup ' cleanup redefine
:init
( we write a fake all-null PSP so openself can fail gracefully )
0 target! 0xff ALLOT
comfilename @ readcom }
T] init ;
: writeenv ( comfile wrapper -- )
swap comfilename !
dup type cr writeself
comfilename @ dup type cr writecom ;
dbg" boot"
} : exit cleanup terminate ; : start init main exit ; {
9 <: ( actual entry point )
MOV SI t& start #
PUSH CS
POP AX
ADD AX 4096 #
MOV SS AX
MOV SP 0x100 #
MOV BP 0x00 #
NEXT
here s", zipstub.min" s" zipmin.com" writeenv
} import common.jrt {
T] init execute
here s", zipstub.seg" s" zipoff.com" writeenv