include "inc/cmdsys.plh"
include "inc/fileio.plh"
include "inc/args.plh"
//
// FORTH dictionary layout
//
//  bytes   usage
//  -----   -----
// [1]      name length
// [1..255] name
// [1]      FFA (flag field address)
// [2]      LFA (link field address)
// [2]      CFA (code field address)
// [2..]    PFA (param field address)
//

//
// Mask and flags for dictionary entries
//
const inline_flag   = $10
const imm_flag      = $20
const componly_flag = $40
const hidden_flag   = $80
//
// Predefine instrinsics
//
predef _drop_(a)#0, _swap_(a,b)#2, _dup_(a)#2, _over_(a,b,c)#4, _rot_(a,b,c)#3
predef _add_(a,b)#1, _sub_(a,b)#1, _mul_(a,b)#1, _div_(a,b)#1
predef _neg_(a)#1, _and_(a,b)#1, _or_(a,b)#1, _xor_(a,b)#1, _not_(a)#1
predef _cset_(a,b)#0, _cget_(a)#1, _wset_(a,b)#0, _wget_(a)#1
predef _cfa_(a)#1, _lfa_(a)#1
predef _eq_(a,b)#1, _gt_(a,b)#1, _lt_(a,b)#1
predef _branch_#0, _branch0_(a)#0, _if_#0, _else_#0, _then_#0
predef _do_#0, _doloop_#0, _leave_#0, _loop_#0, _j_#1
predef _create_#0, _dodoes_#0, _filldoes_#0, _does_#0
predef _pset_(a)#0, _colon_#0, _semi_#0
predef _tors_(a)#0, _fromrs_#1, _toprs_#1
predef _var_(a)#0, _const_(a)#0, _lit_#1, _slit_#1, _tick_#1, _forget_#0
predef _str_#0, _prstr_#0, _src_#0
predef _vlist_#0, _tron_#0, _troff_#0, _checkon_#0, _checkoff_#0
predef _show_#0, _showstack_#0, _bye_#0, _abort_#0
// DROP
char d_drop = "DROP"
byte = 0
word = 0, @_drop_, 0
// SWAP
char d_swap = "SWAP"
byte = 0
word = @d_drop, @_swap_, 0
// DUP
char d_dup = "DUP"
byte = 0
word = @d_swap, @_dup_, 0
// OVER
word d_over = "OVER"
byte = 0
word = @d_dup, @_over_, 0
// ROT
word d_rot = "ROT"
byte = 0
word = @d_over, @_rot_, 0
// ADD
char d_add = "+"
byte = 0
word = @d_rot, @_add_, 0
// SUB
char d_sub = "-"
byte = 0
word = @d_add, @_sub_, 0
// MUL
char d_mul = "*"
byte = 0
word = @d_sub, @_mul_, 0
// DIV
char d_div = "/"
byte = 0
word = @d_mul, @_div_, 0
// NEG
char d_neg = "NEG"
byte = 0
word = @d_div, @_neg_, 0
// AND
char d_and = "AND"
byte = 0
word = @d_neg, @_and_, 0
// OR
char d_or = "OR"
byte = 0
word = @d_and, @_or_, 0
// XOR
char d_xor = "XOR"
byte = 0
word = @d_or, @_xor_, 0
// NOT
char d_not = "NOT"
byte = 0
word = @d_xor, @_not_, 0
// EQUALS
char d_eq = "="
byte = 0
word = @d_not, @_eq_, 0
// GREATER THAN
char d_gt = ">"
byte = 0
word = @d_eq, @_gt_, 0
// LESS THAN
char d_lt = "<"
byte = 0
word = @d_gt, @_lt_, 0
// CHAR PUT
char d_cset = "C!"
byte = 0
word = @d_lt, @_cset_, 0
// WORD PUT
char d_wset = "!"
byte = 0
word = @d_cset, @_wset_, 0
// CHAR GET
char d_cget = "C@"
byte = 0
word = @d_wset, @_cget_, 0
// WORD SET
char d_wget = "@"
byte = 0
word = @d_cget, @_wget_, 0
// TO RSTACK
char d_torstk = ">R"
byte = 0
word = @d_wget, @_tors_, 0
// FROM RSTACK
char d_fromrstk = "R>"
byte = 0
word = @d_torstk, @_fromrs_, 0
// TOP OF RSTACK
char d_toprstk = "R@"
byte = 0
word = @d_fromrstk, @_toprs_, 0
// VARIABLE
char d_var = "VARIABLE"
byte = 0
word = @d_toprstk, @_var_, 0
// CONSTANT
char d_const = "CONSTANT"
byte = 0
word = @d_var, @_const_, 0
// HERE
char d_here = "HERE"
byte = 0
word = @d_const, @heapmark, 0
// ALLOT
char d_allot = "ALLOT"
byte = 0
word = @d_here, @heapalloc, 0
// BRANCH
char d_branch = "(BRANCH)"
byte = inline_flag
word = @d_allot, @_branch_, 0
// BRANCH IF 0
char d_branch0 = "(BRANCH0)"
byte = inline_flag
word = @d_branch, @_branch0_, 0
// IF
char d_if = "IF"
byte = componly_flag | imm_flag
word = @d_branch0, @_if_, 0
// ELSE
char d_else = "ELSE"
byte = componly_flag | imm_flag
word = @d_if, @_else_, 0
// THEN
char d_then = "THEN"
byte = componly_flag | imm_flag
word = @d_else, @_then_, 0
// DO
char d_do = "DO"
byte = componly_flag | imm_flag
word = @d_then, @_do_, 0
// LEAVE
char d_leave = "LEAVE"
byte = componly_flag
word = @d_do, @_leave_, 0
// LOOP
char d_doloop = "(DOLOOP)"
byte = componly_flag | inline_flag
word = @d_leave, @_doloop_, 0
// LOOP
char d_loop = "LOOP"
byte = componly_flag | imm_flag
word = @d_doloop, @_loop_, 0
// I
char d_i = "I"
byte = componly_flag
word = @d_loop, @_toprs_, 0
// J
char d_j = "J"
byte = componly_flag
word = @d_i, @_j_, 0
// FORGET
char d_forget = "FORGET"
byte = 0
word = @d_j, @_forget_, 0
// BUILDS
char d_builds = "<BUILDS"
byte = 0
word = @d_forget, @_create_, 0
// FILL DOES COMPILE TIME
char d_filldoes = "(FILLDOES)"
byte = 0
word = @d_builds, @_filldoes_, 0
// DO DOES RUN TIME
char d_dodoes = "(DODOES)"
byte = 0
word = @d_filldoes, @_dodoes_, 0
// DOES
char d_does = "DOES>"
byte = imm_flag
word = @d_dodoes, @_does_, 0
// COMMA
char d_comma = ","
byte = 0
word = @d_does, @_pset_, 0
// COLON
char d_colon = ":"
byte = 0
word = @d_comma, @_colon_, 0
// SEMI
char d_semi = ";"
byte = imm_flag
word = @d_colon, @_semi_, 0
// TICK
char d_tick = "'"
byte = 0
word = @d_semi, @_tick_, 0
// LITERAL NUMBER
char d_lit = "LIT"
byte = inline_flag
word = @d_tick, @_lit_, 0
// PRINT TOS
char d_prtos = "."
byte = 0
word = @d_lit, @puti, 0
// PRINT TOS HEX
char d_prtoshex = ".$"
byte = 0
word = @d_prtos, @puth, 0
// PRINT TOS HEX
char d_prtosbyte = ".C$"
byte = 0
word = @d_prtoshex, @putb, 0
// EMIT
char d_emit = "EMIT"
byte = 0
word = @d_prtosbyte, @putc, 0
// CR
char d_cr = "CR"
byte = 0
word = @d_emit, @putln, 0
// STRING
char d_str = "\""
byte = imm_flag
word = @d_cr, @_str_, 0
// LITERAL STRING
char d_slit = "SLIT"
byte = inline_flag
word = @d_str, @_slit_, 0
// COMPILED PRINT STRING
char d_doprstr = "(.\")"
byte = 0
word = @d_slit, @puts, 0
// PRINT STRING
char d_prstr = ".\""
byte = imm_flag
word = @d_doprstr, @_prstr_, 0
// SOURCE FILE
char d_prsrc = "SRC\""
byte = 0
word = @d_prstr, @_src_, 0
// BYE
char d_bye = "BYE"
byte = 0
word = @d_prsrc, @_bye_, 0
// SHOW DEFINITION
char d_show = "SHOW"
byte = 0
word = @d_bye, @_show_, 0
// SHOW STACK
char d_showstack = "SHOWSTACK"
byte = 0
word = @d_show, @_showstack_, 0
// TRACE ON
char d_tron = "TRON"
byte = 0
word = @d_showstack, @_tron_, 0
// TRACE OFF
char d_troff = "TROFF"
byte = 0
word = @d_tron, @_troff_, 0
// CHECK ON
char d_checkon = "CHKON"
byte = 0
word = @d_troff, @_checkon_, 0
// CHECK OFF
char d_checkoff = "CHKOFF"
byte = 0
word = @d_checkon, @_checkoff_, 0
// LIST VOCAB
char d_vlist = "VLIST"
byte = 0
word = @d_checkoff, @_vlist_, 0
//
// Internal variables
//
word vlist = @d_vlist
word startheap, arg, infunc, inref, execwords, IIP, W
const INBUF_SIZE = 80
char inbuf[INBUF_SIZE + 2]
word inptr = @inbuf
//
// RSTACK
//
const RSTK_SIZE = 16
byte RSP = RSTK_SIZE
word RSTACK[RSTK_SIZE]
//
// State flags
//
const exit_flag  = $01
const comp_flag  = $02
byte state   = 0
byte trace   = 0
byte aborted = 0
byte _get_estack   = $8A           // TXA
byte               = $49, $FF      // EOR #$FF
byte               = $38           // SEC
byte               = $69, $10      // ADC #$10
byte               = $C9, $11      // CMP #$11
byte               = $90, $02      // BCC +2
byte               = $A2, $10      // LDX #ESTKSZ/2
byte               = $CA           // DEX
byte               = $95           // STA
byte _estkl        = $D0           // ESTKL,X
byte               = $A9, $00      // LDA #$00
byte               = $95           // STA
byte _estkh        = $C0           // ESTKH,X
byte               = $60           // RTS
byte _reset_estack = $A2, $10      // LDX #ESTKSZ/2
byte               = $60           // RTS
//
// Helper routines
//
def keyin#0
  byte i

  repeat
    if state & comp_flag
      inptr = gets('>'|$80) // Compilation continuation prompt
    else
      puts(" OK")
      inptr = gets('\n'|$80)
    fin
  until ^inptr
  ^(inptr + ^inptr + 1) = 0 // NULL terminate
  inptr++
