193 lines
4.6 KiB
Plaintext
Executable file
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
|
|
|