1 files changed, 75 insertions, 0 deletions

@@ -0,0 +1,75 @@
+--- lam.core --- core procedures
+
+local m = {}
+local type = require "type"
+local isa, null = type.isa, type.null
+local math = math
+
+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
+                return fold(kons, step, r[2])
+        end
+end
+
+m.env = { -- all functions here take R, which is the list of arguments
+        ------- numbers
+        ["number?"] = function (r) return isa(r[1], "number") end,
+        ["="] =
+                function (r)
+                        local function go (a, b)
+                                if a ~= b then return false, 1 end
+                                return b
+                        end
+                        return fold(go, r[1], r[2]) and true
+                end,
+        ["<"] =
+                function (r)
+                        local function go (a, b)
+                                if a >= b then return false, 1 end
+                                return b
+                        end
+                        return fold(go, r[1], r[2]) and true
+                end,
+        [">"] =
+                function (r)
+                        local function go (a, b)
+                                if a <= b then return false, 1 end
+                                return b
+                        end
+                        return fold(go, r[1], r[2]) and 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)
+                        if r == null then error("Wrong arity") end
+                        if r[2] == null then return (1 / r[1]) end
+                        return fold(function (a, b) return a/b end, r[1], r[2])
+                end,
+}
+
+--------
+return m