dialer/tinyjort.jrt

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 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 ;
: t& t' cell + ;

: :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
  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

( some helpers for making manually defining colon words slightly less ugly )
: '>t t' w>t ;
: @>t t& @t w>t ;
: :t DEF [ t& $DOCOLON lit ] w>t ;

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

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

:ASM LIT_
  LODSW
  PUSH AX
  NEXT

: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

L: BASE 10 w>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
L: next-digit
  MOV BL AL
  LODSB
  XCHG AL BL
  CMP BL 0 #
  JZ 1 @> ( string end )
  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 )
  MOV SI DI
  POP DX
  PUSH AX
  PUSH CX ( we know cx is nonzero and will be treated as true )
  NEXT
2 <: ( hex or fail )
  CMP BL key x # ( lowercase x )
  JNZ 0 @>
  CMP CX 1 # ( x is second character )
  JNZ 1 @>
  CMP AX 0 # ( 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

: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 terminate
  MOV AH 0x4c #
  MOV AL 0 # ( todo: pop )
  INT 0x21 #

:ASM execute
  POP BX
  JMP @[ BX]

:ASM +
  POP AX POP BX 
  ADD AX BX
  PUSH AX
  NEXT

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

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

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

:ASM not
  POP AX
  CMP AX FALSE
  JZ RETTRUE
  JMP RETFALSE

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

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

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

:ASM and
  POP AX
  POP BX
  CMP AX FALSE
  JZ RETFALSE
  CMP BX FALSE
  JZ RETFALSE
  JMP RETTRUE

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

:t != '>t = '>t not '>t return
:t <= '>t > '>t not '>t return
:t >= '>t < '>t not '>t return

: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 >>
  POP CX
  POP AX
  SHR AX CL
  PUSH AX
  NEXT

:ASM @
  POP BX
  MOV AX @[ BX]
  PUSH AX
  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
  MOV AX @[ ES: BX]
  PUSH AX
  NEXT

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

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

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

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

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

:ASM >r
  POP AX
  MOV @[ BP] AX
  INC BP INC BP
  NEXT

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

:ASM r@
  MOV AX @[ -2 @+ BP]
  PUSH AX
  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

0 VAR, &here
:t here '>t &here '>t @ '>t return
:t here! '>t &here '>t ! '>t return
0xffff CONST there

:t latest '>t &latest '>t @ '>t return
:t latest! '>t &latest '>t ! '>t return

0 VAR, lastseg
:t segalloc '>t lastseg '>t @ '>t LIT_ 4096 w>t '>t + 
   '>t dup '>t lastseg '>t ! '>t return

2 CONST cell
:t allot '>t here '>t + '>t here! '>t return
:t , '>t here '>t ! '>t cell '>t allot '>t return
:t b, '>t here '>t b! '>t LIT_ 1 w>t '>t allot '>t return

: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
:t fgetc '>t LIT_ 1 w>t '>t fbuffer '>t <rot '>t fread
   '>t fbuffer '>t ub@
   '>t fcount '>t @ '>t not '>t BZ_ target @ 3 cells + w>t
   '>t drop '>t EOF '>t return
:t fputc '>t swap '>t fbuffer '>t b!
   '>t LIT_ 1 w>t '>t fbuffer '>t <rot '>t fwrite '>t return

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

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

0 VAR, infile ( 0 is a predefined file handle meaning stdin )
:t in-key '>t infile '>t @ '>t dup '>t BZ_ target @ 4 cells + w>t
   '>t drop '>t console-key '>t return
   '>t fgetc '>t return
DEFERRED key in-key

( test program )
ARRAY hex65 key 6 >t key 5 >t 0 >t   
L: test-word t' hex65 w>t t' number w>t t' drop w>t t' emit w>t t' terminate w>t

9 <: ( actual entry point )
  LEA SI test-word
  PUSH CS
  POP AX
  ADD AX 4096 #
  MOV SS AX
  MOV t& lastseg @+ AX
  MOV SP 0xfe #
  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