end
def filein#0
  inbuf = fileio:read(inref, @inbuf + 1, INBUF_SIZE)
  if inbuf
    inbuf[inbuf + 1] = 0 // NULL terminate
    inptr            = @inbuf + 1
  else
    fileio:close(inref) // EOF - switch back to keyboard input
    inref  = 0
    infunc = @keyin
    keyin
  fin
end
def toknext#2
  word tokptr
  byte len, comment

  comment = 0
  repeat
    repeat
      if !^inptr
        infunc()#0
      fin
      while ^inptr and ^inptr <= ' ' // Skip whitespace
        inptr++
      loop
    until ^inptr
    len = 0
    while ^(inptr + len) > ' ' // Tokenize characters
      len++
    loop
    if len == 1 and ^inptr == '(' // Check for nested comment
      comment++
    fin
    if comment
      if len == 1 and ^inptr == ')' // Check for nested uncomment
        comment--
      fin
      inptr = inptr + len
      len   = 0
    fin
  until len
  tokptr = inptr
  inptr  = inptr + len
  return tokptr, len
end
def delimit(a)#2
  word delim
  byte len

  if ^inptr == ' '
    inptr++
  fin
  delim = inptr
  while ^inptr and ^inptr <> a // Find delimiter
    inptr++
  loop
  len = inptr - delim
  if ^inptr == a
    inptr++
  fin
  return delim, len
