about summary refs log tree commit diff stats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Makefile19
-rw-r--r--Organization.txt8
-rw-r--r--core.lua241
-rw-r--r--dump.lua39
-rw-r--r--eval.lua171
-rw-r--r--load.lua68
-rw-r--r--port.lua103
-rw-r--r--read.lua380
-rw-r--r--repl.lua81
-rw-r--r--type.lua291
-rw-r--r--util.lua35
11 files changed, 767 insertions, 669 deletions
diff --git a/Makefile b/Makefile index 3495163..23d342f 100644 --- a/Makefile +++ b/Makefile
@@ -1,25 +1,22 @@
1LUA ?= rlwrap luajit \ 1LUA ?= rlwrap luajit \
2 -e 'pp = require("dump").pp' \ 2 -e 'core = require "core"' \
3 -e 'dump = require "dump"' \
3 -e 'eval = require "eval"' \ 4 -e 'eval = require "eval"' \
5 -e 'load = require "load"' \
6 -e 'port = require "port"' \
4 -e 'read = require "read"' \ 7 -e 'read = require "read"' \
8 -e 'repl = require "repl"' \
5 -e 'type = require "type"' \ 9 -e 'type = require "type"' \
6 -e 'utf8 = require "utf8"' \ 10 -e 'util = require "util"'
7 -e 'util = require "util"' \
8 -e 'test = require "test"' \
9 -e 'repl = require "repl"'
10 11
11.PHONY: luarepl 12.PHONY: luarepl
12luarepl: 13luarepl:
13 $(LUA) -i 14 $(LUA) -i
14 15
15.PHONY: repl 16.PHONY: lamrepl
16repl: 17lamrepl:
17 $(LUA) -e 'require("repl").repl("> ")' 18 $(LUA) -e 'require("repl").repl("> ")'
18 19
19.PHONY: test
20test:
21 $(LUA) -e 'test.runtests()'
22
23.PHONY: check 20.PHONY: check
24check: 21check:
25 luacheck *.lua 22 luacheck *.lua
diff --git a/Organization.txt b/Organization.txt new file mode 100644 index 0000000..b2872d5 --- /dev/null +++ b/Organization.txt
@@ -0,0 +1,8 @@
1
2utf8 type---.
3 | / \ \
4 read eval core(environment)
5 \ / |
6 load<----'
7 | (require "core"; core.env.load = m.load) ~ and other stuf i spose
8 repl
diff --git a/core.lua b/core.lua index fd78997..20c6b5c 100644 --- a/core.lua +++ b/core.lua
@@ -1,131 +1,138 @@
1--- lam.core --- core procedures 1--- lam.core --- core procedures
2 2
3local m = {} 3local dump = require("dump")
4local type = require "type" 4local type = require("type")
5local isa, null = type.isa, type.null 5local null = type.null
6local math = math 6local assert_arity = type.assert_arity
7local dump = require("dump").dump
8-- local load = require("repl").load -- circular dependency :<
9local util = require "util"
10local assert_arity = util.assert_arity
11 7
12local function fold (kons, knil, r) 8local function fold (kons, knil, r)
13 if r == null then 9 if r == null then
14 return knil 10 return knil
15 else 11 else
16 local step, early_return = kons(r[1], knil) 12 local step, early_return = kons(r[1], knil)
17 if early_return then return step end 13 if early_return then return early_return end
18 return fold(kons, step, r[2]) 14 return fold(kons, step, r[2])
19 end 15 end
20end 16end
21 17
22m.env = { -- all functions here take R, which is the list of arguments 18local env = {}
23 ------- equivalence 19
24 ["eqv?"] = 20---[[ EQUIVALENCE ]]---
25 function (r) 21
26 assert_arity(r, 2, 2) 22env["eqv?"] = function (r)
27 return r[1] == r[2][1] 23 assert_arity(r,2,2)
28 end, 24 return r[1] == r[2][1]
29 ["eq?"] = 25end
30 function (r) 26-- from what i understand of the spec, it's okay that eqv? and eq? are the same
31 assert_arity(r, 2, 2) 27env["eq?"] = env["eqv?"]
32 -- from how i understand the Scheme spec, it's okay to 28
33 -- make `eqv?' and `eq?' the same. 29---[[ TYPES ]]---
34 return r[1] == r[2][1] 30
35 end, 31env["boolean?"] = function (r)
36 -- equal? can be done in-library 32 assert_arity(r,1,1)
37 ------- i/o 33 return r[1] == false or r[1] == true
38 display = 34end
39 function (r) 35
40 assert_arity(r, 1, 1) 36env["port?"] = function (r)
41 io.write(tostring(r[1])) 37 assert_arity(r,1,1)
42 end, 38 return type.isp(r[1], "input-port") or type.isp(r[1], "output-port")
43 newline = 39end
44 function (r) 40
45 assert_arity(r, 0, 0) 41for _, t in ipairs {
46 io.write("\n") 42 "symbol",
47 end, 43 -- todo: vector
48 dump = 44 "procedure",
49 function (r) 45 "pair",
50 assert_arity(r, 1, 1) 46 "number",
51 return dump(r[1]) 47 "string",
52 end, 48 "port",
53 --[[ load = -- circular dependency :< 49} do
54 function (r) 50 env[t.."?"] = function (r)
55 assert_arity(r, 1, 1) 51 assert_arity(r,1,1)
56 load(r[1]) 52 return type.isp(r[1], t)
57 end, 53 end
58 --]] 54end
59 ------- numbers 55
60 -- todo: assert all of these are numbers 56---[[ NUMBERS ]]---
61 ["number?"] = 57
62 function (r) 58env["="] = function (r)
63 assert_arity(r, 1, 1) 59 if r[1] == nil then return true end
64 return isa(r[1], "number") 60 if r[2] == nil then return true end
65 end, 61 while r[2] ~= null do
66 ["="] = 62 if r[1] ~= r[2][1] then return false end
67 function (r) 63 r = r[2]
68 if r[1] == nil then return true end 64 end
69 if r[2] == nil then return true end 65 return true
70 while r[2] ~= null do 66end
71 if r[1] ~= r[2][1] then return false end 67
72 r = r[2] 68env["<"] = function (r)
73 end 69 if r[1] == nil then return true end
74 return true 70 if r[2] == nil then return true end
75 end, 71 while r[2] ~= null do
76 ["<"] = 72 if r[1] >= r[2][1] then return false end
77 function (r) 73 r = r[2]
78 if r[1] == nil then return true end 74 end
79 if r[2] == nil then return true end 75 return true
80 while r[2] ~= null do 76end
81 if r[1] >= r[2][1] then return false end 77env[">"] = function (r)
82 r = r[2] 78 if r[1] == nil then return true end
83 end 79 if r[2] == nil then return true end
84 return true 80 while r[2] ~= null do
85 end, 81 if r[1] <= r[2][1] then return false end
86 [">"] = 82 r = r[2]
87 function (r) 83 end
88 if r[1] == nil then return true end 84 return true
89 if r[2] == nil then return true end 85end
90 while r[2] ~= null do 86env["<="] = function (r) return not env[">"](r) end
91 if r[1] <= r[2][1] then return false end 87env[">="] = function (r) return not env["<"](r) end
92 r = r[2] 88
93 end 89env["+"] = function (r)
94 return true 90 return fold(function (a, b) return a + b end, 0, r)
95 end, 91end
96 ["<="] = function (r) return not m.env[">"](r) end, 92
97 [">="] = function (r) return not m.env["<"](r) end, 93env["-"] = function (r)
98 ------- math 94 if r == null then return -1 end
99 ["+"] = 95 if r[2] == null then return (- r[1]) end
100 function (r) 96 return fold(function (a, b)
101 return fold(function (a, b) return a + b end, 0, r) 97 return a - b
102 end, 98 end, r[1], r[2])
103 ["-"] = 99end
104 function (r) 100
105 if r == null then return -1 end 101env["*"] = function (r)
106 if r[2] == null then return (- r[1]) end 102 local function go (a, b)
107 return fold(function (a, b) 103 if a == 0 or b == 0 then
108 return a - b 104 return 0, 1
109 end, r[1], r[2]) 105 end
110 end, 106 return a * b
111 ["*"] = 107 end
112 function (r) 108 return fold(go, 1, r)
113 local function go (a, b) 109end
114 if a == 0 or b == 0 then 110
115 return 0, 1 111env["/"] = function (r)
116 end 112 assert_arity(r,1)
117 return a * b 113 if r[2] == null then return (1 / r[1]) end
118 end 114 return fold(function (a, b) return a / b end,
119 return fold(go, 1, r) 115 r[1], r[2])
120 end, 116end
121 ["/"] = 117
122 function (r) 118---[[ INPUT / OUTPUT ]]---
123 assert_arity(r, 1) 119
124 if r[2] == null then return (1 / r[1]) end 120env.dump = function (r)
125 return fold(function (a, b) return a / b end, 121 assert_arity(r,1,1)
126 r[1], r[2]) 122 return dump.dump(r[1])
127 end, 123end
128} 124
125env.display = function (r)
126 assert_arity(r,1,1)
127 io.write(r[1])
128end
129
130env.newline = function (r)
131 assert_arity(r,0,0)
132 io.write("\n")
133end
129 134
130-------- 135--------
131return m 136return {
137 environment = env,
138}
diff --git a/dump.lua b/dump.lua index dc32096..538f606 100644 --- a/dump.lua +++ b/dump.lua
@@ -1,36 +1,33 @@
1--- lam.pp 1--- lam.dump --- dump raw lua values
2 2
3local m = {} 3local m = {}
4local type = require "type" 4local type = require("type")
5 5
6function m.dump (x, lvl) 6function m.dump (x, lvl)
7 lvl = lvl or 0 7 lvl = lvl or 0
8 local space = string.rep(" ", lvl) 8 local space = string.rep(" ", lvl*4)
9 local output = "" 9 local out = {}
10 --[[if getmetatable(x) and getmetatable(x).__tostring then 10 if type.luatype(x) == "table" then
11 output = output .. tostring(x) 11 local sub = {}
12 else]]if type.luatype(x) == "table" then 12 for k, v in pairs(x) do
13 local subo = ""
14 for k,v in pairs(x) do
15 if v == x then 13 if v == x then
16 v = "self" 14 v = "self"
15 elseif type.lamtype(v) == "environment" then
16 v = tostring(v)
17 else 17 else
18 v = m.dump(v, lvl+2) 18 v = m.dump(v, lvl+1)
19 end 19 end
20 subo = subo .. string.format("\n%s[%s] = %s,", 20 table.insert(sub,
21 (space.." "), k, v) 21 string.format("\n%s[%s] = %s,", space, k, v))
22 end 22 end
23 output = output .. string.format("\n%s{%s\n%s}", 23 table.insert(out,
24 space, subo, space) 24 string.format("\n%s{%s\n%s}",
25 space, table.concat(sub), space))
25 else 26 else
26 output = output .. tostring(x) 27 table.insert(out, tostring(x))
27 end 28 end
28 return output 29 return table.concat(out)
29end 30end
30 31
31function m.pp (x) 32--------
32 print(m.dump(x))
33end
34
35---
36return m 33return m
diff --git a/eval.lua b/eval.lua index 867a704..4b8f782 100644 --- a/eval.lua +++ b/eval.lua
@@ -1,150 +1,97 @@
1--- lam.eval 1--- lam.eval
2 2
3local m = {} 3local m = {}
4local type = require "type" 4local type = require("type")
5local assert_arity = require("util").assert_arity 5local assert_arity = type.assert_arity
6local util = require("util")
7local error = util.error
6 8
7function m.environ (inner, outer) 9m.special_forms = {
8 local mt = { 10 quote =
9 __type = "environment", 11 function (r, _)
10 __index = outer, 12 assert_arity(r,1,1)
11 __newindex = 13 return r[1]
12 function (self, key, val) 14 end,
13 if rawget(self, key) then 15 quasiquote =
14 rawset(self, key, val) 16 function (r, e)
17 assert_arity(r,1,1)
18 local x = r[1]
19 if not type.listp(x) or type.nullp(x) then
20 return x
21 end
22 local QQ, fin = {}, nil
23 while x[2] do
24 if type.listp(x[1]) then
25 if x[1][1] == "unquote" then
26 table.insert(QQ,
27 m.eval(x[1][2][1], e))
28 elseif x[1][1] == "unquote-splicing"
29 then
30 local y = m.eval(x[1][2][1], e)
31 if not type.listp(y) then
32 fin = y
33 break
34 end
35 while y[2] do
36 table.insert(QQ, y[1])
37 y = y[2]
38 end
39 end
15 else 40 else
16 getmetatable(self).__index[key] = val 41 table.insert(QQ, x[1])
17 end
18 end,
19 }
20 return setmetatable(inner, mt)
21end
22
23local function procedure_call (proc, r)
24 local function doargs (p, r, e)
25 if p == type.null and r == type.null then return e end
26 if type.isa(p, "symbol") then
27 e[p] = r
28 return e
29 end
30 if p[1] == nil then error("Too many arguments") end
31 if r[1] == nil then error("Too few arguments") end
32 e[p[1]] = r[1]
33 doargs(p[2], r[2], e)
34 end
35
36 local e = doargs(proc.params, r, m.environ({}, proc.env))
37 local b = proc.body
38 while b[2] ~= type.null do
39 m.eval(b[1], e)
40 b = b[2]
41 end
42 return m.eval(b[1], e)
43end
44
45function m.procedure (params, body, env)
46 local t = {
47 params = params,
48 body = body,
49 env = env,
50 }
51 local mt = {
52 __type = "procedure",
53 __call = procedure_call,
54 }
55 return setmetatable(t, mt)
56end
57
58local function handle_quasiquote (r, e)
59 assert_arity(r, 1, 1)
60 local x = r[1]
61 if not type.islist(x) or x == type.null then
62 return x
63 end
64 local QQ, fin = {}, nil
65 local car, cdr = x[1], x[2]
66 while cdr do
67 if type.islist(car) then
68 if car[1] == "unquote" then
69 table.insert(QQ, m.eval(car[2][1], e))
70 elseif car[1] == "unquote-splicing" then
71 local usl = m.eval(car[2][1], e)
72 if not type.islist(usl) then
73 fin = usl
74 break
75 end
76 while usl[2] do
77 table.insert(QQ, usl[1])
78 usl = usl[2]
79 end 42 end
43 x = x[2]
80 end 44 end
81 else 45 return type.list(QQ, fin)
82 table.insert(QQ, car) 46 end,
83 end 47 unquote =
84 car, cdr = cdr[1], cdr[2] 48 function (_, _)
85 end 49 error("unexpected", ",")
86 return type.list(QQ, fin)
87end
88
89m.specials = {
90 -- each of these takes R (a list of args) and E (an environment)
91 quote =
92 function (r, e)
93 assert_arity(r, 1, 1)
94 return r[1]
95 end, 50 end,
96 quasiquote = handle_quasiquote,
97 -- if not inside quasiquote, unquote and unquote-splicing are errors
98 unquote = function () error("Unexpected unquote") end,
99 ["unquote-splicing"] = 51 ["unquote-splicing"] =
100 function () error("Unexpected unquote-splicing") end, 52 function (_, _)
101 -- define variables 53 error("unexpected", ",@")
54 end,
102 define = 55 define =
103 function (r, e) 56 function (r, e)
104 assert_arity(r, 2, 2) 57 assert_arity(r,2,2)
105 rawset(e, r[1], m.eval(r[2][1], e)) 58 rawset(e, r[1], m.eval(r[2][1], e))
106 end, 59 end,
107 ["set!"] = 60 ["set!"] =
108 function (r, e) 61 function (r, e)
109 assert_arity(r, 2, 2) 62 assert_arity(r,2,2)
110 e[r[1]] = m.eval(r[2][1], e) 63 e[r[1]] = m.eval(r[2][1], e)
111 end, 64 end,
112 -- y'know, ... lambda
113 lambda = 65 lambda =
114 function (r, e) 66 function (r, e)
115 assert_arity(r, 2) 67 assert_arity(r,2)
116 return m.procedure(r[1], r[2], e) 68 return type.procedure(r[1], r[2], e, m.eval)
117 end, 69 end,
118 -- control flow
119 ["if"] = 70 ["if"] =
120 function (r, e) 71 function (r, e)
121 assert_arity(r, 3, 3) 72 assert_arity(r,3,3)
122 local test, conseq, alt = 73 local test, conseq, alt = r[1], r[2][1], r[2][2][1]
123 r[1], r[2][1], r[2][2][1]
124 if m.eval(test, e) 74 if m.eval(test, e)
125 then return m.eval(conseq, e) 75 then return m.eval(conseq, e)
126 else return m.eval(alt, e) 76 else return m.eval(alt, e)
127 end 77 end
128 end, 78 end,
129 -- TODO: include, import, define-syntax, ... 79 -- TODO: include, import, define-syntax ...
130} 80}
131-- Aliases
132m.specials.lam = m.specials.lambda
133m.specials.def = m.specials.define
134 81
135function m.eval (x, env) -- TODO: specify ENV on all calls 82function m.eval (x, env)
136 if type.isa(x, "symbol") then 83 if type.isp(x, "symbol") then
137 if env[x] == nil then 84 if env[x] == nil then
138 error(string.format("Unbound variable: %s", x)) 85 error("unbound symbol", x)
139 end 86 end
140 return env[x] 87 return env[x]
141 elseif not type.islist(x) then 88 elseif not type.listp(x) then
142 return x 89 return x
143 else 90 else
144 local op, args = x[1], x[2] 91 local op, args = x[1], x[2]
145 if m.specials[op] then 92 if m.special_forms[op] then
146 return m.specials[op](args, env) 93 return m.special_forms[op](args, env)
147 else -- procedure call 94 else -- procedure application
148 local fn = m.eval(op, env) 95 local fn = m.eval(op, env)
149 local params = {} 96 local params = {}
150 local r = args 97 local r = args
diff --git a/load.lua b/load.lua new file mode 100644 index 0000000..f798712 --- /dev/null +++ b/load.lua
@@ -0,0 +1,68 @@
1--- lam.load
2
3local m = {}
4local core = require("core")
5local eval = require("eval")
6local port = require("port")
7local read = require("read")
8local type = require("type")
9
10local function schemeprint (x)
11 -- possibly a candidate to put in a `write' library
12 if x == true then print("#t")
13 elseif x == false then print("#f")
14 elseif x == nil then return -- print("#<nil>")
15 else print(x)
16 end
17end
18
19local function handle_error (e)
20 local start = e:find(": ")
21 return e:sub(start + 2)
22end
23
24function m.load (filename, interactive)
25 -- interactive = { out = file/handle, prompt = string, }
26 local inport = port.input_port(filename)
27 if interactive then
28 io.output(interactive.out)
29 io.output():setvbuf("line")
30 else
31 io.output():setvbuf("no")
32 end
33 repeat
34 if interactive then
35 io.stderr:write(interactive.prompt or "")
36 io.stderr:flush()
37 end
38 -- read
39 local read_ok, form = xpcall(
40 function () return read.read(inport) end,
41 handle_error)
42 if form == port.eof then break end
43 if not read_ok then
44 io.stderr:write("error (read): ", form, "\n")
45 -- when interactive, errors should not be fatal, but
46 -- they should be in batch mode
47 inport:flush() -- avoid endless loop
48 if not interactive then return nil end
49 else
50 -- eval
51 local eval_ok, value = xpcall(
52 function ()
53 return eval.eval(form, core.environment)
54 end,
55 handle_error)
56 if not eval_ok then
57 io.stderr:write("error (eval): ", value, "\n")
58 if not interactive then return nil end
59 else
60 -- print
61 if interactive then schemeprint(value) end
62 end
63 end
64 until value == port.eof -- loop
65end
66
67--------
68return m
diff --git a/port.lua b/port.lua new file mode 100644 index 0000000..812f05e --- /dev/null +++ b/port.lua
@@ -0,0 +1,103 @@
1--- lam.port --- port objects
2-- because the implementation for ports is fairly involved, they're in their own
3-- file outside of `type'.
4
5local m = {}
6local util = require("util")
7local error = util.error
8local tochars = util.tochars
9
10-- The EOF object is what the reader emits when it hits an end-of-file or use up
11-- a port.
12m.eof = setmetatable({}, {
13 __type = "eof",
14 __tostring = function () return "#<eof>" end,
15})
16
17---[[ INPUT PORTS ]]---
18
19-- return the next token from PORT, given READTABLE
20local function input_port_next_token (port, readtable)
21 repeat
22 if #port.buffer == 0 then
23 if port.file then
24 local ln = port.file:read()
25 if ln == nil then
26 return m.eof
27 end
28 port.buffer = tochars(ln)
29 else
30 return m.eof
31 end
32 end
33
34 local token, token_type
35 local c = port.buffer[1]
36 if readtable.chars[c] then
37 token, token_type, port.buffer =
38 readtable.chars[c](port.buffer)
39 else
40 for re, fn in pairs(readtable.regex) do
41 if c:match(re) then
42 token, token_type, port.buffer =
43 fn(port.buffer)
44 break
45 end
46 end
47 if token == nil then
48 token, token_type, port.buffer =
49 readtable.default(port.buffer)
50 end
51 end
52
53 port.buffer = port.buffer or {}
54 if token then
55 return token, token_type
56 end
57 until nil
58end
59
60function m.input_port (source, source_type)
61 -- SOURCE is the name of the file/string to read or nil; nil means
62 -- standard input. SOURCE_TYPE is one of "file", "string"; "file" is
63 -- the default.
64 local f, b
65 source_type = source_type or "file"
66 if source then
67 if source_type == "file" then
68 f = io.open(source, "r")
69 elseif source_type == "string" then
70 b = tochars(source)
71 else
72 error("input-port: bad type", source_type)
73 end
74 else
75 f = io.input() -- ignore SOURCE_TYPE
76 end
77 local t = {
78 file = f,
79 name = f and source or "[string]",
80 type = source_type,
81 buffer = b or {},
82 flush = function (self) self.buffer = {} end,
83 next = input_port_next_token, -- port:next(readtable)
84 close =
85 function (self)
86 if self.file then self.file:close() end
87 end,
88 }
89 local mt = {
90 __type = "input-port",
91 __tostring =
92 function (self)
93 return string.format("#<port %s>", self.name)
94 end,
95 }
96 return setmetatable(t, mt)
97end
98
99---[[ OUTPUT PORTS ]]---
100-- TODO
101
102--------
103return m
diff --git a/read.lua b/read.lua index 332c919..6d55e23 100644 --- a/read.lua +++ b/read.lua
@@ -1,166 +1,29 @@
1--- lam.read 1--- lam.read
2 2
3local m = {} 3local m = {}
4local t = require "type" 4local type = require("type")
5local utf8 = require "utf8" 5local port = require("port")
6local pop = require("util").pop 6local eof, input_port = port.eof, port.input_port
7local util = require("util")
8local constantly, error, pop = util.constantly, util.error, util.pop
7 9
8-- TODO: 10local token_separators = "[%s#()\"'`,@;]"
9-- - string reading
10-- - probably more
11
12m.eof = setmetatable({}, {
13 __type = "EOF",
14 __tostring = function () return "#<eof>" end,
15})
16
17local function inport_next_token (port)
18 local tok, toktype
19 while true do
20 if #port.line == 0 then
21 if port.file then
22 local ln = port.file:read()
23 if ln == nil then return m.eof end
24 port.line = m.tochars(ln)
25 else
26 return nil
27 end
28 end
29 tok, toktype, port.line = m.scan(port.line)()
30 port.line = port.line or {}
31 if tok ~= nil then return tok, toktype end
32 end
33end
34
35function m.inport (source, kind)
36 -- KIND can be one of "file", "string"; defaults to "file"
37 -- SOURCE is the name of the file or the string to read, or nil; if nil,
38 -- read from standard input.
39 local f, l
40 local k = kind or "file"
41 if source then
42 if k == "file" then
43 f = io.open(source, "r")
44 elseif k == "string" then
45 l = m.tochars(source)
46 end
47 else
48 -- KIND is ignored here
49 f = io.input()
50 end
51 local t = {
52 file = f,
53 filename = source,
54 kind = kind,
55 line = l or {},
56 next_token = inport_next_token,
57 }
58 if t.file then t.close = function (self) self.file:close() end; end
59 local mt = {
60 __type = "port",
61 __tostring =
62 function (self)
63 return string.format("#<port %s>",
64 self.file or "(string)")
65 end,
66 }
67 return setmetatable(t, mt)
68end
69
70function m.tochars (s)
71 local chars = {}
72 for _, code in utf8.codes(s) do
73 table.insert(chars, code)
74 end
75 return chars
76end
77
78--- Consumers
79-- These take a table of characters (cs) and return:
80-- a token, its type, and the rest of the characters
81
82local token_separator = "[^%s#()\"'`,@;]"
83 11
84local function consume_token (cs) 12local function consume_token (cs)
85 local token = {} 13 local tok = {}
86 while #cs > 0 and cs[1]:match(token_separator) do 14 while #cs > 0 and not cs[1]:match(token_separators) do
87 table.insert(token, pop(cs)) 15 local c = pop(cs)
16 table.insert(tok, c)
88 end 17 end
89 return table.concat(token), "symbol", cs 18 return table.concat(tok), cs
90end 19end
91 20
92local function consume_whitespace (cs) 21---[[ READ TABLE ]]---
93 while #cs > 0 and cs[1]:match("%s") do pop(cs) end
94 return nil, nil, cs
95end
96
97local function consume_comment (cs)
98 local comment = {}
99 repeat table.insert(comment, pop(cs))
100 until #cs == 0 or cs[1]:match("\n")
101 return table.concat(comment), "comment", cs
102end
103
104local function idf (x)
105 return function () return x end
106end
107
108local function numf (base)
109 return function (token)
110 local n = tonumber(token:sub(3), base)
111 assert(n, "Can't read number: " .. token)
112 return n
113 end
114end
115
116local literals = {
117 literal = {
118 ["#t"] = idf(true),
119 ["#true"] = idf(true),
120 ["#f"] = idf(false),
121 ["#false"] = idf(false),
122 ["#\\space"] = idf(t.character(" ")),
123 ["#\\tab"] = idf(t.character("\t")),
124 ["#\\newline"] = idf(t.character("\n")),
125 },
126 match = {
127 ["^#b"] = numf(2),
128 ["^#o"] = numf(8),
129 ["^#d"] = numf(10),
130 ["^#x"] = numf(16),
131 ["^#\\"] = function (tok) return t.character(tok:sub(3)) end,
132 }
133}
134
135local function consume_literal (cs)
136 -- whitespace and parantheses character literals.
137 -- reverse the match test b/c it's already a complement
138 if cs[2] == "\\" and not cs[3]:match(token_separator) then
139 return type.character(cs[3])
140 end
141 pop(cs) -- discard '#'
142 local token, value, cs = consume_token(cs) -- todo: vectors #(...)
143 token = "#" .. token -- put '#' back
144
145 if literals.literal[token] then
146 value = literals.literal[token]()
147 else
148 for re, fn in pairs(literals.match) do
149 if token:match(re) then
150 value = fn(token)
151 end
152 end
153 end
154 -- TODO : if `nil' is to be a value in lam i'm going to have to figure
155 -- out some kind of 'lam nil' and 'lua nil' or something..
156 assert(value~=nil, "Can't read literal: " .. token)
157
158 return value, "literal", cs
159end
160 22
161--- Reading from a port 23-- each function should take a list of characters and return the token, its
162 24-- type, and the rest of the characters
163m.readtable = { 25m.readtable = {}
26m.readtable.chars = {
164 ["("] = function (cs) return pop(cs), "open", cs end, 27 ["("] = function (cs) return pop(cs), "open", cs end,
165 [")"] = function (cs) return pop(cs), "close", cs end, 28 [")"] = function (cs) return pop(cs), "close", cs end,
166 ["'"] = function (cs) return pop(cs), "quote", cs end, 29 ["'"] = function (cs) return pop(cs), "quote", cs end,
@@ -175,109 +38,184 @@ m.readtable = {
175 return ",", "quote", cs 38 return ",", "quote", cs
176 end 39 end
177 end, 40 end,
178 [";"] = consume_comment, 41 [";"] = -- comment
179 ["#"] = consume_literal, 42 function (cs)
180} 43 local comment = {}
44 while #cs > 0 and not cs[1]:match("\n") do
45 table.insert(comment, pop(cs))
46 end
47 return table.concat(comment), "comment", cs
48 end,
49 ["#"] = -- literal
50 function (cs)
51 local tok
52 -- bail on just '#\'
53 if not (cs[2] and cs[3]) then
54 cs = {}
55 error("bad literal", "#\\")
56 end
181 57
182--- TODO: Figure out how to read #f and #n properly 58 -- read '#\ ' and such correctly
59 if cs[2] == "\\" and cs[3]:match(token_separators) then
60 pop(cs) -- remove '\'
61 pop(cs) -- remove next character
62 return type.character(cs[1])
63 end
183 64
184-- Return an iterator over a character table, so you can do: 65 pop(cs) -- discard '#' ...
185-- for token, chars in scan(cs) do ... end 66 tok, cs = consume_token(cs)
186function m.scan (cs) 67 tok = "#" .. tok -- ... then put it back
187 local cs = cs 68
188 return function () 69 local val
189 if not next(cs) then return nil end 70 if m.readtable.literals.lit[tok] then
190 local token, toktype 71 val = m.readtable.literals.lit[tok]
191 while true do
192 if m.readtable[cs[1]] then
193 token, toktype, cs = m.readtable[cs[1]](cs)
194 return token, toktype, cs
195 elseif cs[1]:match("%s") then
196 --- should this just continue the loop?
197 -- i.e., remove `return'
198 return consume_whitespace(cs)
199 elseif cs[1]:match("[%d.+-]") then
200 -- numbers, +, -, ., ...
201 local token, _, cs = consume_token(cs)
202 if token:match("[-+]") or token == "..." then
203 return token, "symbol", cs
204 elseif token == "." then
205 return token, "dot", cs
206 else
207 local n = tonumber(token)
208 assert (n ~= nil, "Bad number: "..n)
209 return n, "number", cs
210 end
211 else 72 else
212 return consume_token(cs) 73 for re, fn in pairs(m.readtable.literals.regex)
74 do
75 if tok:match(re) then
76 val = fn(tok)
77 end
78 end
79 end
80
81 if val == nil then
82 error("bad literal", tok)
83 end
84 return val, "literal", cs
85 end,
86}
87m.readtable.regex = {
88 ["%s"] = -- whitespace
89 function (cs)
90 while #cs > 0 and cs[1]:match("%s") do
91 pop(cs)
92 end
93 return false, nil, cs
94 end,
95 ["[%d.+-]"] = -- numbers and symbols +, -, ., and ...
96 function (cs)
97 local tok
98 tok, cs = consume_token(cs)
99 if tok:match("^[-+]$") or tok == "..." then
100 return tok, "symbol", cs
101 elseif tok == "." then
102 return tok, "dot", cs
103 else -- number
104 local n = tonumber(tok)
105 if not n then
106 error("bad number", n)
107 end
108 return n, "number", cs
213 end 109 end
110 end,
111}
112m.readtable.default = -- default action if nothing else matches
113 function (cs)
114 local tok, cs = consume_token(cs)
115 return tok, "symbol", cs
116 end
117
118-- convenience function to make writing the regexen rules easier below
119local function based_num (base)
120 return function (token)
121 local n = tonumber(token:sub(3), base)
122 if not n then
123 error("bad number", token)
214 end 124 end
125 return n
215 end 126 end
216end 127end
217 128
218function m.readchar (port) 129m.readtable.literals = {
219 if #port.line > 0 then 130 lit = {
220 local ch = pop(port.line) 131 ["#t"] = true,
221 return ch 132 ["#true"] = true,
222 else 133 ["#f"] = false,
223 return port.file and port.file.read(1) 134 ["#false"] = false,
224 end 135 },
136 regex = {
137 ["^#b"] = based_num(2),
138 ["^#o"] = based_num(8),
139 ["^#d"] = based_num(10),
140 ["^#x"] = based_num(16),
141 ["^#\\."] =
142 function (tok)
143 return type.character(tok:sub(3))
144 end,
145 },
146}
147-- add named characters
148for char, name in pairs(type.character_names) do
149 m.readtable.literals.lit["#\\"..name] = type.character(char)
225end 150end
226 151
152---[[ READER MACROS ]]---
153-- Each of these are named after the type of the token read and contain
154-- function taking (TOKEN, TYPE, PORT) and returning a lisp object
155
227m.readmacros = { 156m.readmacros = {
157 close =
158 function (token, _, _)
159 error("unexpected", token)
160 end,
228 quote = 161 quote =
229 function (tok, toktype, port) 162 function (token, _, port)
230 local qs = { 163 local qs = {
231 ["'"] = "quote", 164 ["'"] = "quote",
232 ["`"] = "quasiquote", 165 ["`"] = "quasiquote",
233 [","] = "unquote", 166 [","] = "unquote",
234 [",@"] = "unquote-splicing", 167 [",@"] = "unquote-splicing",
235 } 168 }
236 if not qs[tok] then 169 if not qs[token] then
237 error(string.format("Bad quote: '%s'\n", tok)) 170 error("bad quote", token)
238 end 171 end
239 local Q = {qs[tok]} 172 local Q = {qs[token]}
240 table.insert(Q, m.read(port)) 173 table.insert(Q, m.read(port))
241 return t.list(Q) 174 return type.list(Q)
242 end, 175 end,
243 comment = idf(nil) 176 comment = constantly(nil), -- throw comments away
244} 177}
245 178
179---[[ READ ]]---
180
246function m.read (port) 181function m.read (port)
247 local function read_ahead (tok, toktype) 182 local function read_ahead(token, token_type)
248 if tok == m.eof then error("Unexpected EOF") end 183 if token == eof then error("unexpected", token) end
249 if toktype == "open" then 184 if token_type == "open" then
185 -- this must be defined here because it calls read_ahead
186 -- recursively.
250 local L = {} 187 local L = {}
251 while true do 188 repeat
252 local tok, toktype = port:next_token() 189 token, token_type = port:next(m.readtable)
253 if toktype == "close" then 190 if token_type == "close" then
254 return t.list(L) 191 return type.list(L)
255 elseif toktype == "dot" then 192 elseif token_type == "dot" then
256 local fin = m.read(port) 193 local fin = m.read(port)
257 port:next_token() -- throw away ')' 194 port:next(m.readtable) -- discard ')'
258 return t.list(L, fin) 195 return type.list(L, fin)
259 else 196 else
260 table.insert(L, 197 table.insert(L,
261 read_ahead(tok, toktype)) 198 read_ahead(token, token_type))
262 end 199 end
263 end 200 until nil
264 elseif toktype == "close" then 201 elseif m.readmacros[token_type] then
265 error("Unexpected ')'") 202 return m.readmacros[token_type](token, token_type, port)
266 elseif m.readmacros[toktype] then 203 else
267 return m.readmacros[toktype](tok, toktype, port) 204 return token
268 else return tok
269 end 205 end
270 end 206 end
271 -- body of read 207 ---
272 local tok1, toktype1 = port:next_token() 208 local token1, type1 = port:next(m.readtable)
273 if tok1 == m.eof then return m.eof 209 if token1 == eof then
274 else return read_ahead(tok1, toktype1) 210 return eof
211 else
212 return read_ahead(token1, type1)
275 end 213 end
276end 214end
277 215
278function m.read_string (str) 216function m.read_string (str)
279 return m.read(m.inport(str, "string")) 217 return m.read(input_port(str, "string"))
280end 218end
281 219
282--- 220--------
283return m 221return m
diff --git a/repl.lua b/repl.lua index c4a6546..4bdd918 100644 --- a/repl.lua +++ b/repl.lua
@@ -1,25 +1,9 @@
1--- lam.repl 1--- lam.repl
2 2
3local m = {} 3local m = {}
4local _r = require("read") 4local load = require("load").load
5local read, inport, read_string, eof =
6 _r.read, _r.inport, _r.read_string, _r.eof
7local eval = require("eval").eval
8 5
9local function schemeprint (x) 6m.logo = [[
10 -- if x == nil then return end
11 if x == true then
12 print("#t")
13 elseif x == false then
14 print("#f")
15 elseif x == nil then
16 print("#<nil>")
17 else
18 print(x)
19 end
20end
21
22local lam = [[
23 @,,,@ 7 @,,,@
24<|^ ^|> l a m 8<|^ ^|> l a m
25 | /) 0015 9 | /) 0015
@@ -27,66 +11,9 @@ local lam = [[
27 ------------- 11 -------------
28]] 12]]
29 13
30local function handle_error (e)
31 local start = e:find(": ")
32 return e:sub(start + 2)
33end
34
35function m.read_eval (filename, interactive)
36 -- interactive = { out = file or handle, prompt = string, }
37 local inport = inport(filename)
38 local prompt = interactive and interactive.prompt or "> "
39 if interactive then
40 io.output(interactive.out or io.stdout)
41 io.write(lam)
42 io.output():setvbuf("line")
43 else
44 io.output():setvbuf("no")
45 end
46 repeat
47 if interactive then
48 io.stderr:write(prompt)
49 io.stderr:flush()
50 end
51 -- read
52 local ok, x = xpcall(
53 function ()
54 local nxt = read(inport)
55 return nxt
56 end,
57 handle_error
58 )
59 if not ok then
60 io.stderr:write("(read) not ok: ", x, "\n")
61 -- in interactive mode, errors should not be fatal. in
62 -- batch mode, they should be.
63 if not interactive then return nil end
64 end
65 -- eval
66 if ok then
67 local ok, v = xpcall(
68 function () return eval(x) end,
69 handle_error
70 )
71 if not ok then
72 io.stderr:write("(eval) not ok: ", v, "\n")
73 if not interactive then return nil end
74 end
75 -- print
76 if ok and interactive then schemeprint(v) end
77 elseif interactive then
78 ok = "recover"
79 end
80 until x == eof -- loop
81 inport:close()
82end
83
84function m.repl (prompt) 14function m.repl (prompt)
85 return m.read_eval(nil, { prompt = prompt, }) 15 io.stderr:write(m.logo)
86end 16 return load(nil, {prompt = prompt or "> ", })
87
88function m.load (filename)
89 return m.read_eval(filename)
90end 17end
91 18
92-------- 19--------
diff --git a/type.lua b/type.lua index f119270..c205468 100644 --- a/type.lua +++ b/type.lua
@@ -1,112 +1,192 @@
1--- lam.type 1--- lam.type
2-- this library implements lam types---atomic and collection---and type
3-- predicates. it also re-exports lua's `type` as type.luatype and implements
4-- `type.lamtype`. types are implemented as functions to build the given type
5-- from some arguments. their metatables contain various metamethods, but also
6-- `__type`.
2 7
3local m = {} 8local m = {}
4local utf8 = require "utf8" 9local utf8 = require("utf8")
5utf_char, utf_codepoint = utf8.char, utf8.codepoint 10local util = require("util")
11local tochars, error, constantly = util.tochars, util.error, util.constantly
6 12
7--- atomic types 13---[[ ATOMIC TYPES ]]---
8 14
9-- true, false and nil are just ... true, false, and nil 15-- a lam symbol is a lua string
16m.symbol = tostring
17
18-- a lam number is a lua number
19-- TODO: implement full numeric tower
20m.number = tonumber
21
22-- a character is a wrapped single-character string
23-- it contains both the string representation and the character's codepoint
24
25m.character_names = {
26 -- some characters, like whitespace, have names
27 ["\n"] = "newline",
28 [" "] = "space",
29 ["\t"] = "tab",
30}
10 31
11-- Characters contain both their string reputations and their codepoints
12function m.character (x) 32function m.character (x)
13 -- is storing a character with its string and numerical representation
14 -- overkill? ... maybe.
15 local s = tostring(x) 33 local s = tostring(x)
16 local uc = utf_codepoint(s) 34 local uc = utf8.codepoint(s)
17 local t = { -- String representation of the character 35 local t = {
18 v = utf_char(uc), 36 v = utf8.char(uc),
19 u = uc, 37 u = uc,
20 } 38 }
21 local mt = { 39 local mt = {
22 __type = "character", 40 __type = "char", -- scheme name
23 __eq = function (self) return self.v end, 41 -- compare using codepoints since they're just numbers
42 __eq = function (a, b) return a.u == b.u end,
24 __lt = function (a, b) return a.u < b.u end, 43 __lt = function (a, b) return a.u < b.u end,
25 __tostring = 44 __tostring =
26 function (self) 45 function (self)
27 local v = self.v 46 local v = self.v
28 if v == "\n" then 47 if m.character_names[v] then
29 return "#\\newline" 48 v = m.character_names[v]
30 elseif v == " " then
31 return "#\\space"
32 else
33 return "#\\" .. v
34 end 49 end
50 return "#\\" .. v
35 end, 51 end,
36 } 52 }
37 return setmetatable(t, mt) 53 return setmetatable(t, mt)
38end 54end
39 55
40-- a symbol is just a string, unadorned. I was going to have a character be 56---[[ PROCEEDURES AND ENVIRONMENTS ]]---
41-- represented by a one-character string, but then it would be indistinguishable
42-- from a one-character symbol internally.
43m.symbol = tostring
44 57
45-- for now, number will just be lua's number. At *some* point, it will be the 58function m.environment (inner, outer)
46-- whole numeric tower, yaaayyy 59 local mt = {
47m.number = tonumber 60 __type = "environment",
61 __index = outer,
62 __newindex =
63 function (self, key, val)
64 if rawget(self, key) then
65 rawset(self, key, val)
66 else
67 getmetatable(self).__index[key] = val
68 end
69 end,
70 __tostring = constantly("#<environment>"),
71 }
72 return setmetatable(inner, mt)
73end
48 74
49-- strings are wrapped strings 75function m.procedure (params, body, env, eval)
50function m.string (x)
51 local x = tostring(x)
52 local t = { 76 local t = {
53 v = x, 77 params = params,
54 escape = 78 body = body,
55 function (self) 79 env = env,
56 return self.v:gsub("[\\\"]", "\\%1") 80 eval = eval,
57 end,
58 } 81 }
59 local mt = { 82 local mt = {
60 __type = "string", 83 __type = "procedure",
61 __tostring = 84 __tostring =
62 function (self) 85 function (self)
63 return "\"" .. self:escape() .. "\"" 86 return string.format("(lambda %s %s)",
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)
64 end, 127 end,
65 } 128 }
66 return setmetatable(t, mt) 129 return setmetatable(t, mt)
67end 130end
68 131
69-- null () is both an atom and a list (yay) 132function m.assert_arity (r, min, max)
70-- this one is NOT a function 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
139end
140
141---[[ NULL ]]---
142-- 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
144-- it's its own object.
145
71m.null = setmetatable({}, { 146m.null = setmetatable({}, {
72 __type = "null", 147 __type = "null",
73 __tostring = function (self) return "()" end, 148 __tostring = function () return "()" end,
74}) 149})
75 150
76--- collection types 151function m.nullp (x)
152 return x == m.null
153end
154
155---[[ COLLECTION TYPES ]]---
77 156
78-- cons are lisp's fundamental collection type 157-- cons are lisp's fundamental collection type: they link two things together in
158-- a structure
79function m.cons (a, b) 159function m.cons (a, b)
80 local t = { a, b, } 160 local t = { a, b, }
81 local mt = { 161 local mt = {
82 __type = "cons", 162 __type = "pair", -- scheme name
83 __tostring = 163 __tostring =
84 function (self) 164 function (self)
85 local out = {} 165 local t, p = {}, self
86 local car, cdr = self[1], self[2] 166 while p[2] do
87 while cdr do 167 table.insert(t, tostring(p[1]))
88 table.insert(out, tostring(car)) 168 if m.luatype(p[2]) == "table" then
89 if m.luatype(cdr) == "table" then 169 p = p[2]
90 car = cdr[1]
91 cdr = cdr[2]
92 else 170 else
93 table.insert(out, ".") 171 table.insert(t, ".")
94 table.insert(out, cdr) 172 table.insert(t, p[2])
95 break 173 break
96 end 174 end
97 end 175 end
98 return "(" .. table.concat(out, " ") .. ")" 176 return string.format("(%s)",
177 table.concat(t, " "))
99 end, 178 end,
100 __len = 179 __len =
101 function (self) 180 function (self)
102 local function go (lis, acc) 181 local function go (x, acc)
103 -- improper lists don't have lengths 182 -- improper lists don't have lengths
104 -- ... but don't error here. 183 if not m.isp(x, "pair") then
105 if not m.isa(lis, "cons") then
106 return nil 184 return nil
107 end 185 end
108 if lis[2] == m.null then return acc 186 if m.nullp(x[2]) then
109 else return go(lis[2], acc+1) 187 return acc
188 else
189 return go(x[2], acc + 1)
110 end 190 end
111 end 191 end
112 return go(self, 1) 192 return go(self, 1)
@@ -115,74 +195,87 @@ function m.cons (a, b)
115 return setmetatable(t, mt) 195 return setmetatable(t, mt)
116end 196end
117 197
118-- lists are singly-linked cons cells 198-- a series of cons cells linked together is a list
119function m.list (items, last) 199function m.list (items, final)
120 -- ITEMS is a table and LAST is an optional final cdr. If it's nil, the 200 -- ITEMS is a table of items to turn into a list, and FINAL is an
121 -- list is a "proper" list; that is, it ends in (). 201 -- optional final cdr. If it's nil, the list is a "proper" list,
202 -- i.e. it ends in (); otherwise, it's an "improper" list.
122 local function tolist (base, items) 203 local function tolist (base, items)
123 if #items == 0 then return base end 204 if #items == 0 then return base end
124 return tolist(m.cons(table.remove(items), base), items) 205 return tolist(m.cons(table.remove(items), base), items)
125 end 206 end
126 return tolist(last or m.null, items) 207 return tolist(final or m.null, items)
127end 208end
128 209
129-- convert a list to a lua table 210-- strings are vectors of chars
130function m.totable (cons) 211function m.string (x)
131 local t = {} 212 local t = tochars(tostring(x))
132 local car, cdr = cons[1], cons[2] 213 local mt = {
133 while cdr do 214 __type = "string",
134 table.insert(t, car) 215 __tostring =
135 if m.luatype(cdr) == "table" then 216 function (self)
136 car = cdr[1] 217 local esc =
137 cdr = cdr[2] 218 table.concat(self):
138 else 219 gsub("[\\\"]", "\\%1")
139 table.insert(t, cdr) 220 return string.format("\"%s\"", esc)
140 end 221 end,
141 end 222 }
142 return t 223 return setmetatable(t, mt)
143end 224end
144 225
145-- testing types 226---[[ TYPE DETECTION AND PREDICATES ]]---
146 227
147-- we love name collisions 228-- to avoid name clashes, `type` is saved in type.luatype
148m.luatype = type 229m.luatype = type
149 230
231-- return the lam type of a given expression
150function m.lamtype (x) 232function m.lamtype (x)
151 if m.luatype(x) == "string" then 233 if getmetatable(x) and getmetatable(x).__type then
152 return "symbol"
153 elseif getmetatable(x) and getmetatable(x).__type then
154 return getmetatable(x).__type 234 return getmetatable(x).__type
235 elseif m.luatype(x) == "string" then
236 return "symbol"
155 else 237 else
156 return m.luatype(x) 238 return m.luatype(x)
157 end 239 end
158end 240end
159 241
160function m.isa (x, t) 242--- Predicates are named with a `p', lisp-style
243
244-- is X of type T ?
245function m.isp (x, t)
161 return m.lamtype(x) == t 246 return m.lamtype(x) == t
162end 247end
163 248
164function m.islist (x) 249-- is X a "proper" list?
165 -- TODO: detect circular lists 250function m.listp (x)
166 if x == m.null then 251 -- take advantage of cons' __len operator, but since it returns a
167 return true 252 -- number, convert that to a bool
168 elseif m.isa(x, "cons") then 253 if m.isp(x, "pair") and #x
169 return m.islist(x[2]) 254 then return true
170 else 255 else return false
171 return false
172 end 256 end
173end 257end
174 258
175function m.isatom (x) 259-- according to CHICKEN, `atom?' returns #t if X is not a pair (cons)
176 if x == m.null then 260function m.atomp (x)
177 return true -- '() is the only value that is both atom and list 261 return not m.isp(x, "pair")
178 elseif m.luatype(x) == "table" then 262end
179 -- generally, anything that's implemented as a table is *not* an 263
180 -- atom, at least as I will define it. (it's not an actual 264--[[ CONVERTING BACK TO LUA TYPES ]]--
181 -- scheme procedure) 265
182 return false 266-- convert a cons back to a table
183 else 267-- this doesn't special-case for proper/improper lists
184 return true 268function m.totable (cons)
269 local t, p = {}, cons
270 while p[2] do
271 table.insert(t, p[1])
272 if m.isp(p[2]) == "pair" then
273 p = p[2]
274 else
275 table.insert(t, p[2])
276 end
185 end 277 end
278 return t
186end 279end
187 280
188-------- 281--------
diff --git a/util.lua b/util.lua index 8fedbf7..10460a2 100644 --- a/util.lua +++ b/util.lua
@@ -1,22 +1,35 @@
1--- lam.util 1--- lam.util --- utility functions
2 2
3local m = {} 3local m = {}
4local string = string
5local utf8 = require("utf8")
4 6
7m.luaerror = error
8
9-- signal an error
10-- WHERE is where in the process; DESC is a description of the error; the rest
11-- are "irritants"
12function m.error (desc, ...)
13 m.luaerror(string.format("%s: %s", desc, table.concat({...}, " ")
14 ))
15end
16
17-- remove an element from the front of TBL
5function m.pop (tbl) 18function m.pop (tbl)
6 --[[ Remove the first element from TBL. ]]
7 return table.remove(tbl, 1) 19 return table.remove(tbl, 1)
8end 20end
9 21
10function m.assert_arity (r, min, max) 22function m.tochars (str)
11 local rmin = min or 0 23 local cs = {}
12 local rmax = max or 1/0 -- infinity 24 for _, code in utf8.codes(str) do
13 local rlen = #r 25 table.insert(cs, code)
14 if rlen < rmin or rlen > rmax then
15 error(string.format("Wrong arity: %s; expecting %s",
16 rlen,
17 rmin == rmax and rmin or (rmin..".."..rmax)))
18 end 26 end
27 return cs
28end
29
30function m.constantly (x)
31 return function () return x end
19end 32end
20 33
21--- 34--------
22return m 35return m
© 2022 C. Duckworth. generated by cgit. comments, issues, and patches welcome at < git at acdw dot net >.