Reorganization

1 files changed, 192 insertions, 99 deletions

@@ -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
 
 --------