; threaded forth - boot loader/16bit/bios calling
; ax,bx,cx,dx - general purpose registers
; dstack,rstack - pointer registers (stack and rstack?)
; si,codeptr - index registers (codeptr = code pointer?)

bits 16

%define boot_org (1984*16)
%define sector_size 512
%define nsectors 6
%define stack_base (boot_org+sector_size*nsectors)
%define dstack_size 1024
%define rstack_size 512

org boot_org

%define codeptr di
%define rstack bp
%define dstack sp
;; execute next word
%macro next 0
  jmp [codeptr]
%endmacro
;; push to return stack for forth word call
%macro rpush 0
  mov dx, codeptr
  add dx, 2
  sub rstack, 2
  mov word [rstack], dx
%endmacro
;; pop from return stack to resume after word call
%macro rpop 0
  mov codeptr, [rstack]
  add rstack, 2
%endmacro
;; this asm code is inlined at the start of every forth word to setup the
;; code pointer to point at the start of the CFA vector
%define entry_code_len 18 ; must be updated if macro enter is changed
%macro enter 0
  rpush
  mov codeptr, [codeptr] ; code-pointer = this word's ENTER code
  add codeptr, entry_code_len ; offset code-pointer to just after ENTER code i.e. start of cfa vector
  next ; run first cfa in this word's cfa vector
%endmacro
;; this asm code is inlined at the end of every primitive/pure asm word
;; to continue executing with the next CFA in the vector
%macro primexit 0
  add codeptr, 2 ; move code-pointer to next cfa vector entry
  next
%endmacro

; (dictionary entry head)
%macro pentry 1-2 _onlylabel ; label or label 'name' (where label=name if omitted)
  ; cannot use %1 as default parameter for %2
  %ifidn %2, _onlylabel
    %defstr name %1
  %else
    %define name %2
  %endif
  %%nfa:
  db name, 0
  dw last
  %define last %%nfa
  %1:
%endmacro

%macro entry 1-2 _onlylabel ; label or label 'name' (where label=name if omitted)
  pentry %1,%2
  enter
%endmacro

%define last 0

%define newline 0xa
%define return 0xd
%define space 32
%define ascii_zero 0x30

%define black 1
%define green 2
%define red 4
%define white 7

start:
  ; system enter with dl = drive number at boot
  xor ax, ax
  mov ds, ax
  mov es, ax
  mov ss, ax      ; stack base
  mov dstack, stack_base + dstack_size ; data stack pointer 'ss:dstack'
  mov rstack, stack_base + dstack_size + rstack_size ; return stack pointer 'ss:rstack'

  call load_sectors
  mov codeptr, top_cfa_vec
  next
  cli
  hlt

load_sectors:
  mov ax, 0x0200 + nsectors-1 ; read sector/ n sectors
  mov cx, 0x0002 ; track/cylinder zero | start sector number (1 based)
  ;mov dh, 0x00 ; head=0, drive in DL at boot
  mov dx, 0x0080
  mov bx, extra_sectors
  int 0x13
  cmp ah, 0 ; check for success
.die: jnz .die
  ret

;; end of first sector
times 510-($-$$) db 0 ; pad to 512
dw 0xaa55 ; magic
;; second sector memory
extra_sectors:

;; forth primitive used to exit forth words
pentry exit
  rpop
  next

pentry zexit, '0ret'
  pop ax
  cmp ax, 0
  jnz .donothing
  rpop ; exit
  next
.donothing:
  primexit

pentry zexitkeep, '0retk'
  pop ax
  cmp ax, 0
  jnz .donothing
  rpop ; exit
  next
.donothing:
  push ax
  primexit

pentry nzexit, '!0ret'
  pop ax
  cmp ax, 0
  jz .donothing
  rpop ; exit
  next
.donothing:
  primexit

pentry nzexitkeep, '!0retk'
  pop ax
  cmp ax, 0
  jz .donothing
  push ax
  rpop ; exit
  next
.donothing:
  primexit

pentry jump
  add codeptr, 2
  add codeptr, [codeptr]
  primexit

pentry zjump, '0jump'
  add codeptr, 2
  pop ax
  cmp ax, 0
  jnz .donothing
  add codeptr, [codeptr]
.donothing:
  primexit

pentry zjumpkeep, '0jumpk'
  add codeptr, 2
  pop ax
  cmp ax, 0
  jnz .donothing
  add codeptr, [codeptr]
  primexit
.donothing:
  push ax
  primexit

pentry nzjump, '!0jump'
  add codeptr, 2
  pop ax
  cmp ax, 0
  jz .donothing
  add codeptr, [codeptr]
.donothing:
  primexit

