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

: 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