s" defs.jrt" loadfile
dbg" loading asm.jrt"
s" asm.jrt" loadfile

dbg" assembling..."
( tinyjort calling convention:
  SP - data stack pointer, grows down
  BP - return stack pointer, grows up
  SI - instruction pointer
  BX - W register - code pointer for current word

  all other registers can and will be clobbered.
  DF must be cleared before calling NEXT, as LODSW is used to
  increment the instruction pointer.
)

JMP dbg" JMP" 9 @>
dbg" first jmp"
: NEXT 
  LODSW
  MOV BX AX
  JMP @[ BX] ;

( dictionary format:
  DICTIONARY - an array of 16 pointers to linked lists of entries.
               The dictlist for a given word is chosen by taking the
               first character of the word and taking its first 4
               bits.
  Entry:
  LINK - pointer to next word in the dictionary
  META - word, made up of:
    LENGTH - byte
    FLAGS - byte
  NAME - bytes ending in \0
  CODE POINTER - pointer to machine code routine )

: ALLOT ( n -- ) 0 for 0 >t next ;

L: DICTIONARY 0x10 cells ALLOT
L: LATEST 0 w>t

0x0f const BUCKETMASK

: savelabel ( word -- )
  dup type s" : " type
  here swap begin dup b@ dup while b, 1+ repeat b, drop lastlabel ! ;
: DICTLIST ( word -- tptr ) b@ BUCKETMASK & cells [ L@ DICTIONARY lit ] + ;
: strlen ( word -- len ) 0 swap begin dup b@ while swap 1+ swap 1+ repeat drop ;
: str>t ( word -- ) begin dup b@ dup while >t 1+ repeat >t drop ;
: patchpt ( -- tptr ) target @ 0 w>t ;
: patch!t ( tptr -- ) target @ swap !t ;
: link>t ( tptr-head -- ) dup @t swap patch!t w>t ;
: DEF target @ [ L@ LATEST lit ] !t
      word dup savelabel dup DICTLIST link>t dup strlen w>t str>t
      target @ cell + .hex cr ;

: WORD= ( word len tptr -- f ) 
  cell + dup b@t <rot != if 2drop 0 return then cell + ( word tword )
  begin over b@ over b@t = while
    over b@ not if 2drop 1 return then ( 0 byte, matched )
    1+ swap 1+ swap
  repeat 2drop 0 ;
: tlookup ( word -- tcp )
  dup strlen over DICTLIST ( word len tptr-next-entry )
  begin dup while 3dup WORD= if 5 + + swap drop return then @t repeat
  drop drop drop 0 ;
: t' word tlookup ;
: t& t' cell + ;

: :ASM DEF target @ 2 + w>t ;

dbg" core"

L: $$CONST
  INC BX INC BX
  PUSH @[ BX]
  NEXT

: CONST DEF [ L@ $$CONST lit ] w>t w>t ;

L@ $$CONST CONST $DOCONST
L@ DICTIONARY CONST dictionary
L@ LATEST CONST &latest

L: $$VAR
  INC BX INC BX
  PUSH BX
  NEXT

: ARRAY DEF [ L@ $$VAR lit ] w>t ;
: VAR, ARRAY w>t ;

( "codepointer words" that evaluate to a pointer to the assembly -
  useful to define things like $DOCOLON. )
: :CP ARRAY ;
L@ $$VAR CONST $DOVAR

:CP $DOCOLON
  MOV @[ BP] SI
  INC BP INC BP
  INC BX INC BX
  MOV SI BX
  NEXT

:ASM return
  DEC BP DEC BP
  MOV SI @[ BP]
  NEXT

:CP $DODEFERRED
  INC BX INC BX
  MOV BX @[ BX]
  JMP @[ BX]

:CP $DOCREATE
  MOV @[ BP] SI
  INC BP INC BP
  INC BX INC BX
  MOV SI BX
  INC BX INC BX PUSH BX
  NEXT

:ASM LIT_
  LODSW
  PUSH AX
  NEXT

( some helpers for making manually defining colon words less ugly )
: '>t t' w>t ;