end
//
// Find match in dictionary
//
def find(matchchars, matchlen)#1
  word dentry
  byte i

  matchchars--
  dentry = vlist
  while dentry
    if ^dentry == matchlen
      for i = 1 to ^dentry
        if ^(matchchars+i) <> ^(dentry+i)
          break
        fin
      next
      if i > ^dentry
        return dentry
      fin
    fin
    dentry = *(dentry + ^dentry + 2)
  loop
  // Not found
  return 0
end
//
// Convert input into number
//
def isnum(numchars, numlen)#2
  word num, sign
  byte numchar

  sign = 1
  if ^numchars == '-'
    sign = -1
    numchars++
    numlen--
    if numlen == 0
      return 0, 0
    fin
  fin
  num = 0
  if ^numchars == '$'
    numchars++
    numlen--
    if numlen == 0
      return 0, 0
    fin
    while numlen
      numchar = toupper(^numchars)
      if numchar >= '0' and numchar <= '9'
        num = num * 16 + numchar - '0'
      elsif numchar >= 'A' and numchar <= 'F'
        num = num * 16 + numchar - 'A' + 10
      else
        break
      fin
      numchars++
      numlen--
    loop
  else
    while numlen
      numchar = ^numchars
      if numchar < '0' or numchar > '9'
        break
      fin
      num = num * 10 + numchar - '0'
      numchars++
      numlen--
    loop
  fin
  return num * sign, numlen == 0
