vcmi/scripts/lib/verm.lua

local _G=_G
local ipairs=ipairs
local select=select
local pairs=pairs
local type = type
local unpack=unpack
local logError = logError

local DATA = DATA

--/////////////////////////

local function table_print (tt, done)
  done = done or {}
  if type(tt) == "table" then
    local sb = {}
    table.insert(sb, "{");
    for key, value in pairs (tt) do
      if type (value) == "table" and not done [value] then
        done [value] = true
        table.insert(sb, key .. ":{");
        table.insert(sb, table_print (value, done))
        table.insert(sb, "}");
      else
        table.insert(sb, string.format(
            "%s:\"%s\"", tostring (key), tostring(value)))
       end
       table.insert(sb, ",");
    end
    table.insert(sb, "}");

    m = getmetatable(tt);
    if m and m.__index then
		table.insert(sb, table_print (m.__index, done));
    end

    return table.concat(sb)
  else
    return tt .. ""
  end
end

local function to_string( tbl )
    if  "nil"       == type( tbl ) then
        return tostring(nil)
    elseif  "table" == type( tbl ) then
        return table_print(tbl)
    elseif  "string" == type( tbl ) then
        return tbl
    else
        return tostring(tbl)
    end
end

--/////////////////////////

local VERM = {}

local function createEnv(parent, current)
	return setmetatable(
		current or {},
		{
			__parent = parent,
			__index = parent,
			__newindex = function(t, k ,v)
				if type(k) ~= "string" then
					error("String key for env. table required, but got:"..to_string(k))
				end

				local function setOnFirstHit(t, k, v)
					local vv = rawget(t, k)
					if vv~= nil then rawset(t, k, v); return true end

					local m = getmetatable(t)

					if not m then return false end --assume top

					local p = m.__parent

					if not p then
						return false
					else
						return setOnFirstHit(p, k, v)
					end
				end

				if not setOnFirstHit(t, k, v) then
					rawset(t, k, v)
				end
			end
		}
	)
end

local function isNIL(v)
	return (type(v) == "table") and (next(v) == nil)
end

local function prognForm(e, ...)
	--eval each argument, return last result

	local argc = select('#',...)

	if argc == 0 then return {}	end

	for n = 1, argc - 1 do
		VERM:eval(e, (select(n,...)))
	end

	return VERM:eval(e, (select(argc,...)))
end

local function lambdaOrMacro(e, isMacro, args, ...)

	--TODO: get rid of pack-unpack
	local body = {...}
	local oldEnv = e

	local ret = function(e, ...)

	-- we need a function that have parameters with names from `args` table
	-- pack parameters from '...' and bind to new environment

		local newEnv = createEnv(oldEnv, {})

		for i, v in ipairs(args) do
			local p = select(i,...)
			if isMacro then
				newEnv[v] = p
			else
				newEnv[v] = VERM:evalValue(e, p)
			end
		end
		if isMacro then
			local buffer = {}
			for _, v in ipairs(body) do
				table.insert(buffer, (VERM:eval(newEnv, v)))
			end
			return prognForm(newEnv, unpack(buffer))
		else
			return prognForm(newEnv, unpack(body))
		end

	end

	return ret
end

local function lambdaForm(e, args, ...)
	return lambdaOrMacro(e, false, args,  ...)
end

local function defunForm(e, name, args, ...)
	local ret = lambdaOrMacro(e, false, args, ...)
	e[name] = ret
	return ret
end

local function defmacroForm(e, name, args, ...)
	local ret = lambdaOrMacro(e, true, args, ...)
	e[name] = ret
	return ret
end

local function backquoteEval(e, v)
	if isNIL(v) then
		return v
	elseif type(v) == "table" then
		local car = v[1]

		if car == "," then
			return VERM:evalValue(e, v[2])
		else
			local ret = {}

			for _, v in ipairs(v) do
				table.insert(ret, (backquoteEval(e, v)))
			end
			return ret
		end
	else
		return v
	end
end

