Commit | Line | Data |
---|---|---|
8c7587af MK |
1 | @include "types.awk" |
2 | @include "reader.awk" | |
3 | @include "printer.awk" | |
4 | @include "env.awk" | |
5 | ||
6 | function READ(str) | |
7 | { | |
8 | return reader_read_str(str) | |
9 | } | |
10 | ||
11 | function eval_ast(ast, env, i, idx, len, new_idx, ret) | |
12 | { | |
13 | switch (ast) { | |
14 | case /^'/: | |
15 | ret = env_get(env, ast) | |
16 | if (ret !~ /^!/) { | |
17 | types_addref(ret) | |
18 | } | |
19 | return ret | |
20 | case /^[([]/: | |
21 | idx = substr(ast, 2) | |
22 | len = types_heap[idx]["len"] | |
23 | new_idx = types_allocate() | |
24 | for (i = 0; i < len; ++i) { | |
25 | ret = EVAL(types_addref(types_heap[idx][i]), env) | |
26 | if (ret ~ /^!/) { | |
27 | types_heap[new_idx]["len"] = i | |
28 | types_release(substr(ast, 1, 1) new_idx) | |
29 | return ret | |
30 | } | |
31 | types_heap[new_idx][i] = ret | |
32 | } | |
33 | types_heap[new_idx]["len"] = len | |
34 | return substr(ast, 1, 1) new_idx | |
35 | case /^\{/: | |
36 | idx = substr(ast, 2) | |
37 | new_idx = types_allocate() | |
38 | for (i in types_heap[idx]) { | |
39 | if (i ~ /^[":]/) { | |
40 | ret = EVAL(types_addref(types_heap[idx][i]), env) | |
41 | if (ret ~ /^!/) { | |
42 | types_release("{" new_idx) | |
43 | return ret | |
44 | } | |
45 | types_heap[new_idx][i] = ret | |
46 | } | |
47 | } | |
48 | return "{" new_idx | |
49 | default: | |
50 | return ast | |
51 | } | |
52 | } | |
53 | ||
54 | function EVAL_def(ast, env, idx, sym, ret, len) | |
55 | { | |
56 | idx = substr(ast, 2) | |
57 | if (types_heap[idx]["len"] != 3) { | |
58 | len = types_heap[idx]["len"] | |
59 | types_release(ast) | |
60 | env_release(env) | |
61 | return "!\"Invalid argument length for 'def!'. Expects exactly 2 arguments, supplied" (len - 1) "." | |
62 | } | |
63 | sym = types_heap[idx][1] | |
64 | if (sym !~ /^'/) { | |
65 | types_release(ast) | |
66 | env_release(env) | |
67 | return "!\"Incompatible type for argument 1 of 'def!'. Expects symbol, supplied " types_typename(sym) "." | |
68 | } | |
69 | ret = EVAL(types_addref(types_heap[idx][2]), env) | |
70 | if (ret !~ /^!/) { | |
71 | env_set(env, sym, ret) | |
72 | types_addref(ret) | |
73 | } | |
74 | types_release(ast) | |
75 | env_release(env) | |
76 | return ret | |
77 | } | |
78 | ||
79 | function EVAL_let(ast, env, idx, params, params_idx, params_len, new_env, i, sym, ret, body, len) | |
80 | { | |
81 | idx = substr(ast, 2) | |
82 | if (types_heap[idx]["len"] != 3) { | |
83 | len = types_heap[idx]["len"] | |
84 | types_release(ast) | |
85 | env_release(env) | |
86 | return "!\"Invalid argument length for 'let*'. Expects exactly 2 arguments, supplied " (len - 1) "." | |
87 | } | |
88 | params = types_heap[idx][1] | |
89 | if (params !~ /^[([]/) { | |
90 | types_release(ast) | |
91 | env_release(env) | |
92 | return "!\"Incompatible type for argument 1 of 'let*'. Expects list or vector, supplied " types_typename(params) "." | |
93 | } | |
94 | params_idx = substr(params, 2) | |
95 | params_len = types_heap[params_idx]["len"] | |
96 | if (params_len % 2 != 0) { | |
97 | types_release(ast) | |
98 | env_release(env) | |
99 | return "!\"Invalid elements count for argument 1 of 'let*'. Expects even number of elements, supplied " params_len "." | |
100 | } | |
101 | new_env = env_new(env) | |
102 | env_release(env) | |
103 | for (i = 0; i < params_len; i += 2) { | |
104 | sym = types_heap[params_idx][i] | |
105 | if (sym !~ /^'/) { | |
106 | types_release(ast) | |
107 | env_release(new_env) | |
108 | return "!\"Incompatible type for odd element of argument 1 of 'let*'. Expects symbol, supplied " types_typename(sym) "." | |
109 | } | |
110 | ret = EVAL(types_addref(types_heap[params_idx][i + 1]), new_env) | |
111 | if (ret ~ /^!/) { | |
112 | types_release(ast) | |
113 | env_release(new_env) | |
114 | return ret | |
115 | } | |
116 | env_set(new_env, sym, ret) | |
117 | } | |
118 | types_addref(body = types_heap[idx][2]) | |
119 | types_release(ast) | |
120 | ret = EVAL(body, new_env) | |
121 | env_release(new_env) | |
122 | return ret | |
123 | } | |
124 | ||
125 | function EVAL(ast, env, new_ast, ret, idx, f, f_idx) | |
126 | { | |
127 | env_addref(env) | |
128 | if (ast !~ /^\(/) { | |
129 | ret = eval_ast(ast, env) | |
130 | types_release(ast) | |
131 | env_release(env) | |
132 | return ret | |
133 | } | |
134 | idx = substr(ast, 2) | |
135 | if (types_heap[idx]["len"] == 0) { | |
136 | env_release(env) | |
137 | return ast | |
138 | } | |
139 | switch (types_heap[idx][0]) { | |
140 | case "'def!": | |
141 | return EVAL_def(ast, env) | |
142 | case "'let*": | |
143 | return EVAL_let(ast, env) | |
144 | default: | |
145 | new_ast = eval_ast(ast, env) | |
146 | types_release(ast) | |
147 | env_release(env) | |
148 | if (new_ast ~ /^!/) { | |
149 | return new_ast | |
150 | } | |
151 | idx = substr(new_ast, 2) | |
152 | f = types_heap[idx][0] | |
153 | if (f ~ /^&/) { | |
154 | f_idx = substr(f, 2) | |
155 | ret = @f_idx(idx) | |
156 | types_release(new_ast) | |
157 | return ret | |
158 | } else { | |
159 | types_release(new_ast) | |
160 | return "!\"First element of list must be function, supplied " types_typename(f) "." | |
161 | } | |
162 | } | |
163 | } | |
164 | ||
165 | function PRINT(expr, str) | |
166 | { | |
167 | str = printer_pr_str(expr, 1) | |
168 | types_release(expr) | |
169 | return str | |
170 | } | |
171 | ||
172 | function rep(str, ast, expr) | |
173 | { | |
174 | ast = READ(str) | |
175 | if (ast ~ /^!/) { | |
176 | return ast | |
177 | } | |
178 | expr = EVAL(ast, repl_env) | |
179 | if (expr ~ /^!/) { | |
180 | return expr | |
181 | } | |
182 | return PRINT(expr) | |
183 | } | |
184 | ||
185 | function add(idx, lhs, rhs) | |
186 | { | |
187 | if (types_heap[idx]["len"] != 3) { | |
188 | return "!\"Invalid argument length for builtin function '+'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "." | |
189 | } | |
190 | lhs = types_heap[idx][1] | |
191 | if (lhs !~ /^\+/) { | |
192 | return "!\"Incompatible type for argument 1 of builtin function '+'. Expects number, supplied " types_typename(lhs) "." | |
193 | } | |
194 | rhs = types_heap[idx][2] | |
195 | if (rhs !~ /^\+/) { | |
196 | return "!\"Incompatible type for argument 2 of builtin function '+'. Expects number, supplied " types_typename(rhs) "." | |
197 | } | |
198 | return "+" (substr(lhs, 2) + substr(rhs, 2)) | |
199 | } | |
200 | ||
201 | function subtract(idx, lhs, rhs) | |
202 | { | |
203 | if (types_heap[idx]["len"] != 3) { | |
204 | return "!\"Invalid argument length for builtin function '-'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "." | |
205 | } | |
206 | lhs = types_heap[idx][1] | |
207 | if (lhs !~ /^\+/) { | |
208 | return "!\"Incompatible type for argument 1 of builtin function '-'. Expects number, supplied " types_typename(lhs) "." | |
209 | } | |
210 | rhs = types_heap[idx][2] | |
211 | if (rhs !~ /^\+/) { | |
212 | return "!\"Incompatible type for argument 2 of builtin function '-'. Expects number, supplied " types_typename(rhs) "." | |
213 | } | |
214 | return "+" (substr(lhs, 2) - substr(rhs, 2)) | |
215 | } | |
216 | ||
217 | function multiply(idx, lhs, rhs) | |
218 | { | |
219 | if (types_heap[idx]["len"] != 3) { | |
220 | return "!\"Invalid argument length for builtin function '*'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "." | |
221 | } | |
222 | lhs = types_heap[idx][1] | |
223 | if (lhs !~ /^\+/) { | |
224 | return "!\"Incompatible type for argument 1 of builtin function '*'. Expects number, supplied " types_typename(lhs) "." | |
225 | } | |
226 | rhs = types_heap[idx][2] | |
227 | if (rhs !~ /^\+/) { | |
228 | return "!\"Incompatible type for argument 2 of builtin function '*'. Expects number, supplied " types_typename(rhs) "." | |
229 | } | |
230 | return "+" (substr(lhs, 2) * substr(rhs, 2)) | |
231 | } | |
232 | ||
233 | function divide(idx, lhs, rhs) | |
234 | { | |
235 | if (types_heap[idx]["len"] != 3) { | |
236 | return "!\"Invalid argument length for builtin function '/'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "." | |
237 | } | |
238 | lhs = types_heap[idx][1] | |
239 | if (lhs !~ /^\+/) { | |
240 | return "!\"Incompatible type for argument 1 of builtin function '/'. Expects number, supplied " types_typename(lhs) "." | |
241 | } | |
242 | rhs = types_heap[idx][2] | |
243 | if (rhs !~ /^\+/) { | |
244 | return "!\"Incompatible type for argument 2 of builtin function '/'. Expects number, supplied " types_typename(rhs) "." | |
245 | } | |
246 | return "+" int(substr(lhs, 2) / substr(rhs, 2)) | |
247 | } | |
248 | ||
249 | function main(str, ret) | |
250 | { | |
251 | repl_env = env_new() | |
252 | env_set(repl_env, "'+", "&add") | |
253 | env_set(repl_env, "'-", "&subtract") | |
254 | env_set(repl_env, "'*", "&multiply") | |
255 | env_set(repl_env, "'/", "÷") | |
256 | ||
257 | while (1) { | |
258 | printf("user> ") | |
259 | if (getline str <= 0) { | |
260 | break | |
261 | } | |
262 | ret = rep(str) | |
263 | if (ret ~ /^!/) { | |
264 | print "ERROR: " printer_pr_str(substr(ret, 2)) | |
265 | } else { | |
266 | print ret | |
267 | } | |
268 | } | |
269 | } | |
270 | ||
271 | BEGIN { | |
272 | main() | |
273 | env_check(0) | |
274 | env_dump() | |
275 | types_dump() | |
276 | exit(0) | |
277 | } |