diff options
-rw-r--r-- | core.lua | 117 | ||||
-rw-r--r-- | eval.lua | 88 | ||||
-rw-r--r-- | util.lua | 31 |
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 = {} | |||
4 | local type = require "type" | 4 | local type = require "type" |
5 | local isa, null = type.isa, type.null | 5 | local isa, null = type.isa, type.null |
6 | local math = math | 6 | local math = math |
7 | local proc = require("util").proc | 7 | local util = require "util" |
8 | local assert_arity = util.assert_arity | ||
8 | 9 | ||
9 | local function fold (kons, knil, r) | 10 | local function fold (kons, knil, r) |
10 | if r == null then | 11 | if r == null then |
@@ -18,71 +19,73 @@ end | |||
18 | 19 | ||
19 | m.env = { -- all functions here take R, which is the list of arguments | 20 | m.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) |
21 | end | 21 | end |
22 | 22 | ||
23 | local function call_proc (proc, r) | 23 | local 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) |
56 | end | 56 | end |
57 | 57 | ||
58 | local 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) | ||
87 | end | ||
88 | |||
58 | m.specials = { | 89 | m.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) |
8 | end | 8 | end |
9 | 9 | ||
10 | function m.proc (arity, fn) | 10 | function 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 |
34 | end | 19 | end |
35 | 20 | ||