diff options
Diffstat (limited to 'type.lua')
-rw-r--r-- | type.lua | 244 |
1 files changed, 172 insertions, 72 deletions
diff --git a/type.lua b/type.lua index 6dbf313..79f42a6 100644 --- a/type.lua +++ b/type.lua | |||
@@ -53,92 +53,97 @@ function m.character (x) | |||
53 | return setmetatable(t, mt) | 53 | return setmetatable(t, mt) |
54 | end | 54 | end |
55 | 55 | ||
56 | ---[[ PROCEEDURES AND ENVIRONMENTS ]]--- | 56 | ---[[ INPUT PORTS ]]--- |
57 | 57 | ||
58 | function m.environment (inner, outer) | 58 | local function tochars (str) |
59 | local mt = { | 59 | local cs = {} |
60 | __type = "environment", | 60 | for _, code in utf8_codes(str) do |
61 | __index = outer, | 61 | table.insert(cs, code) |
62 | __newindex = | 62 | end |
63 | function (self, key, val) | 63 | return cs |
64 | if rawget(self, key) then | 64 | end |
65 | rawset(self, key, val) | 65 | |
66 | else | 66 | -- return the next token from PORT, given READTABLE |
67 | getmetatable(self).__index[key] = val | 67 | local function input_port_next_token (port, readtable) |
68 | repeat | ||
69 | if #port.buffer == 0 then | ||
70 | if port.file then | ||
71 | local ln = port.file:read() | ||
72 | if ln == nil then | ||
73 | return m.eof | ||
68 | end | 74 | end |
69 | end, | 75 | port.buffer = tochars(ln) |
70 | __tostring = constantly("#<environment>"), | 76 | else |
71 | } | 77 | return m.eof |
72 | return setmetatable(inner, mt) | 78 | end |
79 | end | ||
80 | |||
81 | local token, token_type | ||
82 | local c = port.buffer[1] | ||
83 | if readtable.chars[c] then | ||
84 | token, token_type, port.buffer = | ||
85 | readtable.chars[c](port.buffer) | ||
86 | else | ||
87 | for re, fn in pairs(readtable.regex) do | ||
88 | if c:match(re) then | ||
89 | token, token_type, port.buffer = | ||
90 | fn(port.buffer) | ||
91 | break | ||
92 | end | ||
93 | end | ||
94 | if token == nil then | ||
95 | token, token_type, port.buffer = | ||
96 | readtable.default(port.buffer) | ||
97 | end | ||
98 | end | ||
99 | |||
100 | port.buffer = port.buffer or {} | ||
101 | if token then | ||
102 | return token, token_type | ||
103 | end | ||
104 | until nil | ||
73 | end | 105 | end |
74 | 106 | ||
75 | function m.procedure (params, body, env, eval) | 107 | function m.input_port (source, source_type) |
108 | -- SOURCE is the name of the file/string to read or nil; nil means | ||
109 | -- standard input. SOURCE_TYPE is one of "file", "string"; "file" is | ||
110 | -- the default. | ||
111 | local f, b | ||
112 | source_type = source_type or "file" | ||
113 | if source then | ||
114 | if source_type == "file" then | ||
115 | f = io.open(source, "r") | ||
116 | elseif source_type == "string" then | ||
117 | b = tochars(source) | ||
118 | else | ||
119 | error("input-port: bad type", source_type) | ||
120 | end | ||
121 | else | ||
122 | f = io.input() -- ignore SOURCE_TYPE | ||
123 | end | ||
76 | local t = { | 124 | local t = { |
77 | params = params, | 125 | file = f, |
78 | body = body, | 126 | name = f and source or "[string]", |
79 | env = env, | 127 | type = source_type, |
80 | eval = eval, | 128 | buffer = b or {}, |
129 | flush = function (self) self.buffer = {} end, | ||
130 | next = input_port_next_token, -- port:next(readtable) | ||
131 | close = | ||
132 | function (self) | ||
133 | if self.file then self.file:close() end | ||
134 | end, | ||
81 | } | 135 | } |
82 | local mt = { | 136 | local mt = { |
83 | __type = "procedure", | 137 | __type = "input-port", |
84 | __tostring = | 138 | __tostring = |
85 | function (self) | 139 | function (self) |
86 | return string.format("(lambda %s %s)", | 140 | return string.format("#<port %s>", self.name) |
87 | params, | ||
88 | tostring(body):sub(2, -2)) | ||
89 | end, | ||
90 | __call = | ||
91 | function (self, r) | ||
92 | local rlen = #r | ||
93 | local function doargs (p, r, e) | ||
94 | -- base case | ||
95 | if m.nullp(p) and m.nullp(r) then | ||
96 | return e | ||
97 | end | ||
98 | -- (lambda x ..) or (lambda (x . y) ..) | ||
99 | if type.isp(p, "symbol") then | ||
100 | e[p] = r | ||
101 | return e | ||
102 | end | ||
103 | if p[1] == nil then | ||
104 | error("too many arguments", | ||
105 | rlen, #self.params) | ||
106 | end | ||
107 | if r[1] == nil then | ||
108 | error("too few arguments", | ||
109 | rlen, #self.params) | ||
110 | end | ||
111 | -- bind car(p) to car(r) | ||
112 | e[p[1]] = r[1] | ||
113 | -- recurse | ||
114 | return doargs(p[2], r[2], e) | ||
115 | end | ||
116 | -- create new, expanded environment | ||
117 | e = doargs(self.params, r, | ||
118 | m.environment({}, self.env)) | ||
119 | local b = self.body | ||
120 | -- evaluate body forms | ||
121 | while not m.nullp(b[2]) do | ||
122 | self.eval(b[1], e) | ||
123 | b = b[2] | ||
124 | end | ||
125 | -- return last body form | ||
126 | return self.eval(b[1], e) | ||
127 | end, | 141 | end, |
128 | } | 142 | } |
129 | return setmetatable(t, mt) | 143 | return setmetatable(t, mt) |
130 | end | 144 | end |
131 | 145 | ||
132 | function m.assert_arity (r, min, max) | 146 | ---[[ NULL(S) ]]--- |
133 | local rmin = min or 0 | ||
134 | local rmax = max or 1/0 -- infinity | ||
135 | local rlen = #r | ||
136 | if rlen < rmin or rlen > rmax then | ||
137 | error("wrong arity", rlen, m.cons(rmin, rmax)) | ||
138 | end | ||
139 | end | ||
140 | |||
141 | ---[[ NULL ]]--- | ||
142 | -- The empty list () is the only object that is both an atom and a list. It | 147 | -- The empty list () is the only object that is both an atom and a list. It |
143 | -- forms the ultimate tail of every "proper" list. The important thing is that | 148 | -- forms the ultimate tail of every "proper" list. The important thing is that |
144 | -- it's its own object. | 149 | -- it's its own object. |
@@ -152,6 +157,17 @@ function m.nullp (x) | |||
152 | return x == m.null | 157 | return x == m.null |
153 | end | 158 | end |
154 | 159 | ||
160 | -- The EOF object is what the reader emits when it hits an end-of-file or use up | ||
161 | -- a port. | ||
162 | m.eof = setmetatable({}, { | ||
163 | __type = "eof", | ||
164 | __tostring = function () return "#<eof>" end, | ||
165 | }) | ||
166 | |||
167 | function m.eofp (x) | ||
168 | return x == m.eof | ||
169 | end | ||
170 | |||
155 | ---[[ COLLECTION TYPES ]]--- | 171 | ---[[ COLLECTION TYPES ]]--- |
156 | 172 | ||
157 | -- cons are lisp's fundamental collection type: they link two things together in | 173 | -- cons are lisp's fundamental collection type: they link two things together in |
@@ -231,6 +247,90 @@ function m.string (x) | |||
231 | return setmetatable(t, mt) | 247 | return setmetatable(t, mt) |
232 | end | 248 | end |
233 | 249 | ||
250 | ---[[ PROCEEDURES AND ENVIRONMENTS ]]--- | ||
251 | |||
252 | function m.environment (inner, outer) | ||
253 | local mt = { | ||
254 | __type = "environment", | ||
255 | __index = outer, | ||
256 | __newindex = | ||
257 | function (self, key, val) | ||
258 | if rawget(self, key) then | ||
259 | rawset(self, key, val) | ||
260 | else | ||
261 | getmetatable(self).__index[key] = val | ||
262 | end | ||
263 | end, | ||
264 | __tostring = function (_) return "#<environment>" end, | ||
265 | } | ||
266 | return setmetatable(inner, mt) | ||
267 | end | ||
268 | |||
269 | function m.procedure (params, body, env, eval) | ||
270 | local t = { | ||
271 | params = params, | ||
272 | body = body, | ||
273 | env = env, | ||
274 | eval = eval, | ||
275 | } | ||
276 | local mt = { | ||
277 | __type = "procedure", | ||
278 | __tostring = | ||
279 | function (self) | ||
280 | return string.format("#<procedure %s>", | ||
281 | self.params) | ||
282 | end, | ||
283 | __call = | ||
284 | function (self, r) | ||
285 | local rlen = #r | ||
286 | local function doargs (p, r, e) | ||
287 | -- base case | ||
288 | if m.nullp(p) and m.nullp(r) then | ||
289 | return e | ||
290 | end | ||
291 | -- (lambda x ..) or (lambda (x . y) ..) | ||
292 | if type.isp(p, "symbol") then | ||
293 | e[p] = r | ||
294 | return e | ||
295 | end | ||
296 | if p[1] == nil then | ||
297 | error("too many arguments", | ||
298 | rlen, #self.params) | ||
299 | end | ||
300 | if r[1] == nil then | ||
301 | error("too few arguments", | ||
302 | rlen, #self.params) | ||
303 | end | ||
304 | -- bind car(p) to car(r) | ||
305 | e[p[1]] = r[1] | ||
306 | -- recurse | ||
307 | return doargs(p[2], r[2], e) | ||
308 | end | ||
309 | -- create new, expanded environment | ||
310 | e = doargs(self.params, r, | ||
311 | m.environment({}, self.env)) | ||
312 | local b = self.body | ||
313 | -- evaluate body forms | ||
314 | while not m.nullp(b[2]) do | ||
315 | self.eval(b[1], e) | ||
316 | b = b[2] | ||
317 | end | ||
318 | -- return last body form | ||
319 | return self.eval(b[1], e) | ||
320 | end, | ||
321 | } | ||
322 | return setmetatable(t, mt) | ||
323 | end | ||
324 | |||
325 | function m.assert_arity (r, min, max) | ||
326 | local rmin = min or 0 | ||
327 | local rmax = max or 1/0 -- infinity | ||
328 | local rlen = #r | ||
329 | if rlen < rmin or rlen > rmax then | ||
330 | error("wrong arity", rlen, m.cons(rmin, rmax)) | ||
331 | end | ||
332 | end | ||
333 | |||
234 | ---[[ TYPE DETECTION AND PREDICATES ]]--- | 334 | ---[[ TYPE DETECTION AND PREDICATES ]]--- |
235 | 335 | ||
236 | -- to avoid name clashes, `type` is saved in type.luatype | 336 | -- to avoid name clashes, `type` is saved in type.luatype |