dialer/zipoff.jrt

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