pentry loop
  ; jump back to start of current function (tail call)
  mov codeptr, [rstack] ; rpeek
  sub codeptr, 2
  mov codeptr, [codeptr] ; current word entry
  add codeptr, entry_code_len ; skip entry prelude to cfa vec
  next

pentry calltos ; ( cfa -- )
  ; put cfa on stack into next cfa slot and return, so the cfa will be called
  pop ax
  mov 2[codeptr], ax
  primexit

pentry lit
  add codeptr, 2
  mov ax, [codeptr]
  push ax
  primexit

pentry dup
  pop ax
  push ax
  push ax
  primexit

pentry dup2, '2dup'
  pop bx
  pop ax
  push ax
  push bx
  push ax
  push bx
  primexit

pentry drop
  add dstack, 2
  primexit

pentry drop2, '2drop'
  add dstack, 4
  primexit

pentry swap
  pop bx
  pop ax
  push bx
  push ax
  primexit

pentry rot ; ( a b c - b c a )
  pop cx
  pop bx
  pop ax
  push bx
  push cx
  push ax
  primexit

pentry over ; ( a b - a b a )
  sub dstack, 2
  mov si, dstack
  mov ax, 4[si] ; s[0]=s[2]
  mov 0[si], ax
  primexit

pentry tuck ; ( a b - b a b )
  pop bx
  pop ax
  push bx
  push ax
  push bx
  primexit

pentry nip ; ( a b -- b )
  pop bx
  add dstack, 2
  push bx
  primexit

pentry inc, '1+'
  pop ax
  inc ax
  push ax
  primexit

pentry dec, '1-'
  pop ax
  dec ax
  push ax
  primexit

pentry cfetch, 'c@'
  xor ax, ax
  pop si
  mov al, [si]
  push ax
  primexit

pentry cstore, 'c!' ; ( addr c - )
  pop ax
  pop si
  mov [si], al
  primexit

pentry fetch, '@'
  pop si
  mov ax, [si]
  push ax
  primexit

pentry store, '!' ; ( addr x - )
  pop ax
  pop si
  mov [si], ax
  primexit

pentry lessthan, '<' ; ( a b - a<b )
  pop bx
  pop ax
  cmp ax, bx
  setl al
  mov ah, 0
  push ax
  primexit

pentry gteq, '>=' ; ( a b - a>=b )
  pop bx
  pop ax
  cmp ax, bx
  setge al
  mov ah, 0
  push ax
  primexit

pentry equal, '=' ; ( a b - a=b )
  pop bx
  pop ax
  cmp ax, bx
  sete al
  mov ah, 0
  push ax
  primexit

pentry add, '+' ; ( a b - a+b )
  pop bx
  pop ax
  add ax, bx
  push ax
  primexit

pentry sub, '-' ; ( a b - a-b )
  pop bx
  pop ax
  sub ax, bx
  push ax
  primexit

pentry mul, '*' ; ( a b - a*b ) ; ax*bx -> dx:ax
  pop bx
  pop ax
  mul bx
  push ax ; ignoring 32-bit result dx:ax
  primexit

pentry div, '/' ; ( a b - a/b ) ; (dx:ax)/bx -> ax (remainder in dx)
  pop bx
  pop ax
  xor dx, dx
  div bx
  push ax
  primexit

pentry mod ; ( a b - a%b ) ; (dx:ax)/bx -> ax (remainder in dx)
  pop bx
  pop ax
  xor dx, dx
  div bx
  push dx
  primexit

;; machine io

pentry cls
  mov ax, 0x0600 ; func/nlines=0 means full rectangle
  xor bh,bh ; attr
  xor cx,cx ; row/col top/left
  mov dx,0x184f ; row/col bottom/left 24/79
  int 0x10
  mov ah, 2 ; set cursor (dh/dl)
  xor dx, dx
  int 0x10
  mov word [cursor_pos], 0
  primexit

pentry putc
  pop ax
  mov ah, 9 ; write attr char at cursor
  mov bl, green
  mov cx, 1 ; repeat
  int 0x10
  primexit

;; introspection/system debug
pentry saddr ; ( -- stack-address )
  mov ax, dstack
  push ax
  primexit

top_cfa_vec:
  dw main
  ; never return here

main:
  enter
  dw cls, lit, str_welcome, puts, interpret, exit

spin:
  enter
  dw lit, str_ok, puts, readword, parseint, cr, printint, loop, exit

_emit:
  enter
  dw putc, crsinc, exit

entry cr
  dw lit, cursor_pos, lit, 0, cstore, rowinc, rowcheck, crs_update, exit

entry emit
  dw dup, lit, newline, equal, zjump, 3*2, drop, cr, exit, _emit, exit