: stch? ( str -- f ) ' @ , key lit ' = , ; immediate
( DOES NOT SUPPORT ARBITRARY IMMEDIATE WORDS.
  Supports [], comments, ; and numeric literals ONLY. 
  You must use [ for anything fancy. )
: :t DEF [ t& $DOCOLON lit ] w>t ]
  begin word dup stch? ; not while
    state if dup stch? [ if drop [ ' [ , ] else 
             dup stch? ( if drop [ ' ( , ] else
             dup tlookup dup if w>t drop else drop
             number if [ t' LIT_ lit ] w>t w>t else
             type s" ?" type cr then then then then else
          compileword then
  repeat drop [ t' return lit ] w>t [ ' [ , ] ;

: DEFERRED DEF [ t& $DODEFERRED lit ] w>t '>t ;

:ASM INLINEDATA_
  LODSW
  PUSH SI
  MOV SI AX
  NEXT

:ASM BZ_
  POP CX
  JCXZ 0 @>
  LODSW
  NEXT
L: GOTO_IMPL 0 <:
  LODSW
  MOV SI AX
  NEXT

DEF GOTO_ L@ GOTO_IMPL w>t

:ASM drop
  POP AX
  NEXT

:ASM dup
  POP AX
  PUSH AX
  PUSH AX
  NEXT

:ASM 2dup
  POP AX
  POP BX
  PUSH BX
  PUSH AX
  PUSH BX
  PUSH AX
  NEXT

:ASM 3dup
  POP AX
  POP BX
  POP CX
  PUSH CX
  PUSH BX
  PUSH AX
  PUSH CX
  PUSH BX
  PUSH AX
  NEXT

:ASM swap
  POP AX
  POP BX
  PUSH AX
  PUSH BX
  NEXT

:ASM over
  ( this costs 1 extra byte but should save 20 clock cycles )
  MOV BX SP
  PUSH @[ 2 @+ SS: BX]
(  POP AX
  POP BX
  PUSH BX
  PUSH AX
  PUSH BX )
  NEXT

:ASM <rot
  POP AX
  POP BX
  POP CX
  PUSH BX
  PUSH AX
  PUSH CX
  NEXT

:ASM >rot
  POP AX
  POP BX
  POP CX
  PUSH AX
  PUSH CX
  PUSH BX
  NEXT

:ASM terminate
  MOV AH 0x4c #
  MOV AL 0 # ( todo: pop? )
  INT 0x21 #

:ASM execute
  POP BX
  JMP @[ BX]

dbg" math"
:ASM +
  POP AX POP BX 
  ADD AX BX
  PUSH AX
  NEXT

:ASM 1+
  POP AX INC AX PUSH AX
  NEXT

:ASM -
  POP BX POP AX 
  SUB AX BX
  PUSH AX
  NEXT

:ASM 1-
  POP AX DEC AX PUSH AX
  NEXT

:ASM *
  POP BX POP AX 
  IMUL BX
  PUSH AX
  NEXT

dbg" comparisons"
L: TRUE 0xffff w>t
L: FALSE 0 w>t
L: RETTRUE
  PUSH TRUE
  NEXT
L: RETFALSE
  PUSH FALSE
  NEXT

:ASM not
  POP AX
  OR AX AX
  JZ RETTRUE
  JMP RETFALSE

:ASM =
  POP AX
  POP BX
  CMP AX BX
  JZ RETTRUE
  JMP RETFALSE

:ASM <
  POP AX
  POP BX
  CMP BX AX
  JL RETTRUE
  JMP RETFALSE

:ASM >
  POP AX
  POP BX
  CMP BX AX
  JG RETTRUE
  JMP RETFALSE

:ASM and
  POP AX
  POP BX
  OR AX AX
  JZ RETFALSE
  OR BX BX
  JZ RETFALSE
  JMP RETTRUE

:ASM or
  POP AX
  POP BX
  OR AX BX
  JZ RETFALSE
  JMP RETTRUE

:t != = not ;
:t <= > not ;
:t >= < not ;

dbg" bitwise"
:ASM &
  POP AX
  POP BX
  AND AX BX
  PUSH AX
  NEXT

:ASM |
  POP AX
  POP BX
  OR AX BX
  PUSH AX
  NEXT

:ASM ^
  POP AX
  POP BX
  XOR AX BX
  PUSH AX
  NEXT

:ASM << ( val count )
  POP CX
  POP AX
  SHL AX CL
  PUSH AX
  NEXT

:ASM >> ( val count )
  POP CX
  POP AX
  SHR AX CL
  PUSH AX
  NEXT

dbg" mem"
:ASM @
  POP BX
  PUSH @[ BX]
  NEXT

:ASM b@
  POP BX
  MOV AL @[ BX]
  CBW
  PUSH AX
  NEXT

:ASM ub@
  POP BX
  MOV AL @[ BX]
  XOR AH AH
  PUSH AX
  NEXT

:ASM @far
  POP ES POP BX
  PUSH @[ ES: BX]
  NEXT

:ASM b@far
  POP ES POP BX
  MOV AL @[ ES: BX]
  CBW
  PUSH AX
  NEXT

:ASM !
  POP BX
  POP @[ BX]
  NEXT

:ASM b!
  POP BX POP AX
  MOV @[ BX] AL
  NEXT

:ASM !far
  POP ES POP BX
  POP @[ ES: BX]
  NEXT

:ASM b!far
  POP ES POP BX POP AX
  MOV @[ ES: BX] AL
  NEXT

:ASM +!
  POP BX
  POP AX
  ADD AX @[ BX]
  MOV @[ BX] AX
  NEXT

dbg" return stack"
:ASM >r
  POP @[ BP]
  INC BP INC BP
  NEXT

:ASM <r
  DEC BP DEC BP
  PUSH @[ BP]
  NEXT

:ASM r@
  PUSH @[ -2 @+ BP]
  NEXT

:ASM rdrop
  DEC BP DEC BP
  NEXT

:ASM rswap
  MOV AX @[ -2 @+ BP]
  MOV BX @[ -4 @+ BP]
  MOV @[ -2 @+ BP] BX
  MOV @[ -4 @+ BP] AX
  NEXT

dbg" ASMEXEC"
( usage: push a CP onto the stack, then CALL ASMEXEC.
  will execute the word and then return to your assembly code. 
  note that this will clobber AX and BX and possibly all other registers!! )
( does not work - I think LEA @> is broken
L: ASMEXEC
  LEA BX 1 @> dbg" forward label?"
  JMP @[ BX]
:ASM asmret
  DEC BP DEC BP
  MOV @[ BP] SI
  RET
1 find-patch @ . 1 find-patch cell + @ .
1 <:
dbg" patched"  
  t& $DOCOLON w>t '>t >r '>t execute '>t <r '>t asmret
)
dbg" allocation"
0 VAR, &here
:t here &here @ ;
:t here! &here ! ;
0xffff CONST there

:t latest &latest @ ;
:t latest! &latest ! ;

0 VAR, lastseg
:t segalloc lastseg @ 4096 + dup lastseg ! ;

2 CONST cell
:t cells cell * ;
:t allot here + here! ;
:t , here ! cell allot ;
:t b, here b! 1 allot ;
: t" begin key dup [ key " lit ] != while >t repeat drop 0 >t ;

dbg" i/o"
:ASM overwrite
  MOV AH 0x3c #
  XOR CX CX ( non-system, non-hidden )
  POP DX ( filename ptr )
  INT 0x21 #
  PUSH AX
  NEXT

:ASM open
  MOV AH 0x3d #
  MOV AL 2 # ( read/write access, allow child inheritance )
  POP DX ( filename ptr )
  INT 0x21 #
  PUSH AX
  NEXT

:ASM close
  MOV AH 0x3e #
  POP BX
  INT 0x21 #
  NEXT

0 VAR, fcount
:ASM fread
  MOV AH 0x3f #
  POP BX ( fp )
  POP DX ( buffer )
  POP CX ( length )
  INT 0x21 #
  MOV t& fcount @+ AX ( save number of bytes read )
  NEXT

:ASM fwrite
  MOV AH 0x40 #
  POP BX ( fp )
  POP DX ( buffer )
  POP CX ( length )
  INT 0x21 #
  MOV t& fcount @+ AX ( save number of bytes written )
  NEXT

-1 CONST EOF
0 VAR, fbuffer
: skip>t 1+ cells target @ + w>t ;
:t fgetc ( fp -- c )
  1 fbuffer <rot fread fbuffer ub@
  fcount @ not BZ_ [ 2 skip>t ] drop EOF ;
:t fputc ( c fp -- ) swap fbuffer b! 1 fbuffer <rot fwrite ;

:ASM console-emit
  MOV AH 2 #
  POP DX
  INT 0x21 #
  NEXT
DEFERRED emit console-emit

:t cr 10 emit 13 emit ;
:t bl LIT_ [ key  w>t ] emit ;

:t type 
   [ target @ ] dup b@ dup BZ_ [ patchpt ] 
   emit 1+ GOTO_ [ swap w>t patch!t ]
   drop drop ;

:ASM console-key
  MOV AH 8 #
  INT 0x21 #
  XOR AH AH
  PUSH AX
  NEXT

127 const INBUFSIZE
INBUFSIZE CONST INBUFSIZE
ARRAY inbuf INBUFSIZE 1+ ALLOT
t& inbuf VAR, inptr
:t buf-key inptr @ b@ dup BZ_ [ patchpt ] inptr @ 1+ inptr ! [ patch!t ] ;

0 VAR, infile ( 0 is a predefined file handle meaning stdin )
:t stdin-key 
   buf-key dup BZ_ [ 1 skip>t ] return drop
   ( if buffer is empty, refresh from file )
   INBUFSIZE inbuf 0 fread
   ( if there's any more data, start returning it )
   fcount @ dup BZ_ [ patchpt ] inbuf + 0 swap b! inbuf inptr ! buf-key return
   ( otherwise, EOF ) [ patch!t ] drop EOF ;
:t file-key infile @ dup BZ_ [ patchpt ] fgetc return 
   [ patch!t ] drop stdin-key ;
DEFERRED key file-key

dbg" parsing"
L: BASE 10 w>t L: ISNEG? 0 >t
:ASM number ( str -- num 1 | str 0 )
  ( AX - current number
    BH - 0
    BL - current character
    CX - current digit count, used to detect 0x prefix
    DX - clobbered by IMUL
    SI - remainder of string to be parsed
    DI - saved IP, as SI will be clobbered by LODSB )
  MOV DI SI ( save IP )
  POP SI
  PUSH SI
  MOV BASE 10 #
  
  XOR AX AX
  XOR BX BX
  XOR CX CX
  MOV BYTE ISNEG? AL
L: next-digit
  MOV BL AL
  LODSB
  XCHG AL BL
  OR BL BL
  JZ 1 @> ( string end )
  JCXZ 3 @> ( starts with negative? )
L: parse-digit
  CMP BL key 9 #
  JG 2 @> ( hex or fail )
  SUB BL key 0 #
  JL 0 @> ( not a number )
L: parsed-digit
  IMUL BASE
  ADD AX BX
  INC CX
  JMP next-digit
L: fail-digit 0 <:
  MOV SI DI
  XOR CX CX
  PUSH CX
  NEXT
1 <: ( string end )
  JCXZ fail-digit ( empty string is not zero )
  CMP BYTE ISNEG? 0 #
  JZ 1 @>
  NEG AX
1 <:
  MOV SI DI
  POP DX
  PUSH AX
  PUSH CX ( we know cx is nonzero and will be treated as true )
  NEXT
3 <: ( negative? )
  CMP BL key - #  
  JNZ parse-digit
  CMP BYTE ISNEG? 0 #
  JNZ fail-digit ( only one negative sign allowed )
  MOV BYTE ISNEG? BL ( any nonzero value will do )
  JMP next-digit
2 <: ( hex or fail )
  CMP BL key x # ( lowercase x )
  JNZ 0 @>
  CMP CX 1 # ( x is second character )
  JNZ 1 @>
  OR AX AX ( first character was a 0 ) 
  JNZ 2 @>
  MOV BASE 16 #
  JMP next-digit
0 <: 1 <: 2 <: ( actual parsing of hex digit )
  SUB BL key A #
  JL fail-digit
  ADD BL 10 #
  CMP BL BASE
  JL parsed-digit
  SUB BL key a key A - 10 + #
  JL fail-digit
  ADD BL 10 #
  CMP BL BASE
  JL parsed-digit
  JMP fail-digit

L: DECDIVISORS 1 w>t 10 w>t 100 w>t 1000 w>t 10000 w>t
L: NUMBUF 7 ALLOT ( 5 digits, - sign, ending null )
:ASM num>str
  MOV AX DS
  MOV ES AX
  MOV DI L@ NUMBUF #
  POP AX
  OR AX AX
  JGE 0 @>
  MOV BYTE @[ DI] key - #
  NEG AX
  INC DI
0 <:
  PUSH SI
  MOV SI 4 cells #
  MOV BX L@ DECDIVISORS #
  MOV CX 4 # ( CX=0 when we should write zeros )
L: write-next-digit
  XOR DX DX
  IDIV @[ BX+SI]
  OR AX AX
  JNZ 1 @>
  JCXZ 0 @> ( unconditionally write a zero )
  DEC CX ( if we haven't written any digits this will hit 0 on the ones place )
  JMP 2 @>
1 <: 0 <:
  XOR CX CX ( we've started outputting digits - set CX to 0 )
  ADD AX key 0 #
  STOSB
2 <:
  MOV AX DX
  DEC SI
  DEC SI
  JNS write-next-digit ( once SI decrements below zero the sign bit will set )
  XOR AX AX
  STOSB ( trailing 0 )
  POP SI
  MOV DI L@ NUMBUF #
  PUSH DI
  NEXT

:t . num>str type bl ;

:ASM whitespace?
  POP AX
  CMP AX key  #
  JZ 0 @>
  CMP AX 13 # ( newline )
  JZ 1 @>
  CMP AX 10 # ( linefeed )
  JZ 2 @>
  CMP AX 9 # ( tab )
  JNZ 3 @>
0 <: 1 <: 2 <:
  PUSH TRUE
  NEXT
3 <:
  PUSH FALSE
  NEXT

:ASM eoi? ( end of input )
  POP AX
  OR AX AX ( null )
  JZ 0 @>
  CMP AX -1 # ( EOF )
  JNZ 1 @>
0 <:
  PUSH TRUE
  NEXT
1 <:
  PUSH FALSE
  NEXT

:t word,
  ( consume leading whitespace )
  0 [ target @ ] drop key dup whitespace? not BZ_ [ w>t ]
  ( consume non-whitespace / eoi characters )
  [ target @ ] dup whitespace? over eoi? or
  ( if whitespace or eoi, end ) BZ_ [ 5 skip>t ] drop 0 b, return
  ( otherwise, write byte and continue ) b, key GOTO_ [ w>t ] ;
ARRAY wordbuf 48 ALLOT
:t redir-, ( cp buf -- buf ) here >r dup >r here! execute <r <r here! ;
:t tmp-, ( cp -- buf ) here redir-, ;
:t word LIT_ word, wordbuf redir-, ;

dbg" compiler"
:t wordflags cell + ;
:t wordname 2 cells + ;
:t wordlen wordflags ub@ ;
:t codepointer dup wordname swap wordlen + ( trailing null ) 1+ ;
:t dictbucket ( word -- p ) ub@ LIT_ [ BUCKETMASK w>t ] & cells dictionary + ;
:t new-word
   ( set latest ) here latest!
   ( create entry ) 0 dup , ,
   ( save word + calc length ) here word, here swap - 1- ( ignore null )
   ( save length ) latest wordflags !
   ( find bucket ) latest wordname dictbucket
   ( link to prev ) dup @ latest !
   ( link bucket to new ) latest swap ! ;
:t 2inc ( x y -- x+1 y+1 ) 1+ swap 1+ swap ;
:t strlen ( name -- len )
   0 swap [ target @ ] dup b@ BZ_ [ 3 skip>t ]
   2inc GOTO_ [ w>t ] drop ;

:ASM dict-lookup ( name dict -- cp meta | name 0 )
  MOV AX DS
  MOV ES AX
  POP BX ( dictionary )
  POP DI ( name )
  ( strlen - in DI: str, out CX: len, clobbers AX )
  XOR CX CX DEC CX ( start CX at -1 so we search until we find the 0 )
  XOR AX AX ( search for 0 )
  REPNZ SCASB
  NEG CX DEC CX 
  SUB DI CX ( restore DI )
  DEC CX ( ignore trailing zero )

  ( keeping CX + DI, find the next entry pointer and store in BX )
  MOV AL @[ DI]
  AND AL BUCKETMASK #
  SHL AX 1 #
  ADD BX AX

  ( save SI )
  MOV DX SI

L: check-next-entry
  MOV BX @[ BX]
  OR BX BX
  JZ 0 @>
  CMP CL @[ 2 @+ BX]
  JNZ check-next-entry
  
  ( we have a matching length; compare the string )
  PUSH CX
  PUSH DI
  MOV SI BX
  ADD SI 4 #
  REPZ CMPSB
  POP DI
  POP CX
  JNZ check-next-entry

  ( we have a matching word! return success )
  MOV AX @[ 2 @+ BX] ( read flag word )
  ADD BX CX ( strlen )
  ADD BX 5 # ( header + null byte )
  PUSH BX
  PUSH AX
  MOV SI DX ( restore SI )
  NEXT

0 <: ( failure; we've hit a null pointer in our linked list )
  PUSH DI ( push word pointer back onto the stack )
  PUSH FALSE
  MOV SI DX ( restore SI )
  NEXT

:t lookup dictionary dict-lookup ;

0x100 CONST F_IMMEDIATE
:t immediate latest wordflags dup @ F_IMMEDIATE | swap ! ;
: IMMEDIATE [ L@ LATEST lit ] @t cell + dup @t 0x100 | swap !t ;

0 VAR, &state
:t state &state @ ;
:t ] 1 &state ! ;
:t [ 0 &state ! ; IMMEDIATE
:t : new-word $DOCOLON , ] ;
:t ; LIT_ return , [ '>t [ ] ; IMMEDIATE
:t const new-word $DOCONST , , ;
:t var new-word $DOVAR , 0 , ;
:t interpretword ( cp meta -- ) F_IMMEDIATE & state not or
   BZ_ [ patchpt ] execute return [ patch!t ] , ;
:t interpretnumber ( n -- n? ) state BZ_ [ patchpt ] LIT_ LIT_ , , [ patch!t ] ;
:t ?err ( word -- ) type LIT_ [ key ? w>t ] emit cr ;

DEFERRED err ?err
:t compileword ( word -- )
  lookup dup BZ_ [ patchpt ] interpretword return [ patch!t ] 
  drop number BZ_ [ patchpt ] interpretnumber return [ patch!t ]
  err ;
:t interpreter 
  [ target @ ] word dup b@ BZ_ [ patchpt ] compileword GOTO_ [ swap w>t ]
  [ patch!t ] drop ;

dbg" flow control words and misc."
:t if LIT_ BZ_ , here 0 , ; IMMEDIATE
:t else LIT_ GOTO_ , 0 , here swap ! here cell - ; IMMEDIATE
:t then here swap ! ; IMMEDIATE

:t begin here ; IMMEDIATE
:t while LIT_ BZ_ , here 0 , ; IMMEDIATE
:t repeat LIT_ GOTO_ , swap , here swap ! ; IMMEDIATE
:t again LIT_ GOTO_ , , ; IMMEDIATE
:t until LIT_ BZ_ , , ; IMMEDIATE

:t lit LIT_ LIT_ , , ;
:t ( [ target @ ] key LIT_ [ key ) w>t ] = BZ_ [ w>t ] ; IMMEDIATE

:t inline| LIT_ INLINEDATA_ , here 0 , ;
:t |inline then ;

:t :| inline| $DOCOLON , ; IMMEDIATE
:t |; LIT_ return , |inline ; IMMEDIATE

:t s", [ target @ ] key dup LIT_ [ key " w>t ] != over 0 != and
       BZ_ [ 3 skip>t ] b, GOTO_ [ w>t ]
       drop 0 b, ;
:t s" state BZ_ [ patchpt ] inline| s", |inline return [ patch!t ]
    LIT_ s", tmp-, ; IMMEDIATE
:t ' word lookup drop state BZ_ [ patchpt ] lit return [ patch!t ] ; IMMEDIATE

:t loadfp ( fp -- fp )
  infile @ >r
  infile !
  interpreter
  infile @
  <r infile ! ;
:t loadfile ( filename -- ) open loadfp close ;

:t noop ;
:t defer new-word $DODEFERRED , LIT_ noop , ;
:t redefine ( cp cpdeferred ) cell + ! ;
:t definition ( cpdeferred ) cell + @ ;

:ASM sp+ss
  PUSH SP
  PUSH SS
  NEXT

:t .s sp+ss swap >r 0x100 [ target @ ] 2 - dup r@ < BZ_ 
      ( past top of stack ) [ 4 skip>t ] drop drop rdrop return
      2dup swap @far . GOTO_ [ w>t ] ;

dbg" boot stub"
:ASM debug NEXT
:t tinyjort interpreter terminate ;

9 <: ( actual entry point )
  MOV SI t& tinyjort #
  PUSH CS
  POP AX
  ADD AX 4096 #
  MOV SS AX
  MOV t& lastseg @+ AX
  MOV SP 0x100 #
  MOV BP 0x00 #
  NEXT

target @ t& &here !t

dbg" Program assembled, saving tinyjort.com" 
s" tinyjort.com" overwrite
0x100 target @ :noname for i tseg b@far over fputc next ; execute
close