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
|
--- lam.core --- core procedures
local dump = require("dump")
local type = require("type")
local null = type.null
local assert_arity = type.assert_arity
local function fold (kons, knil, r)
if r == null then
return knil
else
local step, early_return = kons(r[1], knil)
if early_return then return early_return end
return fold(kons, step, r[2])
end
end
local env = {}
---[[ EQUIVALENCE ]]---
env["eqv?"] = function (r)
assert_arity(r,2,2)
return r[1] == r[2][1]
end
-- from what i understand of the spec, it's okay that eqv? and eq? are the same
env["eq?"] = env["eqv?"]
---[[ TYPES ]]---
env["boolean?"] = function (r)
assert_arity(r,1,1)
return r[1] == false or r[1] == true
end
env["port?"] = function (r)
assert_arity(r,1,1)
return type.isp(r[1], "input-port") or type.isp(r[1], "output-port")
end
for _, t in ipairs {
"symbol",
-- todo: vector
"procedure",
"pair",
"number",
"string",
"port",
} do
env[t.."?"] = function (r)
assert_arity(r,1,1)
return type.isp(r[1], t)
end
end
---[[ NUMBERS ]]---
env["="] = function (r)
if r[1] == nil then return true end
if r[2] == nil then return true end
while r[2] ~= null do
if r[1] ~= r[2][1] then return false end
r = r[2]
end
return true
end
env["<"] = function (r)
if r[1] == nil then return true end
if r[2] == nil then return true end
while r[2] ~= null do
if r[1] >= r[2][1] then return false end
r = r[2]
end
return true
end
env[">"] = function (r)
if r[1] == nil then return true end
if r[2] == nil then return true end
while r[2] ~= null do
if r[1] <= r[2][1] then return false end
r = r[2]
end
return true
end
env["<="] = function (r) return not env[">"](r) end
env[">="] = function (r) return not env["<"](r) end
env["+"] = function (r)
return fold(function (a, b) return a + b end, 0, r)
end
env["-"] = function (r)
if r == null then return -1 end
if r[2] == null then return (- r[1]) end
return fold(function (a, b)
return a - b
end, r[1], r[2])
end
env["*"] = function (r)
local function go (a, b)
if a == 0 or b == 0 then
return 0, 1
end
return a * b
end
return fold(go, 1, r)
end
env["/"] = function (r)
assert_arity(r,1)
if r[2] == null then return (1 / r[1]) end
return fold(function (a, b) return a / b end,
r[1], r[2])
end
---[[ INPUT / OUTPUT ]]---
env.dump = function (r)
assert_arity(r,1,1)
return dump.dump(r[1])
end
env.display = function (r)
assert_arity(r,1,1)
io.write(tostring(r[1]))
io.flush()
end
env.newline = function (r)
assert_arity(r,0,0)
io.write("\n")
io.flush()
end
--------
return {
environment = env,
}
|
