about summary refs log tree commit diff stats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--core.lua117
-rw-r--r--eval.lua88
-rw-r--r--util.lua31
3 files changed, 121 insertions, 115 deletions
diff --git a/core.lua b/core.lua index dec4a39..7891f3a 100644 --- a/core.lua +++ b/core.lua
@@ -4,7 +4,8 @@ local m = {}
4local type = require "type" 4local type = require "type"
5local isa, null = type.isa, type.null 5local isa, null = type.isa, type.null
6local math = math 6local math = math
7local proc = require("util").proc 7local util = require "util"
8local assert_arity = util.assert_arity
8 9
9local function fold (kons, knil, r) 10local function fold (kons, knil, r)
10 if r == null then 11 if r == null then
@@ -18,71 +19,73 @@ end
18 19
19m.env = { -- all functions here take R, which is the list of arguments 20m.env = { -- all functions here take R, which is the list of arguments
20 ------- numbers 21 ------- numbers
21 ["number?"] = proc(1, function (r) return isa(r[1], "number") end), 22 ["number?"] =
23 function (r)
24 assert_arity(r, 1, 1)
25 return isa(r[1], "number")
26 end,
22 ["="] = 27 ["="] =
23 proc({0}, function (r) 28 function (r)
24 if r[1] == nil then return true end 29 if r[1] == nil then return true end
25 if r[2] == nil then return true end 30 if r[2] == nil then return true end
26 while r[2] ~= null do 31 while r[2] ~= null do
27 if r[1] ~= r[2][1] then return false end 32 if r[1] ~= r[2][1] then return false end
28 r = r[2] 33 r = r[2]
29 end 34 end
30 return true 35 return true
31 end), 36 end,
32 ["<"] = 37 ["<"] =
33 proc({0}, function (r) 38 function (r)
34 if r[1] == nil then return true end 39 if r[1] == nil then return true end
35 if r[2] == nil then return true end 40 if r[2] == nil then return true end
36 while r[2] ~= null do 41 while r[2] ~= null do
37 if r[1] >= r[2][1] then return false end 42 if r[1] >= r[2][1] then return false end
38 r = r[2] 43 r = r[2]
39 end 44 end
40 return true 45 return true
41 end), 46 end,
42 [">"] = 47 [">"] =
43 proc({0}, function (r) 48 function (r)
44 if r[1] == nil then return true end 49 if r[1] == nil then return true end
45 if r[2] == nil then return true end 50 if r[2] == nil then return true end
46 while r[2] ~= null do 51 while r[2] ~= null do
47 if r[1] <= r[2][1] then return false end 52 if r[1] <= r[2][1] then return false end
48 r = r[2] 53 r = r[2]
49 end 54 end
50 return true 55 return true
51 end), 56 end,
52 ["<="] = proc({0}, function (r) return not m.env[">"](r) end), 57 ["<="] = function (r) return not m.env[">"](r) end,
53 [">="] = proc({0}, function (r) return not m.env["<"](r) end), 58 [">="] = function (r) return not m.env["<"](r) end,
54 ------- math 59 ------- math
55 ["+"] = 60 ["+"] =
56 proc({0}, function (r) 61 function (r)
57 return fold(function (a, b) 62 return fold(function (a, b) return a + b end, 0, r)
58 return a + b 63 end,
59 end, 0, r)
60 end),
61 ["-"] = 64 ["-"] =
62 proc({0}, function (r) 65 function (r)
63 if r == null then return -1 end 66 if r == null then return -1 end
64 if r[2] == null then return (- r[1]) end 67 if r[2] == null then return (- r[1]) end
65 return fold(function (a, b) 68 return fold(function (a, b)
66 return a - b 69 return a - b
67 end, r[1], r[2]) 70 end, r[1], r[2])
68 end), 71 end,
69 ["*"] = 72 ["*"] =
70 proc({0}, function (r) 73 function (r)
71 local function go (a, b) 74 local function go (a, b)
72 if a == 0 or b == 0 then 75 if a == 0 or b == 0 then
73 return 0, 1 76 return 0, 1
74 end
75 return a * b
76 end 77 end
77 return fold(go, 1, r) 78 return a * b
78 end), 79 end
80 return fold(go, 1, r)
81 end,
79 ["/"] = 82 ["/"] =
80 proc({1}, function (r) 83 function (r)
81 if r[2] == null then return (1 / r[1]) end 84 assert_arity(r, 1)
82 return fold(function (a, b) 85 if r[2] == null then return (1 / r[1]) end
83 return a / b 86 return fold(function (a, b) return a / b end,
84 end, r[1], r[2]) 87 r[1], r[2])
85 end), 88 end,
86} 89}
87 90
88-------- 91--------
diff --git a/eval.lua b/eval.lua index 53292d0..60369a9 100644 --- a/eval.lua +++ b/eval.lua
@@ -20,7 +20,7 @@ function m.environ (inner, outer)
20 return setmetatable(inner, mt) 20 return setmetatable(inner, mt)
21end 21end
22 22
23local function call_proc (proc, r) 23local function procedure_call (proc, r)
24 local function doargs (p, r, e) 24 local function doargs (p, r, e)
25 if p == type.null and r == type.null then return e end 25 if p == type.null and r == type.null then return e end
26 if type.isa(p, "symbol") then 26 if type.isa(p, "symbol") then
@@ -50,57 +50,75 @@ function m.procedure (params, body, env)
50 } 50 }
51 local mt = { 51 local mt = {
52 __type = "procedure", 52 __type = "procedure",
53 __call = call_proc, 53 __call = procedure_call,
54 } 54 }
55 return setmetatable(t, mt) 55 return setmetatable(t, mt)
56end 56end
57 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
80 end
81 else
82 table.insert(QQ, car)
83 end
84 car, cdr = cdr[1], cdr[2]
85 end
86 return type.list(QQ, fin)
87end
88
58m.specials = { 89m.specials = {
59 -- each of these takes R (a list of args) and E (an environment) 90 -- each of these takes R (a list of args) and E (an environment)
60 quote = function (r, e) return r[1] end, 91 quote =
61 quasiquote =
62 function (r, e) 92 function (r, e)
63 local x = r[1] 93 assert_arity(r, 1, 1)
64 if not type.islist(x) or x == type.null then 94 return r[1]
65 return x
66 end
67 local QQ, fin = {}, nil
68 local car, cdr = x[1], x[2]
69 while cdr do
70 if type.islist(car) then
71 if car[1] == "unquote" then
72 table.insert(QQ,
73 m.eval(car[2][1], e))
74 elseif car[1] == "unquote-splicing" then
75 local usl = m.eval(car[2][1], e)
76 if not type.islist(usl) then
77 fin = usl
78 break
79 end
80 while usl[2] do
81 table.insert(QQ, usl[1])
82 usl = usl[2]
83 end
84 end
85 else
86 table.insert(QQ, car)
87 end
88 car, cdr = cdr[1], cdr[2]
89 end
90 return type.list(QQ, fin)
91 end, 95 end,
96 quasiquote = handle_quasiquote,
92 -- if not inside quasiquote, unquote and unquote-splicing are errors 97 -- if not inside quasiquote, unquote and unquote-splicing are errors
93 unquote = function () error("Unexpected unquote") end, 98 unquote = function () error("Unexpected unquote") end,
94 ["unquote-splicing"] = 99 ["unquote-splicing"] =
95 function () error("Unexpected unquote-splicing") end, 100 function () error("Unexpected unquote-splicing") end,
96 -- define variables 101 -- define variables
97 define = function (r, e) rawset(e, r[1], m.eval(r[2][1], e)) end, 102 define =
98 ["set!"] = function (r, e) e[r[1]] = m.eval(r[2][1], e) end, 103 function (r, e)
104 assert_arity(r, 2, 2)
105 rawset(e, r[1], m.eval(r[2][1], e))
106 end,
107 ["set!"] =
108 function (r, e)
109 assert_arity(r, 2, 2)
110 e[r[1]] = m.eval(r[2][1], e)
111 end,
99 -- y'know, ... lambda 112 -- y'know, ... lambda
100 lambda = function (r, e) return m.procedure(r[1], r[2], e) end, 113 lambda =
114 function (r, e)
115 assert_arity(r, 2)
116 return m.procedure(r[1], r[2], e)
117 end,
101 -- control flow 118 -- control flow
102 ["if"] = 119 ["if"] =
103 function (r, e) 120 function (r, e)
121 assert_arity(r, 3, 3)
104 local test, conseq, alt = 122 local test, conseq, alt =
105 r[1], r[2][1], r[2][2][1] 123 r[1], r[2][1], r[2][2][1]
106 if m.eval(test) 124 if m.eval(test)
diff --git a/util.lua b/util.lua index d151858..8fedbf7 100644 --- a/util.lua +++ b/util.lua
@@ -7,29 +7,14 @@ function m.pop (tbl)
7 return table.remove(tbl, 1) 7 return table.remove(tbl, 1)
8end 8end
9 9
10function m.proc (arity, fn) 10function m.assert_arity (r, min, max)
11 --[[ Wrap RN in a check that for its ARITY. 11 local rmin = min or 0
12 ARITY can be a number, the minimum number of arguments, 12 local rmax = max or 1/0 -- infinity
13 or a table {MIN, MAX}. If MIN is nil or absent, it's 0; 13 local rlen = #r
14 if MAX is nil or absent, it's infinity. MIN and MAX are 14 if rlen < rmin or rlen > rmax then
15 both inclusive. 15 error(string.format("Wrong arity: %s; expecting %s",
16 ]] 16 rlen,
17 local rmin, rmax, rstr 17 rmin == rmax and rmin or (rmin..".."..rmax)))
18 if type(arity) ~= "table" then
19 rmin, rmax = arity, arity
20 rstr = rmin
21 else
22 rmin, rmax = arity[1] or 0, arity[2] or 1/0 -- infinity
23 rstr = rmin .. ".." .. rmax
24 end
25 return function (r)
26 local rlen = r and #r or 0
27 if rlen < rmin or rlen > rmax then
28 error(string.format("Wrong arity: %s, need %s",
29 rlen,
30 rstr))
31 end
32 return fn(r)
33 end 18 end
34end 19end
35 20
© 2022 C. Duckworth. generated by cgit. comments, issues, and patches welcome at < git at acdw dot net >.