154 lines
3.7 KiB
Plaintext
Executable file
154 lines
3.7 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
|
|
|
|
: te word tdict dict-lookup interpretword ; immediate
|
|
: tlookup ( -- tcp ) word tdict dict-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 ;
|
|
|
|
: tdict| ' tdict ' dictionary redefine ;
|
|
: |tdict ' primary-dict ' dictionary redefine ;
|
|
|
|
: DEF asm-com ' dictionary definition ( preserve the current dictionary )
|
|
tdict| new-word latest wordname lastlabel ! |tdict $DOFAR , target ,
|
|
' dictionary redefine ;
|
|
: :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 ;
|
|
|
|
: { tdict| asm-com
|
|
' targ-pri-lookup ' lookup redefine
|
|
:| cell + @ w>t |; ' compileword redefine
|
|
:| t, LIT_ w>t |; ' compilenum redefine ;
|
|
|
|
: } |tdict asm-here
|
|
' pri-targ-lookup ' lookup redefine
|
|
' , ' compileword redefine
|
|
' lit ' compilenum redefine ;
|
|
|
|
: >{ dictionary tdict = { ;
|
|
: }< if { else } then ;
|
|
|
|
( 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 } } ;
|
|
: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 ;
|
|
|
|
:timm s" t, INLINEDATA_ patchpt
|
|
begin key dup [ key " lit ] != while >t repeat drop 0 >t patch!t ;
|
|
|
|
:timm :| t, INLINEDATA_ patchpt t& $DOCOLON w>t ;
|
|
:timm |; t, return patch!t ;
|
|
|
|
: :t DEF t& $DOCOLON w>t ] { ;
|
|
:timm : :t ;
|
|
:timm ' ['] t' ;
|
|
:timm :noname target t& $DOCOLON w>t ] ;
|
|
:timm const CONST ;
|
|
:timm var, VAR, ;
|
|
:timm var 0 VAR, ;
|
|
:timm array ARRAY ;
|
|
:timm allot ALLOT ;
|
|
:timm :asm :ASM ;
|
|
:timm , w>t ; :timm b, >t ;
|
|
:timm lit compilenum ;
|
|
|
|
: CREATE DEF t& $DOCREATE w>t 0 w>t ;
|
|
: FINISHCREATE { latest } codepointer cell + @ cell + !t ;
|
|
: DOES> target lit ' FINISHCREATE , ' return , { ; immediate
|
|
|
|
: import >{ >r word loadfile <r }< ;
|
|
|
|
import logic.jrt
|
|
|
|
var comfilename
|
|
|
|
: readcom ( filename ) open 0x100 target!
|
|
begin dup fgetc dup EOF != while >t repeat drop close ;
|
|
|
|
:init comfilename @ readcom { ;
|
|
|
|
: writeenv ( comfile wrapper -- )
|
|
swap comfilename !
|
|
dup type cr writeself
|
|
comfilename @ dup type cr writecom ;
|
|
|
|
DEFERRED main terminate
|
|
|
|
dbg" boot"
|
|
|
|
9 <: ( actual entry point )
|
|
MOV SI t& main #
|
|
PUSH CS
|
|
POP AX
|
|
ADD AX 4096 #
|
|
MOV SS AX
|
|
MOV SP 0x100 #
|
|
MOV BP 0x00 #
|
|
NEXT
|
|
|
|
here s", zipstub.seg" s" zipoff.com" writeenv
|
|
|