From 8ce2915e3c54598c2fda4fec0980ebfc2a3adf6e Mon Sep 17 00:00:00 2001
From: Case Duckworth
Date: Tue, 9 Apr 2024 21:04:17 -0500
Subject: Reorganization
---
Makefile | 19 ++-
Organization.txt | 8 ++
core.lua | 241 ++++++++++++++++++-----------------
dump.lua | 39 +++---
eval.lua | 171 +++++++++----------------
load.lua | 68 ++++++++++
port.lua | 103 +++++++++++++++
read.lua | 380 +++++++++++++++++++++++--------------------------------
repl.lua | 81 +-----------
type.lua | 291 +++++++++++++++++++++++++++---------------
util.lua | 35 +++--
11 files changed, 767 insertions(+), 669 deletions(-)
create mode 100644 Organization.txt
create mode 100644 load.lua
create mode 100644 port.lua
diff --git a/Makefile b/Makefile
index 3495163..23d342f 100644
--- a/Makefile
+++ b/Makefile
@@ -1,25 +1,22 @@
LUA ?= rlwrap luajit \
- -e 'pp = require("dump").pp' \
+ -e 'core = require "core"' \
+ -e 'dump = require "dump"' \
-e 'eval = require "eval"' \
+ -e 'load = require "load"' \
+ -e 'port = require "port"' \
-e 'read = require "read"' \
+ -e 'repl = require "repl"' \
-e 'type = require "type"' \
- -e 'utf8 = require "utf8"' \
- -e 'util = require "util"' \
- -e 'test = require "test"' \
- -e 'repl = require "repl"'
+ -e 'util = require "util"'
.PHONY: luarepl
luarepl:
$(LUA) -i
-.PHONY: repl
-repl:
+.PHONY: lamrepl
+lamrepl:
$(LUA) -e 'require("repl").repl("> ")'
-.PHONY: test
-test:
- $(LUA) -e 'test.runtests()'
-
.PHONY: check
check:
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 @@
+
+utf8 type---.
+ | / \ \
+ read eval core(environment)
+ \ / |
+ load<----'
+ | (require "core"; core.env.load = m.load) ~ and other stuf i spose
+ repl
diff --git a/core.lua b/core.lua
index fd78997..20c6b5c 100644
--- a/core.lua
+++ b/core.lua
@@ -1,131 +1,138 @@
--- lam.core --- core procedures
-local m = {}
-local type = require "type"
-local isa, null = type.isa, type.null
-local math = math
-local dump = require("dump").dump
--- local load = require("repl").load -- circular dependency :<
-local util = require "util"
-local assert_arity = util.assert_arity
+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 step end
+ if early_return then return early_return end
return fold(kons, step, r[2])
end
end
-m.env = { -- all functions here take R, which is the list of arguments
- ------- equivalence
- ["eqv?"] =
- function (r)
- assert_arity(r, 2, 2)
- return r[1] == r[2][1]
- end,
- ["eq?"] =
- function (r)
- assert_arity(r, 2, 2)
- -- from how i understand the Scheme spec, it's okay to
- -- make `eqv?' and `eq?' the same.
- return r[1] == r[2][1]
- end,
- -- equal? can be done in-library
- ------- i/o
- display =
- function (r)
- assert_arity(r, 1, 1)
- io.write(tostring(r[1]))
- end,
- newline =
- function (r)
- assert_arity(r, 0, 0)
- io.write("\n")
- end,
- dump =
- function (r)
- assert_arity(r, 1, 1)
- return dump(r[1])
- end,
- --[[ load = -- circular dependency :<
- function (r)
- assert_arity(r, 1, 1)
- load(r[1])
- end,
- --]]
- ------- numbers
- -- todo: assert all of these are numbers
- ["number?"] =
- function (r)
- assert_arity(r, 1, 1)
- return isa(r[1], "number")
- end,
- ["="] =
- 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,
- ["<"] =
- 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,
- [">"] =
- 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,
- ["<="] = function (r) return not m.env[">"](r) end,
- [">="] = function (r) return not m.env["<"](r) end,
- ------- math
- ["+"] =
- function (r)
- return fold(function (a, b) return a + b end, 0, r)
- end,
- ["-"] =
- 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,
- ["*"] =
- 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,
- ["/"] =
- 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,
-}
+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(r[1])
+end
+
+env.newline = function (r)
+ assert_arity(r,0,0)
+ io.write("\n")
+end
--------
-return m
+return {
+ environment = env,
+}
diff --git a/dump.lua b/dump.lua
index dc32096..538f606 100644
--- a/dump.lua
+++ b/dump.lua
@@ -1,36 +1,33 @@
---- lam.pp
+--- lam.dump --- dump raw lua values
local m = {}
-local type = require "type"
+local type = require("type")
function m.dump (x, lvl)
lvl = lvl or 0
- local space = string.rep(" ", lvl)
- local output = ""
- --[[if getmetatable(x) and getmetatable(x).__tostring then
- output = output .. tostring(x)
- else]]if type.luatype(x) == "table" then
- local subo = ""
- for k,v in pairs(x) do
+ local space = string.rep(" ", lvl*4)
+ local out = {}
+ if type.luatype(x) == "table" then
+ local sub = {}
+ for k, v in pairs(x) do
if v == x then
v = "self"
+ elseif type.lamtype(v) == "environment" then
+ v = tostring(v)
else
- v = m.dump(v, lvl+2)
+ v = m.dump(v, lvl+1)
end
- subo = subo .. string.format("\n%s[%s] = %s,",
- (space.." "), k, v)
+ table.insert(sub,
+ string.format("\n%s[%s] = %s,", space, k, v))
end
- output = output .. string.format("\n%s{%s\n%s}",
- space, subo, space)
+ table.insert(out,
+ string.format("\n%s{%s\n%s}",
+ space, table.concat(sub), space))
else
- output = output .. tostring(x)
+ table.insert(out, tostring(x))
end
- return output
+ return table.concat(out)
end
-function m.pp (x)
- print(m.dump(x))
-end
-
----
+--------
return m
diff --git a/eval.lua b/eval.lua
index 867a704..4b8f782 100644
--- a/eval.lua
+++ b/eval.lua
@@ -1,150 +1,97 @@
--- lam.eval
local m = {}
-local type = require "type"
-local assert_arity = require("util").assert_arity
+local type = require("type")
+local assert_arity = type.assert_arity
+local util = require("util")
+local error = util.error
-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)
+m.special_forms = {
+ quote =
+ function (r, _)
+ assert_arity(r,1,1)
+ return r[1]
+ end,
+ quasiquote =
+ function (r, e)
+ assert_arity(r,1,1)
+ local x = r[1]
+ if not type.listp(x) or type.nullp(x) then
+ return x
+ end
+ local QQ, fin = {}, nil
+ while x[2] do
+ if type.listp(x[1]) then
+ if x[1][1] == "unquote" then
+ table.insert(QQ,
+ m.eval(x[1][2][1], e))
+ elseif x[1][1] == "unquote-splicing"
+ then
+ local y = m.eval(x[1][2][1], e)
+ if not type.listp(y) then
+ fin = y
+ break
+ end
+ while y[2] do
+ table.insert(QQ, y[1])
+ y = y[2]
+ end
+ end
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]
+ table.insert(QQ, x[1])
end
+ x = x[2]
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]
+ return type.list(QQ, fin)
+ end,
+ unquote =
+ function (_, _)
+ error("unexpected", ",")
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
+ function (_, _)
+ error("unexpected", ",@")
+ end,
define =
function (r, e)
- assert_arity(r, 2, 2)
+ 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)
+ 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)
+ assert_arity(r,2)
+ return type.procedure(r[1], r[2], e, m.eval)
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]
+ assert_arity(r,3,3)
+ local test, conseq, alt = r[1], r[2][1], r[2][2][1]
if m.eval(test, e)
then return m.eval(conseq, e)
else return m.eval(alt, e)
end
end,
- -- TODO: include, import, define-syntax, ...
+ -- TODO: include, import, define-syntax ...
}
--- Aliases
-m.specials.lam = m.specials.lambda
-m.specials.def = m.specials.define
-function m.eval (x, env) -- TODO: specify ENV on all calls
- if type.isa(x, "symbol") then
+function m.eval (x, env)
+ if type.isp(x, "symbol") then
if env[x] == nil then
- error(string.format("Unbound variable: %s", x))
+ error("unbound symbol", x)
end
return env[x]
- elseif not type.islist(x) then
+ elseif not type.listp(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
+ if m.special_forms[op] then
+ return m.special_forms[op](args, env)
+ else -- procedure application
local fn = m.eval(op, env)
local params = {}
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 @@
+--- lam.load
+
+local m = {}
+local core = require("core")
+local eval = require("eval")
+local port = require("port")
+local read = require("read")
+local type = require("type")
+
+local function schemeprint (x)
+ -- possibly a candidate to put in a `write' library
+ if x == true then print("#t")
+ elseif x == false then print("#f")
+ elseif x == nil then return -- print("#<nil>")
+ else print(x)
+ end
+end
+
+local function handle_error (e)
+ local start = e:find(": ")
+ return e:sub(start + 2)
+end
+
+function m.load (filename, interactive)
+ -- interactive = { out = file/handle, prompt = string, }
+ local inport = port.input_port(filename)
+ if interactive then
+ io.output(interactive.out)
+ io.output():setvbuf("line")
+ else
+ io.output():setvbuf("no")
+ end
+ repeat
+ if interactive then
+ io.stderr:write(interactive.prompt or "")
+ io.stderr:flush()
+ end
+ -- read
+ local read_ok, form = xpcall(
+ function () return read.read(inport) end,
+ handle_error)
+ if form == port.eof then break end
+ if not read_ok then
+ io.stderr:write("error (read): ", form, "\n")
+ -- when interactive, errors should not be fatal, but
+ -- they should be in batch mode
+ inport:flush() -- avoid endless loop
+ if not interactive then return nil end
+ else
+ -- eval
+ local eval_ok, value = xpcall(
+ function ()
+ return eval.eval(form, core.environment)
+ end,
+ handle_error)
+ if not eval_ok then
+ io.stderr:write("error (eval): ", value, "\n")
+ if not interactive then return nil end
+ else
+ -- print
+ if interactive then schemeprint(value) end
+ end
+ end
+ until value == port.eof -- loop
+end
+
+--------
+return 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 @@
+--- lam.port --- port objects
+-- because the implementation for ports is fairly involved, they're in their own
+-- file outside of `type'.
+
+local m = {}
+local util = require("util")
+local error = util.error
+local tochars = util.tochars
+
+-- The EOF object is what the reader emits when it hits an end-of-file or use up
+-- a port.
+m.eof = setmetatable({}, {
+ __type = "eof",
+ __tostring = function () return "#<eof>" end,
+})
+
+---[[ INPUT PORTS ]]---
+
+-- return the next token from PORT, given READTABLE
+local function input_port_next_token (port, readtable)
+ repeat
+ if #port.buffer == 0 then
+ if port.file then
+ local ln = port.file:read()
+ if ln == nil then
+ return m.eof
+ end
+ port.buffer = tochars(ln)
+ else
+ return m.eof
+ end
+ end
+
+ local token, token_type
+ local c = port.buffer[1]
+ if readtable.chars[c] then
+ token, token_type, port.buffer =
+ readtable.chars[c](port.buffer)
+ else
+ for re, fn in pairs(readtable.regex) do
+ if c:match(re) then
+ token, token_type, port.buffer =
+ fn(port.buffer)
+ break
+ end
+ end
+ if token == nil then
+ token, token_type, port.buffer =
+ readtable.default(port.buffer)
+ end
+ end
+
+ port.buffer = port.buffer or {}
+ if token then
+ return token, token_type
+ end
+ until nil
+end
+
+function m.input_port (source, source_type)
+ -- SOURCE is the name of the file/string to read or nil; nil means
+ -- standard input. SOURCE_TYPE is one of "file", "string"; "file" is
+ -- the default.
+ local f, b
+ source_type = source_type or "file"
+ if source then
+ if source_type == "file" then
+ f = io.open(source, "r")
+ elseif source_type == "string" then
+ b = tochars(source)
+ else
+ error("input-port: bad type", source_type)
+ end
+ else
+ f = io.input() -- ignore SOURCE_TYPE
+ end
+ local t = {
+ file = f,
+ name = f and source or "[string]",
+ type = source_type,
+ buffer = b or {},
+ flush = function (self) self.buffer = {} end,
+ next = input_port_next_token, -- port:next(readtable)
+ close =
+ function (self)
+ if self.file then self.file:close() end
+ end,
+ }
+ local mt = {
+ __type = "input-port",
+ __tostring =
+ function (self)
+ return string.format("#<port %s>", self.name)
+ end,
+ }
+ return setmetatable(t, mt)
+end
+
+---[[ OUTPUT PORTS ]]---
+-- TODO
+
+--------
+return m
diff --git a/read.lua b/read.lua
index 332c919..6d55e23 100644
--- a/read.lua
+++ b/read.lua
@@ -1,166 +1,29 @@
--- lam.read
local m = {}
-local t = require "type"
-local utf8 = require "utf8"
-local pop = require("util").pop
+local type = require("type")
+local port = require("port")
+local eof, input_port = port.eof, port.input_port
+local util = require("util")
+local constantly, error, pop = util.constantly, util.error, util.pop
--- TODO:
--- - string reading
--- - probably more
-
-m.eof = setmetatable({}, {
- __type = "EOF",
- __tostring = function () return "#<eof>" end,
-})
-
-local function inport_next_token (port)
- local tok, toktype
- while true do
- if #port.line == 0 then
- if port.file then
- local ln = port.file:read()
- if ln == nil then return m.eof end
- port.line = m.tochars(ln)
- else
- return nil
- end
- end
- tok, toktype, port.line = m.scan(port.line)()
- port.line = port.line or {}
- if tok ~= nil then return tok, toktype end
- end
-end
-
-function m.inport (source, kind)
- -- KIND can be one of "file", "string"; defaults to "file"
- -- SOURCE is the name of the file or the string to read, or nil; if nil,
- -- read from standard input.
- local f, l
- local k = kind or "file"
- if source then
- if k == "file" then
- f = io.open(source, "r")
- elseif k == "string" then
- l = m.tochars(source)
- end
- else
- -- KIND is ignored here
- f = io.input()
- end
- local t = {
- file = f,
- filename = source,
- kind = kind,
- line = l or {},
- next_token = inport_next_token,
- }
- if t.file then t.close = function (self) self.file:close() end; end
- local mt = {
- __type = "port",
- __tostring =
- function (self)
- return string.format("#<port %s>",
- self.file or "(string)")
- end,
- }
- return setmetatable(t, mt)
-end
-
-function m.tochars (s)
- local chars = {}
- for _, code in utf8.codes(s) do
- table.insert(chars, code)
- end
- return chars
-end
-
---- Consumers
--- These take a table of characters (cs) and return:
--- a token, its type, and the rest of the characters
-
-local token_separator = "[^%s#()\"'`,@;]"
+local token_separators = "[%s#()\"'`,@;]"
local function consume_token (cs)
- local token = {}
- while #cs > 0 and cs[1]:match(token_separator) do
- table.insert(token, pop(cs))
+ local tok = {}
+ while #cs > 0 and not cs[1]:match(token_separators) do
+ local c = pop(cs)
+ table.insert(tok, c)
end
- return table.concat(token), "symbol", cs
+ return table.concat(tok), cs
end
-local function consume_whitespace (cs)
- while #cs > 0 and cs[1]:match("%s") do pop(cs) end
- return nil, nil, cs
-end
-
-local function consume_comment (cs)
- local comment = {}
- repeat table.insert(comment, pop(cs))
- until #cs == 0 or cs[1]:match("\n")
- return table.concat(comment), "comment", cs
-end
-
-local function idf (x)
- return function () return x end
-end
-
-local function numf (base)
- return function (token)
- local n = tonumber(token:sub(3), base)
- assert(n, "Can't read number: " .. token)
- return n
- end
-end
-
-local literals = {
- literal = {
- ["#t"] = idf(true),
- ["#true"] = idf(true),
- ["#f"] = idf(false),
- ["#false"] = idf(false),
- ["#\\space"] = idf(t.character(" ")),
- ["#\\tab"] = idf(t.character("\t")),
- ["#\\newline"] = idf(t.character("\n")),
- },
- match = {
- ["^#b"] = numf(2),
- ["^#o"] = numf(8),
- ["^#d"] = numf(10),
- ["^#x"] = numf(16),
- ["^#\\"] = function (tok) return t.character(tok:sub(3)) end,
- }
-}
-
-local function consume_literal (cs)
- -- whitespace and parantheses character literals.
- -- reverse the match test b/c it's already a complement
- if cs[2] == "\\" and not cs[3]:match(token_separator) then
- return type.character(cs[3])
- end
- pop(cs) -- discard '#'
- local token, value, cs = consume_token(cs) -- todo: vectors #(...)
- token = "#" .. token -- put '#' back
-
- if literals.literal[token] then
- value = literals.literal[token]()
- else
- for re, fn in pairs(literals.match) do
- if token:match(re) then
- value = fn(token)
- end
- end
- end
- -- TODO : if `nil' is to be a value in lam i'm going to have to figure
- -- out some kind of 'lam nil' and 'lua nil' or something..
- assert(value~=nil, "Can't read literal: " .. token)
-
- return value, "literal", cs
-end
+---[[ READ TABLE ]]---
---- Reading from a port
-
-m.readtable = {
+-- each function should take a list of characters and return the token, its
+-- type, and the rest of the characters
+m.readtable = {}
+m.readtable.chars = {
["("] = function (cs) return pop(cs), "open", cs end,
[")"] = function (cs) return pop(cs), "close", cs end,
["'"] = function (cs) return pop(cs), "quote", cs end,
@@ -175,109 +38,184 @@ m.readtable = {
return ",", "quote", cs
end
end,
- [";"] = consume_comment,
- ["#"] = consume_literal,
-}
+ [";"] = -- comment
+ function (cs)
+ local comment = {}
+ while #cs > 0 and not cs[1]:match("\n") do
+ table.insert(comment, pop(cs))
+ end
+ return table.concat(comment), "comment", cs
+ end,
+ ["#"] = -- literal
+ function (cs)
+ local tok
+ -- bail on just '#\'
+ if not (cs[2] and cs[3]) then
+ cs = {}
+ error("bad literal", "#\\")
+ end
---- TODO: Figure out how to read #f and #n properly
+ -- read '#\ ' and such correctly
+ if cs[2] == "\\" and cs[3]:match(token_separators) then
+ pop(cs) -- remove '\'
+ pop(cs) -- remove next character
+ return type.character(cs[1])
+ end
--- Return an iterator over a character table, so you can do:
--- for token, chars in scan(cs) do ... end
-function m.scan (cs)
- local cs = cs
- return function ()
- if not next(cs) then return nil end
- local token, toktype
- while true do
- if m.readtable[cs[1]] then
- token, toktype, cs = m.readtable[cs[1]](cs)
- return token, toktype, cs
- elseif cs[1]:match("%s") then
- --- should this just continue the loop?
- -- i.e., remove `return'
- return consume_whitespace(cs)
- elseif cs[1]:match("[%d.+-]") then
- -- numbers, +, -, ., ...
- local token, _, cs = consume_token(cs)
- if token:match("[-+]") or token == "..." then
- return token, "symbol", cs
- elseif token == "." then
- return token, "dot", cs
- else
- local n = tonumber(token)
- assert (n ~= nil, "Bad number: "..n)
- return n, "number", cs
- end
+ pop(cs) -- discard '#' ...
+ tok, cs = consume_token(cs)
+ tok = "#" .. tok -- ... then put it back
+
+ local val
+ if m.readtable.literals.lit[tok] then
+ val = m.readtable.literals.lit[tok]
else
- return consume_token(cs)
+ for re, fn in pairs(m.readtable.literals.regex)
+ do
+ if tok:match(re) then
+ val = fn(tok)
+ end
+ end
+ end
+
+ if val == nil then
+ error("bad literal", tok)
+ end
+ return val, "literal", cs
+ end,
+}
+m.readtable.regex = {
+ ["%s"] = -- whitespace
+ function (cs)
+ while #cs > 0 and cs[1]:match("%s") do
+ pop(cs)
+ end
+ return false, nil, cs
+ end,
+ ["[%d.+-]"] = -- numbers and symbols +, -, ., and ...
+ function (cs)
+ local tok
+ tok, cs = consume_token(cs)
+ if tok:match("^[-+]$") or tok == "..." then
+ return tok, "symbol", cs
+ elseif tok == "." then
+ return tok, "dot", cs
+ else -- number
+ local n = tonumber(tok)
+ if not n then
+ error("bad number", n)
+ end
+ return n, "number", cs
end
+ end,
+}
+m.readtable.default = -- default action if nothing else matches
+ function (cs)
+ local tok, cs = consume_token(cs)
+ return tok, "symbol", cs
+ end
+
+-- convenience function to make writing the regexen rules easier below
+local function based_num (base)
+ return function (token)
+ local n = tonumber(token:sub(3), base)
+ if not n then
+ error("bad number", token)
end
+ return n
end
end
-function m.readchar (port)
- if #port.line > 0 then
- local ch = pop(port.line)
- return ch
- else
- return port.file and port.file.read(1)
- end
+m.readtable.literals = {
+ lit = {
+ ["#t"] = true,
+ ["#true"] = true,
+ ["#f"] = false,
+ ["#false"] = false,
+ },
+ regex = {
+ ["^#b"] = based_num(2),
+ ["^#o"] = based_num(8),
+ ["^#d"] = based_num(10),
+ ["^#x"] = based_num(16),
+ ["^#\\."] =
+ function (tok)
+ return type.character(tok:sub(3))
+ end,
+ },
+}
+-- add named characters
+for char, name in pairs(type.character_names) do
+ m.readtable.literals.lit["#\\"..name] = type.character(char)
end
+---[[ READER MACROS ]]---
+-- Each of these are named after the type of the token read and contain
+-- function taking (TOKEN, TYPE, PORT) and returning a lisp object
+
m.readmacros = {
+ close =
+ function (token, _, _)
+ error("unexpected", token)
+ end,
quote =
- function (tok, toktype, port)
+ function (token, _, port)
local qs = {
["'"] = "quote",
["`"] = "quasiquote",
[","] = "unquote",
[",@"] = "unquote-splicing",
}
- if not qs[tok] then
- error(string.format("Bad quote: '%s'\n", tok))
+ if not qs[token] then
+ error("bad quote", token)
end
- local Q = {qs[tok]}
+ local Q = {qs[token]}
table.insert(Q, m.read(port))
- return t.list(Q)
+ return type.list(Q)
end,
- comment = idf(nil)
+ comment = constantly(nil), -- throw comments away
}
+---[[ READ ]]---
+
function m.read (port)
- local function read_ahead (tok, toktype)
- if tok == m.eof then error("Unexpected EOF") end
- if toktype == "open" then
+ local function read_ahead(token, token_type)
+ if token == eof then error("unexpected", token) end
+ if token_type == "open" then
+ -- this must be defined here because it calls read_ahead
+ -- recursively.
local L = {}
- while true do
- local tok, toktype = port:next_token()
- if toktype == "close" then
- return t.list(L)
- elseif toktype == "dot" then
+ repeat
+ token, token_type = port:next(m.readtable)
+ if token_type == "close" then
+ return type.list(L)
+ elseif token_type == "dot" then
local fin = m.read(port)
- port:next_token() -- throw away ')'
- return t.list(L, fin)
+ port:next(m.readtable) -- discard ')'
+ return type.list(L, fin)
else
table.insert(L,
- read_ahead(tok, toktype))
+ read_ahead(token, token_type))
end
- end
- elseif toktype == "close" then
- error("Unexpected ')'")
- elseif m.readmacros[toktype] then
- return m.readmacros[toktype](tok, toktype, port)
- else return tok
+ until nil
+ elseif m.readmacros[token_type] then
+ return m.readmacros[token_type](token, token_type, port)
+ else
+ return token
end
end
- -- body of read
- local tok1, toktype1 = port:next_token()
- if tok1 == m.eof then return m.eof
- else return read_ahead(tok1, toktype1)
+ ---
+ local token1, type1 = port:next(m.readtable)
+ if token1 == eof then
+ return eof
+ else
+ return read_ahead(token1, type1)
end
end
function m.read_string (str)
- return m.read(m.inport(str, "string"))
+ return m.read(input_port(str, "string"))
end
----
+--------
return m
diff --git a/repl.lua b/repl.lua
index c4a6546..4bdd918 100644
--- a/repl.lua
+++ b/repl.lua
@@ -1,25 +1,9 @@
--- lam.repl
local m = {}
-local _r = require("read")
-local read, inport, read_string, eof =
- _r.read, _r.inport, _r.read_string, _r.eof
-local eval = require("eval").eval
+local load = require("load").load
-local function schemeprint (x)
- -- if x == nil then return end
- if x == true then
- print("#t")
- elseif x == false then
- print("#f")
- elseif x == nil then
- print("#<nil>")
- else
- print(x)
- end
-end
-
-local lam = [[
+m.logo = [[
@,,,@
<|^ ^|> l a m
| /) 0015
@@ -27,66 +11,9 @@ local lam = [[
-------------
]]
-local function handle_error (e)
- local start = e:find(": ")
- return e:sub(start + 2)
-end
-
-function m.read_eval (filename, interactive)
- -- interactive = { out = file or handle, prompt = string, }
- local inport = inport(filename)
- local prompt = interactive and interactive.prompt or "> "
- if interactive then
- io.output(interactive.out or io.stdout)
- io.write(lam)
- io.output():setvbuf("line")
- else
- io.output():setvbuf("no")
- end
- repeat
- if interactive then
- io.stderr:write(prompt)
- io.stderr:flush()
- end
- -- read
- local ok, x = xpcall(
- function ()
- local nxt = read(inport)
- return nxt
- end,
- handle_error
- )
- if not ok then
- io.stderr:write("(read) not ok: ", x, "\n")
- -- in interactive mode, errors should not be fatal. in
- -- batch mode, they should be.
- if not interactive then return nil end
- end
- -- eval
- if ok then
- local ok, v = xpcall(
- function () return eval(x) end,
- handle_error
- )
- if not ok then
- io.stderr:write("(eval) not ok: ", v, "\n")
- if not interactive then return nil end
- end
- -- print
- if ok and interactive then schemeprint(v) end
- elseif interactive then
- ok = "recover"
- end
- until x == eof -- loop
- inport:close()
-end
-
function m.repl (prompt)
- return m.read_eval(nil, { prompt = prompt, })
-end
-
-function m.load (filename)
- return m.read_eval(filename)
+ io.stderr:write(m.logo)
+ return load(nil, {prompt = prompt or "> ", })
end
--------
diff --git a/type.lua b/type.lua
index f119270..c205468 100644
--- a/type.lua
+++ b/type.lua
@@ -1,112 +1,192 @@
--- 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"
-utf_char, utf_codepoint = utf8.char, utf8.codepoint
+local utf8 = require("utf8")
+local util = require("util")
+local tochars, error, constantly = util.tochars, util.error, util.constantly
---- atomic types
+---[[ ATOMIC TYPES ]]---
--- true, false and nil are just ... true, false, and nil
+-- 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",
+}
--- Characters contain both their string reputations and their codepoints
function m.character (x)
- -- is storing a character with its string and numerical representation
- -- overkill? ... maybe.
local s = tostring(x)
- local uc = utf_codepoint(s)
- local t = { -- String representation of the character
- v = utf_char(uc),
+ local uc = utf8.codepoint(s)
+ local t = {
+ v = utf8.char(uc),
u = uc,
}
local mt = {
- __type = "character",
- __eq = function (self) return self.v end,
+ __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 v == "\n" then
- return "#\\newline"
- elseif v == " " then
- return "#\\space"
- else
- return "#\\" .. v
+ if m.character_names[v] then
+ v = m.character_names[v]
end
+ return "#\\" .. v
end,
}
return setmetatable(t, mt)
end
--- a symbol is just a string, unadorned. I was going to have a character be
--- represented by a one-character string, but then it would be indistinguishable
--- from a one-character symbol internally.
-m.symbol = tostring
+---[[ PROCEEDURES AND ENVIRONMENTS ]]---
--- for now, number will just be lua's number. At *some* point, it will be the
--- whole numeric tower, yaaayyy
-m.number = tonumber
+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
--- strings are wrapped strings
-function m.string (x)
- local x = tostring(x)
+function m.procedure (params, body, env, eval)
local t = {
- v = x,
- escape =
- function (self)
- return self.v:gsub("[\\\"]", "\\%1")
- end,
+ params = params,
+ body = body,
+ env = env,
+ eval = eval,
}
local mt = {
- __type = "string",
+ __type = "procedure",
__tostring =
function (self)
- return "\"" .. self:escape() .. "\""
+ 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
--- null () is both an atom and a list (yay)
--- this one is NOT a function
+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 (self) return "()" end,
+ __tostring = function () return "()" end,
})
---- collection types
+function m.nullp (x)
+ return x == m.null
+end
+
+---[[ COLLECTION TYPES ]]---
--- cons are lisp's fundamental collection type
+-- 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 = "cons",
+ __type = "pair", -- scheme name
__tostring =
function (self)
- local out = {}
- local car, cdr = self[1], self[2]
- while cdr do
- table.insert(out, tostring(car))
- if m.luatype(cdr) == "table" then
- car = cdr[1]
- cdr = cdr[2]
+ 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(out, ".")
- table.insert(out, cdr)
+ table.insert(t, ".")
+ table.insert(t, p[2])
break
end
end
- return "(" .. table.concat(out, " ") .. ")"
+ return string.format("(%s)",
+ table.concat(t, " "))
end,
__len =
function (self)
- local function go (lis, acc)
+ local function go (x, acc)
-- improper lists don't have lengths
- -- ... but don't error here.
- if not m.isa(lis, "cons") then
+ if not m.isp(x, "pair") then
return nil
end
- if lis[2] == m.null then return acc
- else return go(lis[2], acc+1)
+ if m.nullp(x[2]) then
+ return acc
+ else
+ return go(x[2], acc + 1)
end
end
return go(self, 1)
@@ -115,74 +195,87 @@ function m.cons (a, b)
return setmetatable(t, mt)
end
--- lists are singly-linked cons cells
-function m.list (items, last)
- -- ITEMS is a table and LAST is an optional final cdr. If it's nil, the
- -- list is a "proper" list; that is, it ends in ().
+-- 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(last or m.null, items)
+ return tolist(final or m.null, items)
end
--- convert a list to a lua table
-function m.totable (cons)
- local t = {}
- local car, cdr = cons[1], cons[2]
- while cdr do
- table.insert(t, car)
- if m.luatype(cdr) == "table" then
- car = cdr[1]
- cdr = cdr[2]
- else
- table.insert(t, cdr)
- end
- end
- return t
+-- 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
--- testing types
+---[[ TYPE DETECTION AND PREDICATES ]]---
--- we love name collisions
+-- 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 m.luatype(x) == "string" then
- return "symbol"
- elseif getmetatable(x) and getmetatable(x).__type then
+ 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
-function m.isa (x, t)
+--- Predicates are named with a `p', lisp-style
+
+-- is X of type T ?
+function m.isp (x, t)
return m.lamtype(x) == t
end
-function m.islist (x)
- -- TODO: detect circular lists
- if x == m.null then
- return true
- elseif m.isa(x, "cons") then
- return m.islist(x[2])
- else
- return false
+-- 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
-function m.isatom (x)
- if x == m.null then
- return true -- '() is the only value that is both atom and list
- elseif m.luatype(x) == "table" then
- -- generally, anything that's implemented as a table is *not* an
- -- atom, at least as I will define it. (it's not an actual
- -- scheme procedure)
- return false
- else
- return true
+-- 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
--------
diff --git a/util.lua b/util.lua
index 8fedbf7..10460a2 100644
--- a/util.lua
+++ b/util.lua
@@ -1,22 +1,35 @@
---- lam.util
+--- lam.util --- utility functions
local m = {}
+local string = string
+local utf8 = require("utf8")
+m.luaerror = error
+
+-- signal an error
+-- WHERE is where in the process; DESC is a description of the error; the rest
+-- are "irritants"
+function m.error (desc, ...)
+ m.luaerror(string.format("%s: %s", desc, table.concat({...}, " ")
+ ))
+end
+
+-- remove an element from the front of TBL
function m.pop (tbl)
- --[[ Remove the first element from TBL. ]]
return table.remove(tbl, 1)
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(string.format("Wrong arity: %s; expecting %s",
- rlen,
- rmin == rmax and rmin or (rmin..".."..rmax)))
+function m.tochars (str)
+ local cs = {}
+ for _, code in utf8.codes(str) do
+ table.insert(cs, code)
end
+ return cs
+end
+
+function m.constantly (x)
+ return function () return x end
end
----
+--------
return m
--
cgit 1.4.1-21-gabe81