end
//
// Execute code in CFA
//
def execword(dentry)#0
  if ^$C000 == $83 // CTRL-C
    ^$C010 // Clear KB strobe
    _abort_
  fin
  if ^$C000 == $94 // CTRL-T
    ^$C010 // Clear KB strobe
    trace = not trace
  fin
  if trace
    _showstack_; puts(": "); puts(dentry); putln
  fin
  W = _cfa_(dentry)
  (*W)()#0
  if (@_get_estack)()#1 > 16
    puts("Stack over/underflow\n")
    _abort_
  fin
end
def execwords_check(wlist)#0
  word prevIP, dentry

  prevIP = IIP
  IIP    = wlist
  while *IIP
    dentry = *IIP
    IIP    = IIP + 2
    execword(dentry)
  loop
  IIP = prevIP
end
def execwords_nocheck(wlist)#0
  word prevIP

  prevIP = IIP
  IIP    = wlist
  while *IIP
    W   = _cfa_(*IIP)
    IIP = IIP + 2
    (*W)()#0
  loop
  IIP = prevIP
end
def push(a)#1 // Stack hack - call as (@push)(a)#0 to leave a on eval stack
  return a
end
//
// Intrinsics
//
def _drop_(a)#0
  return
end
def _swap_(a,b)#2
  return b,a
end
def _dup_(a)#2
  return a,a
end
def _over_(a,b,c)#4
  return a,b,c,a
end
def _rot_(a,b,c)#3
  return b,c,a
end
def _add_(a,b)#1
  return a+b
end
def _sub_(a,b)#1
  return a-b
end
def _mul_(a,b)#1
  return a*b
end
def _div_(a,b)#1
  return a/b
end
def _neg_(a)#1
  return -a
end
def _and_(a,b)#1
  return a & b
end
def _or_(a,b)#1
  return a | b
end
def _xor_(a,b)#1
  return a ^ b
end
def _not_(a)#1
  return ~a
end
def _eq_(a,b)#1
  return a == b
end
def _gt_(a,b)#1
  return a > b
end
def _lt_(a,b)#1
  return a < b
end
def _cset_(a,b)#0
  ^b=a
end
def _wset_(a,b)#0
  *b=a
end
def _cget_(a)#1
  return ^a
end
def _wget_(a)#1
  return *a
end
def _ffa_(dentry)#1
  return dentry + ^dentry + 1
end
def _lfa_(dentry)#1
  return dentry + ^dentry + 2
end
def _cfa_(dentry)#1
 return dentry + ^dentry + 4
end
def _pfa_(dentry)#1
 return dentry + ^dentry + 6
end
def _tors_(a)#0
  if RSP == 0
    puts("Return stack overflow\n")
    _abort_
  fin
  RSP--
  RSTACK[RSP] = a
