include "inc/cmdsys.plh"
include "inc/args.plh"
include "inc/fileio.plh"

import sexpr
  const TYPE_MASK  = $70
  const NIL        = $00
  const BOOL_FALSE = $00
  const BOOL_TRUE  = $01
  const CONS_TYPE  = $10
  const SYM_TYPE   = $20
  const SYM_LEN    = $0F
  const NUM_TYPE   = $30
  const NUM_INT    = $31
  const NUM_FLOAT  = $32
  const ARRAY_TYPE = $40

  struc t_elem
    word link
    byte type
    byte refcnt
  end
  struc t_cons
    res[t_elem]
    word car
    word cdr
  end
  struc t_sym
    res[t_elem]
    word natv
    word lambda
    word array
    word apval
    char name[0]
  end
  struc t_numint
    res[t_elem]
    word intval[2]
  end

  var fmt_fpint
  var fmt_fpfrac

  predef ref(expr)#1
  predef deref(expr)#1
  predef print_expr(expr)#1
  predef parse_expr(evalptr, level, refill)#2
  predef eval_expr(expr)#1
  predef bool_pred(bool)#1
  predef new_int(intlo, inthi)#1
  predef new_sym(symstr)#1
  predef new_assoc(symptr, valptr)#0
  predef set_assoc(symptr, valptr)#0
end

import smath
  predef eval_int(expr)#1
end

var prog, prog_expr, prog_return // Current PROG expressions
var sym_cond, sym_fpint, sym_fpfrac
var pred_true

const FILEBUF_SIZE = 128
var readfn                       // Read input routine
var fileref, filebuf             // File read vars
byte quit = FALSE                // Quit interpreter flag

//
// (PROG ...) language extension
//

def natv_prog(symptr, expr)
  var prog_enter, prog_car, cond_expr

  prog_expr  = expr=>cdr
  prog       = prog_expr // Update current PROG expression
  prog_enter = prog      // Save current prog
  expr = expr=>car       // Set up local variables
  while expr
    new_assoc(expr=>car, NULL)
    expr = expr=>cdr
  loop
  prog_return = NULL
  while prog_expr and not prog_return
    prog_car  = prog_expr=>car
    prog_expr = prog_expr=>cdr // Assume continuation
    if prog_car->type == CONS_TYPE
      //
      // List - check for (COND (...))
      //
      if prog_car=>car == sym_cond // Inline cond() evaluation
        cond_expr = prog_car=>cdr
        while cond_expr
          if deref(eval_expr(cond_expr=>car=>car)) == pred_true
            deref(eval_expr(cond_expr=>car=>cdr=>car)) // Drop result
            break
          fin
          cond_expr = cond_expr=>cdr
        loop
      else
        deref(eval_expr(prog_car)) // Drop result
      fin
    //else
      //
      // Atom - skip, i.e. (GO ) destination
      //
    fin
  loop
  prog = prog_enter
  return eval_expr(prog_return)
end

def natv_return(symptr, expr)
  prog_return = expr=>car
  return NULL // This value will be dropped in natv_prog
end

def natv_go(symptr, expr)
  expr   = expr=>car
  symptr = prog // Scan prog list looking for matching SYM
  while symptr
    if symptr=>car == expr
      prog_expr = symptr=>cdr
      return NULL
    fin
    symptr = symptr=>cdr
  loop
  puts("(GO ...) destination not found:"); print_expr(expr); putln
  return NULL
end

def natv_set(symptr, expr)
  symptr = eval_expr(expr=>cdr=>car)
  set_assoc(deref(eval_expr(expr=>car)), symptr)
  return ref(symptr)
end

def natv_setq(symptr, expr)
  symptr = eval_expr(expr=>cdr=>car)
  set_assoc(expr=>car, symptr)
  return ref(symptr)
end

//
// REPL native helper functions
//

def natv_fpint(symptr, expr)
  var fmt

  fmt_fpint = eval_int(expr)=>intval
  deref(expr)
  fmt = new_int(fmt_fpint,  0)
  set_assoc(sym_fpint, fmt)
  return fmt
end

def natv_fpfrac(symptr, expr)
  var fmt

  fmt_fpfrac = eval_int(expr)=>intval
  deref(expr)
  fmt = new_int(fmt_fpfrac,  0)
  set_assoc(sym_fpfrac, fmt)
  return fmt
end

def natv_memavail(symptr, expr)
  return new_int(heapavail, 0)
end

def natv_bye(symptr, expr)
  quit = TRUE
  return ref(new_sym("GOODBYE!")) // (QUOTE GOODBYE!)
end

//
// Keyboard and file input routines
//

def refill_keybd
  var readline

  repeat
    readline = gets('>'|$80)
    ^(readline + ^readline + 1) = 0
  until ^readline
  return readline + 1
end

def read_keybd
  var readline, expr

  repeat
    readline = gets('?'|$80)
    ^(readline + ^readline + 1) = 0
  until ^readline
  drop, expr = parse_expr(readline + 1, 0, @refill_keybd)
  //print_expr(expr); putln // DEBUG - print parsed expression
  return expr
end

def read_fileline
  var len

  repeat
    len = fileio:read(fileref, filebuf, FILEBUF_SIZE-1)
    if len
      if ^(filebuf + len - 1) == $0D
        len-- // Remove trailing carriage return
      fin
      ^(filebuf + len) = 0 // NULL terminate
    else
      fileio:close(fileref)
      readfn = @read_keybd
      return FALSE
    fin
  until len
  return TRUE
end

def refill_file
  if not read_fileline
    puts("File input prematurely ended\n")
    return refill_keybd
  fin
  return filebuf
end

def read_file
  var expr

  if not read_fileline
    return read_keybd
  fin
  drop, expr = parse_expr(filebuf, 0, @refill_file)
  return expr
end

//
// Handle command line options
//

def parse_cmdline#0
  var filename

  readfn = @read_keybd
  filename = argNext(argFirst)
  if ^filename
    fileref = fileio:open(filename)
    if fileref
      fileio:newline(fileref, $7F, $0D)
      readfn = @read_file
      filebuf = heapalloc(FILEBUF_SIZE)
    else
      puts("Unable to open: "); puts(filename); putln
    fin
  fin
end

//
// REPL
//

def rep#0
  var expr, eval

  expr = readfn()
  eval = eval_expr(expr)
  deref(print_expr(eval)); putln
  if eval and eval <> expr; deref(expr); fin
end

puts("DRAWL (LISP 1.5) symbolic processor\n")
pred_true  = bool_pred(TRUE) // Capture value of TRUE
sym_fpint  = new_sym("FMTFPI")
sym_fpfrac = new_sym("FMTFPF")
sym_fpint=>natv  = @natv_fpint
sym_fpfrac=>natv = @natv_fpfrac
new_assoc(sym_fpint,  new_int(fmt_fpint,  0))
new_assoc(sym_fpfrac, new_int(fmt_fpfrac, 0))
sym_cond = new_sym("COND") // This should actually match COND
new_sym("PROG")=>natv   = @natv_prog
new_sym("GO")=>natv     = @natv_go
new_sym("RETURN")=>natv = @natv_return
new_sym("SET")=>natv    = @natv_set
new_sym("SETQ")=>natv   = @natv_setq
new_sym("MEM")=>natv    = @natv_memavail
new_sym("BYE")=>natv    = @natv_bye

parse_cmdline
while not quit; rep; loop
putln
done