local specialForms =
{
	["<"] = function(e, lhs, rhs)
		lhs = VERM:evalValue(e, lhs)
		rhs = VERM:evalValue(e, rhs)
		if lhs < rhs then
			return lhs
		else
			return {}
		end
	end,
	["<="] = function(e, lhs, rhs)
		lhs = VERM:evalValue(e, lhs)
		rhs = VERM:evalValue(e, rhs)
		if lhs <= rhs then
			return lhs
		else
			return {}
		end
	end,
	[">"] = function(e, lhs, rhs)
		lhs = VERM:evalValue(e, lhs)
		rhs = VERM:evalValue(e, rhs)
		if lhs > rhs then
			return lhs
		else
			return {}
		end
	end,
	[">="] = function(e, lhs, rhs)
		lhs = VERM:evalValue(e, lhs)
		rhs = VERM:evalValue(e, rhs)
		if lhs >= rhs then
			return lhs
		else
			return {}
		end
	end,
	["="] = function(e, lhs, rhs)
		lhs = VERM:evalValue(e, lhs)
		rhs = VERM:evalValue(e, rhs)
		if lhs == rhs then
			return lhs
		else
			return {}
		end
	end,
	["+"] = function(e, ...)
		local ret = 0
		for n=1,select('#',...) do
			local v = VERM:evalValue(e, (select(n,...)))
			ret = ret + v
		end
		return ret
	end,
	["*"] = function(e, ...)
		local ret = 1
		for n=1,select('#',...) do
			local v = VERM:evalValue(e, (select(n,...)))
			ret = ret * v
		end
		return ret
	end,
	["-"] = function(e, lhs, rhs)
		lhs = VERM:evalValue(e, lhs)
		rhs = VERM:evalValue(e, rhs)
		return lhs - rhs
	end,
	["/"] = function(e, lhs, rhs)
		lhs = VERM:evalValue(e, lhs)
		rhs = VERM:evalValue(e, rhs)
		return lhs / rhs
	end,
	["%"] = function(e, lhs, rhs)
		lhs = VERM:evalValue(e, lhs)
		rhs = VERM:evalValue(e, rhs)
		return lhs % rhs
	end,
--	["comma-unlist"] = function(e, ...) end,
	["`"] = backquoteEval,
--	["get-func"] = function(e, ...) end,
	["'"] = function(e, v)
		return v
	end,
	["if"] = function(e, cond, v1, v2)
		cond = VERM:evalValue(e, cond)

		if isNIL(cond) then
			return VERM:evalValue(e, v2)
		else
			return VERM:evalValue(e, v1)
		end
	end,
--	["set"] = function(e, ...) end,
--	["setf"] = function(e, ...) end,
	["setq"] = function(e, name, value)
		e[name] = VERM:evalValue(e, value)
	end,
	["lambda"] = lambdaForm,
	["defun"] = defunForm,
	["progn"] = prognForm,
	["defmacro"] = defmacroForm,
	["do"] = function(e, cond, body)
		local c = VERM:eval(e, cond)
		while not isNIL(c) do
			VERM:eval(e, body)
			c = VERM:eval(e, cond)
		end
		return {}
	end,
	["car"] = function(e, list)
		list = VERM:eval(e, list)
		return list[1] or {}
	end,
	["cdr"] = function(e, list)
		list = VERM:eval(e, list)
		local ret = {}
		for i, v in ipairs(list) do
			if i > 1 then
				table.insert(ret, v)
			end
		end

		return ret
	end,
	["list"] = function(e, ...)
		local ret = {}
		for n=1,select('#',...) do
			local v = VERM:evalValue(e, (select(n,...)))
			table.insert(ret, v)
		end

		return ret
	end,
	["setq-erm"] = function(e, var, varIndex, value)
		local v = VERM:evalValue(e, value)
		DATA.ERM[var][tostring(VERM:evalValue(e, varIndex))] = v
		return v
	end,
}

function VERM:evalValue(e, v)
	if isNIL(v) then
		return v
	elseif type(v) == "table" then
		return self:eval(e, v)
	elseif type(v) == "string" then
		return e[v]
	elseif type(v) == "function" then
		error("evalValue do not accept functions")
	else
		return v
    end
end

function VERM:eval(e, t)
	if type(t) ~= "table" then
		logError("Not valid form: ".. to_string(t))
		return {}
	end

	local car = t[1]
	local origCar = car

	if type(car) == "string" then
		car = e[car]
	end

	if type(car) == "table" then
		car = self:eval(e, car)
	end

	if type(car) == "function" then
		return car(e, unpack(t,2))
	else
		logError(to_string(t) .. " is not callable. Car()="..to_string(car))
		logError("Env:"..to_string(e))
		return {}
	end
end

function VERM:E(line)
	self:eval(self.topEnv, line)
end

VERM.topEnv = createEnv(specialForms)

return VERM