about summary refs log tree commit diff stats
path: root/eval.lua
blob: e3e21c3be318375cfe4fa1633b3947a8f6c01a89 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
--- lam.eval

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

function m.environ (inner, outer)
	local mt = {
		__type = "environment",
		__index = outer,
		__newindex =
			function (self, key, val)
				if rawget(self, key) then
					rawset(self, key, val)
				else
					getmetatable(self).__index[key] = val
				end
			end,
	}
	return setmetatable(inner, mt)
end

local function procedure_call (proc, r)
	local function doargs (p, r, e)
		if p == type.null and r == type.null then return e end
		if type.isa(p, "symbol") then
			e[p] = r
			return e
		end
		if p[1] == nil then error("Too many arguments") end
		if r[1] == nil then error("Too few arguments") end
		e[p[1]] = r[1]
		doargs(p[2], r[2], e)
	end

	local e = doargs(proc.params, r, m.environ({}, proc.env))
	local b = proc.body
	while b[2] ~= type.null do
		m.eval(b[1], e)
		b = b[2]
	end
	return m.eval(b[1], e)
end

function m.procedure (params, body, env)
	local t = {
		params = params,
		body = body,
		env = env,
	}
	local mt = {
		__type = "procedure",
		__call = procedure_call,
	}
	return setmetatable(t, mt)
end

local function handle_quasiquote (r, e)
	assert_arity(r, 1, 1)
	local x = r[1]
	if not type.islist(x) or x == type.null then
		return x
	end
	local QQ, fin = {}, nil
	local car, cdr = x[1], x[2]
	while cdr do
		if type.islist(car) then
			if car[1] == "unquote" then
				table.insert(QQ, m.eval(car[2][1], e))
			elseif car[1] == "unquote-splicing" then
				local usl = m.eval(car[2][1], e)
				if not type.islist(usl) then
					fin = usl
					break
				end
				while usl[2] do
					table.insert(QQ, usl[1])
					usl = usl[2]
				end
			end
		else
			table.insert(QQ, car)
		end
		car, cdr = cdr[1], cdr[2]
	end
	return type.list(QQ, fin)
end

m.specials = {
	-- each of these takes R (a list of args) and E (an environment)
	quote =
		function (r, e)
			assert_arity(r, 1, 1)
			return r[1]
		end,
	quasiquote = handle_quasiquote,
	-- if not inside quasiquote, unquote and unquote-splicing are errors
	unquote = function () error("Unexpected unquote") end,
	["unquote-splicing"] =
		function () error("Unexpected unquote-splicing") end,
	-- define variables
	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,
	-- y'know, ... lambda
	lambda =
		function (r, e)
			assert_arity(r, 2)
			return m.procedure(r[1], r[2], e)
		end,
	-- control flow
	["if"] =
		function (r, e)
			assert_arity(r, 3, 3)
			local test, conseq, alt =
				r[1], r[2][1], r[2][2][1]
			if m.eval(test)
			then return m.eval(conseq)
			else return m.eval(alt)
			end
		end,
	-- TODO: include, import, define-syntax, ...
}
-- Aliases
m.specials.lam = m.specials.lambda
m.specials.def = m.specials.define

function m.eval (x, env)
	local env = env or core.env
	if type.isa(x, "symbol") then
		if env[x] == nil then
			error(string.format("Unbound variable: %s", x))
		end
		return env[x]
	elseif not type.islist(x) then
		return x
	else
		local op, args = x[1], x[2]
		if m.specials[op] then
			return m.specials[op](args, env)
		else		-- procedure call
			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