--[[ Scheme Evaluator Module
     KILT -- Kamin Interpreters in Lua Toolset
     H. Conrad Cunningham, Professor
     Computer and Information Science
     University of Mississippi

Developed for CSci 658, Software Language Engineering, Fall 2013

2013-08-21: Built Scheme module from Scheme interpreter evaluator code
2013-08-22: Added require of new Utilities module
            Moved initGlobalEnv back to main Scheme chunk
            Added evalArithOp and evalRelOp function factories
2013-08-24: Added calls to new cons, car, and cdr functions in Values
            Added deconsList function factory
            Cleaned dependencies and comments
2013-08-29: Modified to use Opcode and Values Factory modules

1234567890123456789012345678901234567890123456789012345678901234567890

The Evaluator takes the semantic representations of the expressions
and the Symbol Tables generated by the Parser, evaluates the
expression, and returns the resulting value.

The implementation of the evaluator uses a table eval indexed by the
OpCodes used in semantic representation.  The corresponding entry for
an OpCode is a closure that evaluates the corresponding semantic
structure.

--]]

-- KILT Scheme Interpreter Opcode Global Constants
local opcodes = require "opcodes"

-- KILT tree utilities library
local util = require "utilities"
local treeConcat = util.treeConcat

-- KILT Environment Module
local evm = require "environment"
local globalEnv, newEnv      = evm.globalEnv, evm.newEnv
local getVal, assign, setVal = evm.getVal, evm.assign, evm.setVal 

-- BEGIN delete for Scheme
-- -- KILT Function Table Module
-- local ftm = require "funtab"
-- local defFun, getFun = ftm.defFun, ftm.getFun
-- END delete for Scheme

-- KILT Values Module
local vm = require "values"
local FALSEVAL, TRUEVAL = vm.FALSEVAL, vm.TRUEVAL
local isFalse, isTrue   = vm.isFalse,  vm.isTrue
local boolAsVal         = vm.boolAsVal
local hasOpCode         = vm.hasOpCode
-- BEGIN add for Lisp
local NILLIST, consList = vm.NILLIST,  vm.consList
local cons, car, cdr    = vm.cons, vm.car, vm.cdr
local getNum, getSym    = vm.getNum, vm.getSym
-- END add for Lisp
-- BEGIN add for Scheme
local getPrim           = vm.getPrim
-- END add for Scheme


-- EVALUATION TABLE (indexed by OpCode)

local eval = {}

-- Trap any attempts to evaluate invalid OpCodes 
setmetatable(eval,eval)

eval.__index = function(_,key)
  error("Attempt to evaluate invalid OpCode " .. treeConcat(key),2)
end

-- Function "doeval" evaluates the semantic form "t" in the
-- environment "env".  It calls the entry in the "eval" table based on
-- the opcode stored in element "t[i]".  "i" defaults to 1 if the
-- argument is nil or unspecified.

local function doeval(t,env,i) 
  i = i or 1 
  return eval[t[i]](t,env)
end

-- Function "evalScript" evaluates each semantic form in the script
-- "t" (a list) in the environment "env".  Each semantic form in this
-- script is an abstract syntax tree (AST) for a Scheme expression.

local function evalScript(t,env)
  local res = {}
  for i = 1, #t do
    res[i] = doeval(t[i],env)
  end
  return res
end