end
def _fromrs_#1
  if RSP == RSTK_SIZE
    puts("Return stack underflow\n")
    _abort_
  fin
  RSP++
  return RSTACK[RSP - 1]
end
def _toprs_#1
  return RSTACK[RSP]
end
def _lit_#1
  word lit

  lit = *IIP
  IIP = IIP + 2
  return lit
end
def _slit_#1
  word slit

  slit = IIP
  IIP  = IIP + ^IIP + 1
  return slit
end
def _pset_(a)#0
  *(heapalloc(2)) = a
end
def _create_#0
  word bldptr, plist, namechars, namelen

  namechars, namelen = toknext
  plist = vlist
  vlist  = heapmark
  ^vlist = namelen
  bldptr = vlist + 1
  while namelen
    ^bldptr = ^namechars
    bldptr++
    namechars++
    namelen--
  loop
  ^bldptr = 0      // Flags
  bldptr++
  *bldptr = plist; // Link ptr
  bldptr  = bldptr + 2
  *bldptr = 0;     // Code ptr
  bldptr  = bldptr + 2
  *bldptr = 0;     // Parameters
  heapalloc(bldptr - vlist + 2) // Code ptr
end
def _dovar_#1
  return W + 2 // Address of PFA
end
def _var_(a)#0
  _create_
  *(_cfa_(vlist)) = @_dovar_
  *(_pfa_(vlist)) = a
end
def _doconst_#1
  return *(W + 2) // PFA contents
end
def _const_(a)#0
  _create_
  *(_cfa_(vlist)) = @_doconst_
  *(_pfa_(vlist)) = a
end
def _docolon_#0
  execwords(W + 2)#0 // Exec PFA
end
def _colon_#0
  state = comp_flag
  _create_
  *(_cfa_(vlist)) = @_docolon_
  heaprelease(_pfa_(vlist)) // Backup to compile into PFA
end
def _dodoes_#0
  (@push)(W + 4)#0 // Address of PFA + 2
  execwords(*(W + 2))#0 // Exec PFA ptr
end
def _filldoes_#0
  *(_cfa_(vlist)) = @_dodoes_
  *(_pfa_(vlist)) = IIP + 2
end
def _does_#0
  *(heapalloc(2)) = @d_filldoes
  *(heapalloc(2)) = 0
end
def _semi_#0
  *(heapalloc(2)) = 0
  state = 0
end
def _immediate_#0
  ^_ffa_(vlist) = ^_ffa_(vlist) | imm_flag
end
def _branch_#0
  IIP = *IIP
end
def _branch0_(a)#0
  if a
    IIP = IIP + 2
  else
    IIP = *IIP
  fin
end
def _if_#0
  *(heapalloc(2)) = @d_branch0
  _tors_(heapalloc(2))
end
def _else_#0
  word backref

  backref = _fromrs_
  *(heapalloc(2)) = @d_branch
  _tors_(heapalloc(2))
  *backref = heapmark
end
def _then_#0
  *_fromrs_ = heapmark
end
def _do_#0
  *(heapalloc(2)) = @d_swap
  *(heapalloc(2)) = @d_torstk
  *(heapalloc(2)) = @d_torstk
  _tors_(heapmark)
end
def _leave_#0
  RSTACK[RSP] = RSTACK[RSP + 1] - 1
end
def _doloop_#0
  word count

  count = _fromrs_
  count++
  if count <> _toprs_
    _tors_(count)
    IIP = *IIP
  else
    _fromrs_
    IIP = IIP + 2
  fin
end
def _loop_#0
  *(heapalloc(2)) = @d_doloop
  *(heapalloc(2)) = _fromrs_
end
def _j_#1
  return RSTACK[RSP + 2]
end
def _tick_#1
  return find(toknext)
end
def _forget_#0
  word dentry

  dentry = find(toknext)
  if dentry
    vlist = *_lfa_(dentry)
    heaprelease(dentry)
  fin
end
def _bye_#0
  byte params[7]

  if aborted // then must exit with 'BYE' processing
    params.0 = 4
    params.1 = 0
    params:2 = 0
    params.4 = 0
    params:5 = 0
    syscall($65, @params)
  fin
  state = state | exit_flag
