about summary refs log tree commit diff stats
path: root/core.lua
diff options
context:
space:
mode:
Diffstat (limited to 'core.lua')
-rw-r--r--core.lua241
1 files changed, 124 insertions, 117 deletions
diff --git a/core.lua b/core.lua index fd78997..20c6b5c 100644 --- a/core.lua +++ b/core.lua
@@ -1,131 +1,138 @@
1--- lam.core --- core procedures 1--- lam.core --- core procedures
2 2
3local m = {} 3local dump = require("dump")
4local type = require "type" 4local type = require("type")
5local isa, null = type.isa, type.null 5local null = type.null
6local math = math 6local assert_arity = type.assert_arity
7local dump = require("dump").dump
8-- local load = require("repl").load -- circular dependency :<
9local util = require "util"
10local assert_arity = util.assert_arity
11 7
12local function fold (kons, knil, r) 8local function fold (kons, knil, r)
13 if r == null then 9 if r == null then
14 return knil 10 return knil
15 else 11 else
16 local step, early_return = kons(r[1], knil) 12 local step, early_return = kons(r[1], knil)
17 if early_return then return step end 13 if early_return then return early_return end
18 return fold(kons, step, r[2]) 14 return fold(kons, step, r[2])
19 end 15 end
20end 16end
21 17
22m.env = { -- all functions here take R, which is the list of arguments 18local env = {}
23 ------- equivalence 19
24 ["eqv?"] = 20---[[ EQUIVALENCE ]]---
25 function (r) 21
26 assert_arity(r, 2, 2) 22env["eqv?"] = function (r)
27 return r[1] == r[2][1] 23 assert_arity(r,2,2)
28 end, 24 return r[1] == r[2][1]
29 ["eq?"] = 25end
30 function (r) 26-- from what i understand of the spec, it's okay that eqv? and eq? are the same
31 assert_arity(r, 2, 2) 27env["eq?"] = env["eqv?"]
32 -- from how i understand the Scheme spec, it's okay to 28
33 -- make `eqv?' and `eq?' the same. 29---[[ TYPES ]]---
34 return r[1] == r[2][1] 30
35 end, 31env["boolean?"] = function (r)
36 -- equal? can be done in-library 32 assert_arity(r,1,1)
37 ------- i/o 33 return r[1] == false or r[1] == true
38 display = 34end
39 function (r) 35
40 assert_arity(r, 1, 1) 36env["port?"] = function (r)
41 io.write(tostring(r[1])) 37 assert_arity(r,1,1)
42 end, 38 return type.isp(r[1], "input-port") or type.isp(r[1], "output-port")
43 newline = 39end
44 function (r) 40
45 assert_arity(r, 0, 0) 41for _, t in ipairs {
46 io.write("\n") 42 "symbol",
47 end, 43 -- todo: vector
48 dump = 44 "procedure",
49 function (r) 45 "pair",
50 assert_arity(r, 1, 1) 46 "number",
51 return dump(r[1]) 47 "string",
52 end, 48 "port",
53 --[[ load = -- circular dependency :< 49} do
54 function (r) 50 env[t.."?"] = function (r)
55 assert_arity(r, 1, 1) 51 assert_arity(r,1,1)
56 load(r[1]) 52 return type.isp(r[1], t)
57 end, 53 end
58 --]] 54end
59 ------- numbers 55
60 -- todo: assert all of these are numbers 56---[[ NUMBERS ]]---
61 ["number?"] = 57
62 function (r) 58env["="] = function (r)
63 assert_arity(r, 1, 1) 59 if r[1] == nil then return true end
64 return isa(r[1], "number") 60 if r[2] == nil then return true end
65 end, 61 while r[2] ~= null do
66 ["="] = 62 if r[1] ~= r[2][1] then return false end
67 function (r) 63 r = r[2]
68 if r[1] == nil then return true end 64 end
69 if r[2] == nil then return true end 65 return true
70 while r[2] ~= null do 66end
71 if r[1] ~= r[2][1] then return false end 67
72 r = r[2] 68env["<"] = function (r)
73 end 69 if r[1] == nil then return true end
74 return true 70 if r[2] == nil then return true end
75 end, 71 while r[2] ~= null do
76 ["<"] = 72 if r[1] >= r[2][1] then return false end
77 function (r) 73 r = r[2]
78 if r[1] == nil then return true end 74 end
79 if r[2] == nil then return true end 75 return true
80 while r[2] ~= null do 76end
81 if r[1] >= r[2][1] then return false end 77env[">"] = function (r)
82 r = r[2] 78 if r[1] == nil then return true end
83 end 79 if r[2] == nil then return true end
84 return true 80 while r[2] ~= null do
85 end, 81 if r[1] <= r[2][1] then return false end
86 [">"] = 82 r = r[2]
87 function (r) 83 end
88 if r[1] == nil then return true end 84 return true
89 if r[2] == nil then return true end 85end
90 while r[2] ~= null do 86env["<="] = function (r) return not env[">"](r) end
91 if r[1] <= r[2][1] then return false end 87env[">="] = function (r) return not env["<"](r) end
92 r = r[2] 88
93 end 89env["+"] = function (r)
94 return true 90 return fold(function (a, b) return a + b end, 0, r)
95 end, 91end
96 ["<="] = function (r) return not m.env[">"](r) end, 92
97 [">="] = function (r) return not m.env["<"](r) end, 93env["-"] = function (r)
98 ------- math 94 if r == null then return -1 end
99 ["+"] = 95 if r[2] == null then return (- r[1]) end
100 function (r) 96 return fold(function (a, b)
101 return fold(function (a, b) return a + b end, 0, r) 97 return a - b
102 end, 98 end, r[1], r[2])
103 ["-"] = 99end
104 function (r) 100
105 if r == null then return -1 end 101env["*"] = function (r)
106 if r[2] == null then return (- r[1]) end 102 local function go (a, b)
107 return fold(function (a, b) 103 if a == 0 or b == 0 then
108 return a - b 104 return 0, 1
109 end, r[1], r[2]) 105 end
110 end, 106 return a * b
111 ["*"] = 107 end
112 function (r) 108 return fold(go, 1, r)
113 local function go (a, b) 109end
114 if a == 0 or b == 0 then 110
115 return 0, 1 111env["/"] = function (r)
116 end 112 assert_arity(r,1)
117 return a * b 113 if r[2] == null then return (1 / r[1]) end
118 end 114 return fold(function (a, b) return a / b end,
119 return fold(go, 1, r) 115 r[1], r[2])
120 end, 116end
121 ["/"] = 117
122 function (r) 118---[[ INPUT / OUTPUT ]]---
123 assert_arity(r, 1) 119
124 if r[2] == null then return (1 / r[1]) end 120env.dump = function (r)
125 return fold(function (a, b) return a / b end, 121 assert_arity(r,1,1)
126 r[1], r[2]) 122 return dump.dump(r[1])
127 end, 123end
128} 124
125env.display = function (r)
126 assert_arity(r,1,1)
127 io.write(r[1])
128end
129
130env.newline = function (r)
131 assert_arity(r,0,0)
132 io.write("\n")
133end
129 134
130-------- 135--------
131return m 136return {
137 environment = env,
138}
© 2022 C. Duckworth. generated by cgit. comments, issues, and patches welcome at < git at acdw dot net >.