-- BEGIN delete for Scheme
-- local returnVal = function(t,env)
--   assert(#t == 2, "OpCode must have one argument.")
--   return t[2]
-- end    
-- END delete for Scheme

-- The following define entries in the "eval" table for each OpCode
-- type (i.e., for control operation, value operation, and
-- user-defined function).

-- BEGIN change for Scheme

-- -- Evaluate t = {FUNDEF, name}
-- eval[FUNDEF] = returnVal
-- END change for Scheme

-- Evaluate t = {VARVAL, name}
eval[VARVAL]  = function(t,env)
  local val = getVal(t[2],env)
  if val then 
    return val
  else
    error("Attempt to access value of undefined variable " ..
          tostring(t[2]))
  end
end

-- BEGIN change/add for Lisp

-- -- Evaluate t = {NUMVAL, number}
-- eval[NUMVAL]  = returnVal

local returnArg1 = function(t,env,...) return t end

-- Evaluate t = {NUMSXP, number} 
eval[NUMSXP]  = returnArg1

-- Evaluate t = {SYMSXP, name}
eval[SYMSXP]  = returnArg1

-- Evaluate t = {NILSXP} 
eval[NILSXP]  = returnArg1

-- Evaluate t = {LISTSXP, list} 
eval[LISTSXP] = returnArg1

-- END add for Lisp

-- BEGIN add for Scheme

-- Evaluate t = {CLOSXP, #parms, parms, body, cloenv}
eval[CLOSXP] = returnArg1

-- Evaluate t = {PRIMSXP, operator}
eval[PRIMSXP] = returnArg1

-- END add for Scheme

-- Evaluate t = {IFOP, test, thenExpr, elseExpr}
eval[IFOP] = function(t,env)
  local test, thenExp, elseExp = t[2], t[3], t[4]
  if isTrue(doeval(test,env)) then 
    return doeval(thenExp,env)
  else 
    return doeval(elseExp,env)
  end
end

-- Evaluate t = {WHILEOP, test, body} 
eval[WHILEOP] = function(t,env)
  local test, body = t[2], t[3]
  local res
  while isTrue(doeval(test,env)) do
    res = doeval(body,env)
  end
  return FALSEVAL
end

-- Evaluate t = {SETOP, var, exp}
eval[SETOP] = function(t,env)
  local var, exp = t[2], t[3]
  local val = doeval(exp,env)
  return setVal(var,val,env) -- SIDE EFFECT
end

-- Evaluate t = {BEGINOP, expr1 ...} one or more expr
eval[BEGINOP] = function(t,env)
  local res
  for i = 2, #t do
    res = doeval(t[i],env)
  end
  return res
end
  
-- BEGIN change/add for Scheme

-- -- Evaluate t = {APPLYFUN,name,arg1,arg2,...} zero or more arg
-- eval[APPLYFUN] = function(t,env)
--   local name = t[2]
--   local fdef = getFun(name)
--   if not fdef then 
--     error("Function " .. name .. " not defined.",2)
--   end
-- 
--     -- Entry funTab[name] = {arity, formals, body}
--   local numargs = #t - 2
--   local arity, formal, body = fdef[1], fdef[2], fdef[3]
--   if numargs < arity then
--     error("Function "..name.." called with too few arguments.",2)
--   elseif numargs > arity then 
--     error("Function "..name.." called with too many arguments.",2)
--   end
-- 
--   local localEnv = newEnv(env) -- new environment frame for args
--   for i = 3, #t do
--     local val = doeval(t[i],env)  -- evaluate argument
--     local var = formal[i-2]    
--     assign(var,val,localEnv)      -- assign to parameter name
--   end
--   return doeval(body,localEnv)e
-- end

-- Evaluate t = {LAMBDAOP, #params, params, body}
eval[LAMBDAOP] = function(t,env) 
  return {CLOSXP,t[2],t[3],t[4],env}
end

-- Evaluate t = {APPLYCLO, closure, arg1, arg2,...} zero or more args
eval[APPLYCLO] = function(t,env)
    -- t[2] =  {CLOSXP, arity, formals, body, cloenv}
  local numargs = #t - 2
  local closure = t[2]
  local arity, formal, body, cloenv = 
        closure[2], closure[3], closure[4], closure[5]
  if numargs < arity then
    error("Closure called with too few arguments.",2)
  elseif numargs > arity then 
    error("Closure called with too many arguments.",2)
  end

  -- new local environment frame for arguments extends closure frame
  local localEnv = newEnv(cloenv)
  for i = 3, #t do
    local val = doeval(t[i],env)  -- evaluate arg in caller frame
    local var = formal[i-2]    
    assign(var,val,localEnv)      -- assign to formal in local frame
  end
  return doeval(body,localEnv)    -- eval body in local frame
  -- if body includes a lambda, then localEnv captured in its closure frame
end

-- END change/add for Scheme

-- Evaluate t = {APPLYOP, operator, arg1, arg2, ...}
eval[APPLYOP] = function(t,env)
  -- BEGIN change/add for Scheme
  -- return doeval(t,env,2) -- dispatch again on builtin operator
  local newt
  if #t > 1 then
    local op = doeval(t[2],env) -- valueop or closure or ???
    if hasOpCode(op,PRIMSXP) then
      newt = { unpack(t) }
      newt[2] = getPrim(t[2])
      return doeval(newt,env,2) -- dispatch again on builtin operator
    elseif hasOpCode(op,CLOSXP) then
      newt = { unpack(t) }
      newt[1] = APPLYCLO
      newt[2] = doeval(t[2],env)
      return doeval(newt,env) -- dispatch again on closure
    else
      error("Attempt to apply invalid operator " .. tostring(op),2)
    end
  else
    error("Invalid APPLYOP instruction " .. treeConcat(t), 2)
  end
  -- END change/add for Scheme
end


-- Functions for the builtin binary operators on numbers

-- Function "evalArithOp" takes an arithmetic operator function "op"
-- and a string "disp" giving how to display the operator. It returns
-- an evaluation function that evaluates the corresponding value
-- operator in the given environment.

local function evalArithOp(op,disp)
  local msg1  = disp .. " operation requires 2 arguments."
  local msg2  = disp .. " applied to nonnumeric values "
  local arith = function(t,env)
    assert(#t == 4, msg1)
    local left, right = doeval(t[3],env), doeval(t[4],env)
    -- BEGIN change/add for Lisp
    -- return op(left,right)
    if hasOpCode(left,NUMSXP) and hasOpCode(right,NUMSXP) then
      return { NUMSXP, op(getNum(left),getNum(right)) }
    else
      error(msg2 .. treeConcat(t[3]) .. " and " .. 
            treeConcat(t[4]) .. ".")
    end
    -- END change/add for Lisp
  end
  return arith
end 

-- Lua's numbers are all double floating point numbers.  Function
-- "roundTowardZero" is used to round results of division to give the
-- usual truncating integer division result.

local function roundTowardZero(i) 
  if i < 0 then 
    return math.ceil(i) 
  else
    return math.floor(i) 
  end 
end

-- Functions for the arithmetic operators
local add = function(l,r) return l + r end
local sub = function(l,r) return l - r end
local mul = function(l,r) return l * r end
local div = function(l,r) return roundTowardZero(l / r) end

-- Evaluate t = {APPLYOP, arithmetic_op, expr1, expr2}
eval[ADDOP] = evalArithOp(add,"+")
eval[SUBOP] = evalArithOp(sub,"-")
eval[MULOP] = evalArithOp(mul,"*")
eval[DIVOP] = evalArithOp(div,"*")


-- Functions for builtin relational operators

-- Function "evalRelOp" takes an relational operator function "op" and
-- a string "disp" giving how to display the operator. It returns a
-- "boolean" function that evaluates the corresponding value operator
-- in the given environment.

local function evalRelOp(op,disp)
  local msg1  = disp .. " comparison requires 2 arguments."
  local order = function(t,env)
    assert(#t == 4, msg1)
    local left, right = doeval(t[3],env), doeval(t[4],env)
    -- BEGIN change/add for Lisp
    left, right = getNum(left), getNum(right)
    -- END change for Lisp
    return boolAsVal(op(left,right))
  end
  return order
end 

-- Functions for the relational operators
local function lt(l,r) return l < r end
local function gt(l,r) return l > r end

-- Evaluate t = {APPLYOP, relational_op, expr1, expr2}
eval[LTOP] = evalRelOp(lt,"<")
eval[GTOP] = evalRelOp(gt,">")

-- BEGIN change for Lisp
-- Equality comparison is more general than < and >

-- local function eq(l,r) return l == r end
-- eval[EQOP] = evalRelOp(eq,"=")

eval[EQOP] = function(t,env)
  assert(#t == 4, "= operation requires 2 arguments.")
  local left, right = doeval(t[3],env), doeval(t[4],env)
  if hasOpCode(left,NUMSXP) and hasOpCode(right,NUMSXP) then
    return boolAsVal(getNum(left) == getNum(right))
  elseif hasOpCode(left,SYMSXP) and hasOpCode(right,SYMSXP) then
    return boolAsVal(getSym(left) == getSym(right))
  elseif hasOpCode(left,NILSXP) and hasOpCode(right,NILSXP) then 
    return TRUEVAL
  else
    return FALSEVAL
  end 
end

-- END change for Lisp

-- Evaluate t = {PRINTOP, expression}
eval[PRINTOP] = function(t,env)
  assert(#t == 3, "print operation requires 1 argument.")
  local res = doeval(t[3],env)
  print(valToString(res))  -- SIDE EFFECT
  return res
end

-- BEGIN add for Lisp

-- Evaluate t = {APPLYOP,CONSOP,expr1,expr2}
eval[CONSOP] = function(t,env)
  assert(#t == 4, "cons operation requires 2 arguments.")
  local head, tail = doeval(t[3],env), doeval(t[4],env)
  return cons(head,tail)
end

-- Function "deconsList" takes a unary list deconstruction "operator"
-- "op" and a string "disp" giving how to display the operator.  It
-- returns an evaluation function that evaluates value operations of
-- that type in the given environment.

local function deconsList(op,disp)
  local msg1 = disp .. " operation requires 1 argument."
  local oplist = function(t,env)
    assert(#t == 3, msg1)
    local val = doeval(t[3],env)
    return op(val)
  end
  return oplist
end
  
-- Evaluate t = {APPLYOP,list_operation,expr1}
eval[CAROP] = deconsList(car,"car")
eval[CDROP] = deconsList(cdr,"cdr")

-- Function "testVal" takes an "opcode" and a string "disp" giving how
-- to display that operator.  It returns a boolean evaluation function
-- that evaluates value operations of that type in the given
-- environment.

local function testVal(opcode,disp)
  local msg1 = disp .. " operation requires 1 argument."
  local relop = function(t,env)
    assert(#t == 3, msg1)
    local val = doeval(t[3],env)
    return boolAsVal(hasOpCode(val,opcode))
  end
  return relop
end

-- Evaluate t = {APPLYOP,predicate,expr1}
eval[NUMBERPOP]  = testVal(NUMSXP,"number?")
eval[SYMBOLPOP]  = testVal(SYMSXP,"symbol?")
eval[NULLPOP]    = testVal(NILSXP,"null?")
eval[LISTPOP]    = testVal(LISTSXP,"list?")

-- END add for Lisp

-- BEGIN add for Scheme

-- Evaluate t = {APPLYOP,predicate,expr1}
eval[PRIMOPPOP]  = testVal(PRIMSXP,"primop?")
eval[CLOSUREPOP] = testVal(CLOSXP,"closure?")

-- END add for Scheme


-- MODULE EXPORT LIST

return {
  evalScript    = evalScript
}