--- lam.eval

local m = {}
local type = require("type")
local assert_arity = type.assert_arity
local util = require("util")
local error = util.error

m.primitives = {
	quote =
		function (r, _)
			assert_arity(r,1,1)
			return r[1]
		end,
	quasiquote =
		function (r, e)
			assert_arity(r,1,1)
			local x = r[1]
			if not type.listp(x) or type.nullp(x) then
				return x
			end
			local QQ, fin = {}, nil
			while x[2] do
				if type.listp(x[1]) then
					if x[1][1] == "unquote" then
						table.insert(QQ,
							m.eval(x[1][2][1], e))
					elseif x[1][1] == "unquote-splicing"
					then
						local y = m.eval(x[1][2][1], e)
						if not type.listp(y) then
							fin = y
							break
						end
						while y[2] do
							table.insert(QQ, y[1])
							y = y[2]
						end
					end
				else
					table.insert(QQ, x[1])
				end
				x = x[2]
			end
			return type.list(QQ, fin)
		end,
	unquote =
		function (_, _)
			error("unexpected", ",")
		end,
	["unquote-splicing"] =
		function (_, _)
			error("unexpected", ",@")
		end,
	define =
		function (r, e)
			assert_arity(r,2,2)
			rawset(e, r[1], m.eval(r[2][1], e))
		end,
	["set!"] =
		function (r, e)
			assert_arity(r,2,2)
			e[r[1]] = m.eval(r[2][1], e)
		end,
	lambda =
		function (r, e)
			assert_arity(r,2)
			return type.procedure(r[1], r[2], e, m.eval)
		end,
	["if"] =
		function (r, e)
			assert_arity(r,2,3)
			local test, conseq, alt = r[1], r[2][1], r[2][2][1]
			if m.eval(test, e)
			then return m.eval(conseq, e)
			else return m.eval(alt, e)
			end
		end,
	-- TODO: include, import, define-syntax ...
}

function m.eval (x, env)
	if type.isp(x, "symbol") then
		if env[x] == nil then
			error("unbound symbol", x)
		end
		return env[x]
	elseif not type.listp(x) then
		return x
	else
		local op, args = x[1], x[2]
		if m.primitives[op] then
			return m.primitives[op](args, env)
		else -- procedure application
			local fn = m.eval(op, env)
			local params = {}
			local r = args
			while r[2] do
				table.insert(params, m.eval(r[1], env))
				r = r[2]
			end
			return fn(type.list(params))
		end
	end
end

--------
return m