puts_:
  enter
  dw dup, cfetch, zexitkeep, emit, inc, jump, -7*2, exit

entry puts
  dw puts_, drop, exit

colinc:
  enter
  dw lit, cursor_pos, dup, cfetch, inc, cstore, exit

rowinc:
  enter
  dw lit, cursor_pos+1, dup, cfetch, inc, cstore, exit

str_welcome db `Welcome to FORTH!\n`, 0
str_ok db `\nok> `, 0
cursor_pos dw 0

crs_update:
  mov dx, [cursor_pos]
  mov ah, 2 ; set cursor (dh/dl)
  int 0x10
  primexit

rowcheck: ; row?
  enter
  dw lit, cursor_pos+1, cfetch, lit, 25, gteq, zexit, lit, cursor_pos+1, lit, 0, cstore, cls, exit

colcheck: ; col?
  enter
  dw lit, cursor_pos, cfetch, lit, 80, gteq, zexit, lit, cursor_pos, lit, 0, cstore, rowinc, rowcheck, exit

crsinc: ; crs+
  enter
  dw colinc, colcheck, crs_update, exit

_key:
  xor ax,ax ; wait for key (=> AH/AL scan/ascii)
  int 0x16
  xor ah,ah ; zero keycode
  push ax
  primexit

entry key
  dw _key, dup, lit, return, equal, zjump, 3*2, drop, lit, space, exit

text: times 65 db 0 ;  buffer for user input byte[0]=len

entry cincstore, 'c1+!' ; ( addr - )
  dw dup, cfetch, inc, cstore, exit

clearword:
  enter
  dw lit, text, lit, 0, cstore, exit

readwordlen:
  enter
  dw key, dup, lit, space, equal, zjump, 2*2, drop, exit, dup, emit, lit, text, dup, cfetch, add, inc, swap, cstore, lit, text, cincstore, loop, exit

nulterm: ; ( string - )
  enter
  dw dup, cfetch, add, inc, lit, 0, cstore, exit

; where p points at nul-terminated number string
parseintloop: ; ( 0 p  - N p' )
  enter
  dw dup, cfetch, zexitkeep, lit, ascii_zero, sub ; ( N p d )
  dw rot, lit, 10, mul, add ; ( p N' )
  dw swap, inc ; ( N' p' )
  dw loop, exit

entry parseint ; ( - N )
  dw lit, 0, lit, text+1, parseintloop, drop, exit

printintloop: ; ( N p )
  enter
  dw over, zexit, dec, over
  dw lit, 10, mod, lit, ascii_zero, add ; ( N p 'd' )
  dw over, swap, cstore
  dw swap, lit, 10, div, swap, loop, exit

printint:
  enter
  dw dup, nzjump, 5*2, drop, lit, ascii_zero, emit, exit
  dw lit, text+64, dup, lit, 0, cstore, printintloop, puts, drop, exit

entry kick, '.' ; ( N - )
  dw cr, printint, exit

entry streq ; ( s1 s2 - ? )
  dw dup, cfetch ; ( s2 s1 c1 )
  dw rot, dup, cfetch ; ( s1 c1 s2 c2 )
  dw rot ; ( s1 s2 c2 c1 )
  dw equal ; ( s1 s2 ? )
  dw nzjump, 4*2, drop2, lit, 0, exit ; ( false ) if unequal
  dw dup, cfetch ; ( s1 s2 nul? )
  dw nzjump, 4*2, drop2, lit, 1, exit ; ( true ) if one is NUL, both are cos both equal
  ;  ( s1 s2 )
  dw inc, swap, inc, swap ; ( s1++ s2++ )
  dw loop, exit

entry nfa2lfa, "nfa>lfa" ; ( nfa -- lfa )
  dw dup, cfetch, nzjump, 4, inc, exit ; ( lfa )
  dw inc, loop, exit

entry lfa2cfa, "lfa>cfa"
  dw lit, 2, add, exit

findnameloop: ; ( name nfa -- name nfa | name 0 )
  enter
  dw dup, zexit ; ( name 0 )
  dw dup2, streq, nzexit ; ( name nfa )
  dw nfa2lfa, fetch, loop, exit ; ( name nfa' )

entry find ; ( -- nfa|0 )
  dw lit, text+1, lit, last, findnameloop, nip, exit

entry readword
  dw clearword, readwordlen, lit, text, nulterm, exit

entry interpret
  dw lit, str_ok, puts
  dw readword
  dw find ; ( nfa|0 )
  dw zjumpkeep, 5*2, nfa2lfa, lfa2cfa, calltos, 0, loop ; execute found word
  dw parseint ; ( i )
  dw loop, exit

times 512*nsectors-($-$$) db 0 ; pad to n sectors