end
def _str_#0
  word str, dict
  byte len

  str, len = delimit('"')
  str--
  ^str = len
  len++
  if state & comp_flag
    *(heapalloc(2)) = @d_slit
  fin
  dict = heapalloc(len)
  memcpy(dict, str, len)
  if not state & comp_flag
    (@push)(dict)#0
  fin
end
def _prstr_#0
  word str
  byte len

  str, len = delimit('"')
  str--
  ^str = len
  if state & comp_flag
    len++
    *(heapalloc(2)) = @d_slit
    memcpy(heapalloc(len), str, len)
    *(heapalloc(2)) = @d_doprstr
  else
    puts(str)
  fin
end
def _src_#0
  word filename
  byte len

  filename, len = delimit('"')
  filename--
  ^filename = len
  inref = fileio:open(filename)
  if inref
    fileio:newline(inref, $7F, $0D)
    infunc = @filein
    inptr  = @inbuf
    inbuf  = 0
  else
    puts("Failed to open "); puts(filename); putln
  fin
end
def _show_#0
  word dentry, pfa, w

  dentry = find(toknext)
  if dentry
    if *_cfa_(dentry) == @_docolon_
      pfa = _pfa_(dentry)
    else
      pfa = *_pfa_(dentry)
    fin
    w = *pfa
    while w
      puts("  "); puts(w)
      if ^_ffa_(w) & inline_flag
        pfa = pfa + 2
        putc('=')
        if *_cfa_(w) == @_slit_
          puts(pfa)
          pfa = pfa + ^pfa - 1
        else
          puti(*pfa)
        fin
      fin
      putln
      pfa = pfa + 2
      w = *pfa
    loop
  fin
end
def _showstack_#0
  word val
  byte depth

  for depth = 1 to (@_get_estack)()#1
    val = ^(_estkl + 16 - depth) | (^(_estkh + 16 - depth) << 8)
    puti(val); putc(' ')
  next
end
def _tron_#0
  trace = 1
end
def _troff_#0
  trace = 0
end
def _checkon_#0
  execwords = @execwords_check
end
def _checkoff_#0
  execwords = @execwords_nocheck
end
def _vlist_#0
  word d

  d = vlist
  while d
    puts(d); puts("  ")
    d = *_lfa_(d)
  loop
end
//
// Warm start
//
def _warmstart_#0
  (@_reset_estack)()#0
  RSP    = RSTK_SIZE
  inbuf  = 0
  inptr  = @inbuf
  infunc = @keyin
  if state // Undo compilation state
    heaprelease(vlist)
    vlist = *_lfa_(vlist)
    state = 0
  fin
  if inref
    fileio:close(inref)
    inref = 0
  fin
end
//
// Cold start
//
def _coldstart_#0
  vlist = @d_vlist
  state = 0
  heaprelease(startheap)
  _warmstart_
end
//
// Quit and look for user input
//
def _quit_#0
  word inchars, dentry
  byte inlen, i

  //
  // Set flags on words
  //
  repeat
    inchars, inlen = toknext
    dentry = find(inchars, inlen)
    if dentry
      if (not state & comp_flag) or (^_ffa_(dentry) & imm_flag)
        execword(dentry)
      else
        _pset_(dentry)
      fin
    elsif not (@isnum)(inchars, inlen)#1
      _warmstart_
      puts("? No match\n")
    elsif state & comp_flag
      _pset_(@d_lit)
      (@_pset_)()#0 // Poke literal value on stack into PFA
    fin
  until state & exit_flag
end
//
// Abort
//
def _abort_#0
  _warmstart_
  puts("Abort\n")
  aborted = 1
  _quit_
end

puts("PLFORTH WIP\n")
startheap = heapmark
_estkl    = ^(@syscall + 1) // Hack to fill in parameter stack locations
_estkh    = ^(@syscall + 3)
execwords = @execwords_nocheck // Faster, no checking execution
_warmstart_
inptr = argNext(argFirst)
if ^inptr; inptr++; _src_; fin
_quit_
done
