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
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
|
--- lam.type
-- this library implements lam types---atomic and collection---and type
-- predicates. it also re-exports lua's `type` as type.luatype and implements
-- `type.lamtype`. types are implemented as functions to build the given type
-- from some arguments. their metatables contain various metamethods, but also
-- `__type`.
local m = {}
local utf8 = require("utf8")
local util = require("util")
local tochars, error, constantly = util.tochars, util.error, util.constantly
---[[ ATOMIC TYPES ]]---
-- a lam symbol is a lua string
m.symbol = tostring
-- a lam number is a lua number
-- TODO: implement full numeric tower
m.number = tonumber
-- a character is a wrapped single-character string
-- it contains both the string representation and the character's codepoint
m.character_names = {
-- some characters, like whitespace, have names
["\n"] = "newline",
[" "] = "space",
["\t"] = "tab",
}
function m.character (x)
local s = tostring(x)
local uc = utf8.codepoint(s)
local t = {
v = utf8.char(uc),
u = uc,
}
local mt = {
__type = "char", -- scheme name
-- compare using codepoints since they're just numbers
__eq = function (a, b) return a.u == b.u end,
__lt = function (a, b) return a.u < b.u end,
__tostring =
function (self)
local v = self.v
if m.character_names[v] then
v = m.character_names[v]
end
return "#\\" .. v
end,
}
return setmetatable(t, mt)
end
---[[ PROCEEDURES AND ENVIRONMENTS ]]---
function m.environment (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,
__tostring = constantly("#<environment>"),
}
return setmetatable(inner, mt)
end
function m.procedure (params, body, env, eval)
local t = {
params = params,
body = body,
env = env,
eval = eval,
}
local mt = {
__type = "procedure",
__tostring =
function (self)
return string.format("(lambda %s %s)",
params,
tostring(body):sub(2, -2))
end,
__call =
function (self, r)
local rlen = #r
local function doargs (p, r, e)
-- base case
if m.nullp(p) and m.nullp(r) then
return e
end
-- (lambda x ..) or (lambda (x . y) ..)
if type.isp(p, "symbol") then
e[p] = r
return e
end
if p[1] == nil then
error("too many arguments",
rlen, #self.params)
end
if r[1] == nil then
error("too few arguments",
rlen, #self.params)
end
-- bind car(p) to car(r)
e[p[1]] = r[1]
-- recurse
return doargs(p[2], r[2], e)
end
-- create new, expanded environment
e = doargs(self.params, r,
m.environment({}, self.env))
local b = self.body
-- evaluate body forms
while not m.nullp(b[2]) do
self.eval(b[1], e)
b = b[2]
end
-- return last body form
return self.eval(b[1], e)
end,
}
return setmetatable(t, mt)
end
function m.assert_arity (r, min, max)
local rmin = min or 0
local rmax = max or 1/0 -- infinity
local rlen = #r
if rlen < rmin or rlen > rmax then
error("wrong arity", rlen, m.cons(rmin, rmax))
end
end
---[[ NULL ]]---
-- The empty list () is the only object that is both an atom and a list. It
-- forms the ultimate tail of every "proper" list. The important thing is that
-- it's its own object.
m.null = setmetatable({}, {
__type = "null",
__tostring = function () return "()" end,
})
function m.nullp (x)
return x == m.null
end
---[[ COLLECTION TYPES ]]---
-- cons are lisp's fundamental collection type: they link two things together in
-- a structure
function m.cons (a, b)
local t = { a, b, }
local mt = {
__type = "pair", -- scheme name
__tostring =
function (self)
local t, p = {}, self
while p[2] do
table.insert(t, tostring(p[1]))
if m.luatype(p[2]) == "table" then
p = p[2]
else
table.insert(t, ".")
table.insert(t, p[2])
break
end
end
return string.format("(%s)",
table.concat(t, " "))
end,
__len =
function (self)
local function go (x, acc)
-- improper lists don't have lengths
if not m.isp(x, "pair") then
return nil
end
if m.nullp(x[2]) then
return acc
else
return go(x[2], acc + 1)
end
end
return go(self, 1)
end,
}
return setmetatable(t, mt)
end
-- a series of cons cells linked together is a list
function m.list (items, final)
-- ITEMS is a table of items to turn into a list, and FINAL is an
-- optional final cdr. If it's nil, the list is a "proper" list,
-- i.e. it ends in (); otherwise, it's an "improper" list.
local function tolist (base, items)
if #items == 0 then return base end
return tolist(m.cons(table.remove(items), base), items)
end
return tolist(final or m.null, items)
end
-- strings are vectors of chars
function m.string (x)
local t = tochars(tostring(x))
local mt = {
__type = "string",
__tostring =
function (self)
local esc =
table.concat(self):
gsub("[\\\"]", "\\%1")
return string.format("\"%s\"", esc)
end,
}
return setmetatable(t, mt)
end
---[[ TYPE DETECTION AND PREDICATES ]]---
-- to avoid name clashes, `type` is saved in type.luatype
m.luatype = type
-- return the lam type of a given expression
function m.lamtype (x)
if getmetatable(x) and getmetatable(x).__type then
return getmetatable(x).__type
elseif m.luatype(x) == "string" then
return "symbol"
else
return m.luatype(x)
end
end
--- Predicates are named with a `p', lisp-style
-- is X of type T ?
function m.isp (x, t)
return m.lamtype(x) == t
end
-- is X a "proper" list?
function m.listp (x)
-- take advantage of cons' __len operator, but since it returns a
-- number, convert that to a bool
if m.isp(x, "pair") and #x
then return true
else return false
end
end
-- according to CHICKEN, `atom?' returns #t if X is not a pair (cons)
function m.atomp (x)
return not m.isp(x, "pair")
end
--[[ CONVERTING BACK TO LUA TYPES ]]--
-- convert a cons back to a table
-- this doesn't special-case for proper/improper lists
function m.totable (cons)
local t, p = {}, cons
while p[2] do
table.insert(t, p[1])
if m.isp(p[2]) == "pair" then
p = p[2]
else
table.insert(t, p[2])
end
end
return t
end
--------
return m
|