s" defs.jrt" loadfile
s" asm.jrt" loadfile

( 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 9 @>

: 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
  FLAGS - byte
  LENGTH - byte
  NAME - bytes ending in \0
  CODE POINTER - pointer to machine code routine )

L: DICTIONARY 
0 w>t 0 w>t 0 w>t 0 w>t 0 w>t 0 w>t 0 w>t 0 w>t 
0 w>t 0 w>t 0 w>t 0 w>t 0 w>t 0 w>t 0 w>t 0 w>t 
L: LATEST 0 w>t

: savelabel ( word -- )
  here swap begin dup b@ dup while b, 1 + repeat b, drop lastlabel ! ;
: DICTLIST ( word -- tptr ) b@ 0x0f & 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 ;
: link>t ( tptr-head -- ) dup @t swap target @ swap !t w>t ;
: DEF word dup savelabel dup DICTLIST link>t 0 >t dup strlen >t str>t ;

: WORD= ( word len tptr -- f ) 
  3 + dup b@t <rot != if 2drop 0 return then 1 + ( 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 ;

: t' word 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 ;

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

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

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

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
L: $$COLON
  MOV @[ BP] SI
  INC BP INC BP
  INC BX INC BX
  MOV SI BX
  NEXT

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

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

:ASM LIT_
  LODSW
  PUSH 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

L: BASE 10 w>t
:ASM number ( str -- num 1 | str 0 )
  ( AX - current number
    BX - saved IP, as SI will be clobbered by LODSB
    CX - current digit count, used to detect 0x prefix
    DX - clobbered by IMUL 
    SI - remainder of string to be parsed )
  MOV BX SI ( save IP )
  POP SI
  PUSH SI
  MOV BASE 10 #
  
  XOR AX AX
  XOR CX CX
L: next-digit
  IMUL BASE
  MOV BL AL
  LODSB
  CMP AL 0 #
  JZ 1 @> ( string end )
  CMP AL key 9 #
  JG 2 @> ( hex or fail )
  SUB AL key 0 #
  JL 0 @> ( not a number )
L: parsed-digit
  ADD BL AL
  ADC AH 0 #
  INC CX
  JMP next-digit
L: fail-digit 0 <:
  MOV SI BX
  PUSH 0 #
  NEXT
1 <: ( string end )
  JCXZ fail-digit ( empty string is not zero )
  MOV SI BX
  POP DX
  PUSH AX
  PUSH 1 #
  NEXT
2 <: ( hex or fail )
  CMP AL key x ( lowercase x )
  JNZ 0 @>
  CMP CX 1 # ( x is second character )
  JNZ 1 @>
  CMP BL 0 # ( first character was a 0 ) 
  JNZ 2 @>
  MOV BASE 16 #
  JMP next-digit
0 <: 1 <: 2 <: ( actual parsing of hex digit )
  SUB AL key A #
  JL fail-digit
  ADD AL 10 #
  CMP AL BASE
  JL parsed-digit
  SUB AL key a key A - 10 - #
  JL fail-digit
  ADD AL 10 #
  CMP AL BASE
  JL parsed-digit
  JMP fail-digit

:ASM drop
  POP AX
  NEXT

:ASM dup
  POP AX
  PUSH AX
  PUSH AX
  NEXT

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

:ASM over
  POP AX
  POP BX
  POP BX
  POP AX
  POP BX
  NEXT

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

:ASM emit
  MOV AH 5 #
  POP DX
  INT 0x21 #
  NEXT

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

( test program )
ARRAY hex65 key 0 >t key x >t key 6 >t key 5 >t 0 >t   
L: test-word L@ $$COLON w>t t' hex65 w>t t' emit w>t t' terminate w>t

9 <: ( actual entry point )
  LEA SI test-word
  ( TODO: configure stacks )
  NEXT  

.s 

s" tinyjort.com" overwrite
0x100 target @ :noname for i tseg b@far fputc next ; execute
close