Commit | Line | Data |
---|---|---|
8c7587af MK |
1 | @include "types.awk" |
2 | @include "reader.awk" | |
3 | @include "printer.awk" | |
4 | @include "env.awk" | |
5 | @include "core.awk" | |
6 | ||
7 | function READ(str) | |
8 | { | |
9 | return reader_read_str(str) | |
10 | } | |
11 | ||
12 | function is_pair(ast) | |
13 | { | |
14 | return ast ~ /^[([]/ && types_heap[substr(ast, 2)]["len"] != 0 | |
15 | } | |
16 | ||
17 | function quasiquote(ast, i, len, new_idx, idx, lst_idx, first, first_idx, verb, ret) | |
18 | { | |
19 | if (!is_pair(ast)) { | |
20 | new_idx = types_allocate() | |
21 | types_heap[new_idx][0] = "'quote" | |
22 | types_heap[new_idx][1] = ast | |
23 | types_heap[new_idx]["len"] = 2 | |
24 | return "(" new_idx | |
25 | } | |
26 | idx = substr(ast, 2) | |
27 | first = types_heap[idx][0] | |
28 | if (first == "'unquote") { | |
29 | if (types_heap[idx]["len"] != 2) { | |
30 | len = types_heap[idx]["len"] | |
31 | types_release(ast) | |
32 | return "!\"Invalid argument length for 'unquote'. Expects exactly 1 argument, supplied " (len - 1) "." | |
33 | } | |
34 | types_addref(ret = types_heap[idx][1]) | |
35 | types_release(ast) | |
36 | return ret | |
37 | } | |
38 | ||
39 | first_idx = substr(first, 2) | |
40 | if (is_pair(first) && types_heap[first_idx][0] == "'splice-unquote") { | |
41 | if (types_heap[first_idx]["len"] != 2) { | |
42 | len = types_heap[first_idx]["len"] | |
43 | types_release(ast) | |
44 | return "!\"Invalid argument length for 'splice-unquote'. Expects exactly 1 argument, supplied " (len - 1) "." | |
45 | } | |
46 | types_addref(first = types_heap[first_idx][1]) | |
47 | verb = "'concat" | |
48 | } else { | |
49 | types_addref(first) | |
50 | first = quasiquote(first) | |
51 | if (first ~ /^!/) { | |
52 | types_release(ast) | |
53 | return first | |
54 | } | |
55 | verb = "'cons" | |
56 | } | |
57 | lst_idx = types_allocate() | |
58 | len = types_heap[idx]["len"] | |
59 | for (i = 1; i < len; ++i) { | |
60 | types_addref(types_heap[lst_idx][i - 1] = types_heap[idx][i]) | |
61 | } | |
62 | types_heap[lst_idx]["len"] = len - 1 | |
63 | types_release(ast) | |
64 | ret = quasiquote("(" lst_idx) | |
65 | if (ret ~ /^!/) { | |
66 | types_release(first) | |
67 | return ret | |
68 | } | |
69 | ||
70 | new_idx = types_allocate() | |
71 | types_heap[new_idx][0] = verb | |
72 | types_heap[new_idx][1] = first | |
73 | types_heap[new_idx][2] = ret | |
74 | types_heap[new_idx]["len"] = 3 | |
75 | return "(" new_idx | |
76 | } | |
77 | ||
78 | function is_macro_call(ast, env, sym, ret, f) | |
79 | { | |
80 | if (!is_pair(ast)) { | |
81 | return 0 | |
82 | } | |
83 | sym = types_heap[substr(ast, 2)][0] | |
84 | if (sym !~ /^'/) { | |
85 | return 0 | |
86 | } | |
87 | f = env_get(env, sym) | |
88 | return f ~ /^\$/ && types_heap[substr(f, 2)]["is_macro"] | |
89 | } | |
90 | ||
91 | function macroexpand(ast, env, idx, f_idx, new_env) | |
92 | { | |
93 | while (is_macro_call(ast, env)) { | |
94 | idx = substr(ast, 2) | |
95 | f_idx = substr(env_get(env, types_heap[idx][0]), 2) | |
96 | new_env = env_new(types_heap[f_idx]["env"], types_heap[f_idx]["params"], idx) | |
97 | types_release(ast) | |
98 | if (new_env ~ /^!/) { | |
99 | return new_env | |
100 | } | |
101 | types_addref(ast = types_heap[f_idx]["body"]) | |
102 | ast = EVAL(ast, new_env) | |
103 | env_release(new_env) | |
104 | if (ast ~ /^!/) { | |
105 | return ast | |
106 | } | |
107 | } | |
108 | return ast | |
109 | } | |
110 | ||
111 | function eval_ast(ast, env, i, idx, len, new_idx, ret) | |
112 | { | |
113 | switch (ast) { | |
114 | case /^'/: | |
115 | ret = env_get(env, ast) | |
116 | if (ret !~ /^!/) { | |
117 | types_addref(ret) | |
118 | } | |
119 | return ret | |
120 | case /^[([]/: | |
121 | idx = substr(ast, 2) | |
122 | len = types_heap[idx]["len"] | |
123 | new_idx = types_allocate() | |
124 | for (i = 0; i < len; ++i) { | |
125 | ret = EVAL(types_addref(types_heap[idx][i]), env) | |
126 | if (ret ~ /^!/) { | |
127 | types_heap[new_idx]["len"] = i | |
128 | types_release(substr(ast, 1, 1) new_idx) | |
129 | return ret | |
130 | } | |
131 | types_heap[new_idx][i] = ret | |
132 | } | |
133 | types_heap[new_idx]["len"] = len | |
134 | return substr(ast, 1, 1) new_idx | |
135 | case /^\{/: | |
136 | idx = substr(ast, 2) | |
137 | new_idx = types_allocate() | |
138 | for (i in types_heap[idx]) { | |
139 | if (i ~ /^[":]/) { | |
140 | ret = EVAL(types_addref(types_heap[idx][i]), env) | |
141 | if (ret ~ /^!/) { | |
142 | types_release("{" new_idx) | |
143 | return ret | |
144 | } | |
145 | types_heap[new_idx][i] = ret | |
146 | } | |
147 | } | |
148 | return "{" new_idx | |
149 | default: | |
150 | return ast | |
151 | } | |
152 | } | |
153 | ||
154 | function EVAL_def(ast, env, idx, sym, ret, len) | |
155 | { | |
156 | idx = substr(ast, 2) | |
157 | if (types_heap[idx]["len"] != 3) { | |
158 | len = types_heap[idx]["len"] | |
159 | types_release(ast) | |
160 | env_release(env) | |
161 | return "!\"Invalid argument length for 'def!'. Expects exactly 2 arguments, supplied" (len - 1) "." | |
162 | } | |
163 | sym = types_heap[idx][1] | |
164 | if (sym !~ /^'/) { | |
165 | types_release(ast) | |
166 | env_release(env) | |
167 | return "!\"Incompatible type for argument 1 of 'def!'. Expects symbol, supplied " types_typename(sym) "." | |
168 | } | |
169 | ret = EVAL(types_addref(types_heap[idx][2]), env) | |
170 | if (ret !~ /^!/) { | |
171 | env_set(env, sym, ret) | |
172 | types_addref(ret) | |
173 | } | |
174 | types_release(ast) | |
175 | env_release(env) | |
176 | return ret | |
177 | } | |
178 | ||
179 | function EVAL_let(ast, env, ret_env, idx, params, params_idx, params_len, new_env, i, sym, ret, body, len) | |
180 | { | |
181 | idx = substr(ast, 2) | |
182 | if (types_heap[idx]["len"] != 3) { | |
183 | len = types_heap[idx]["len"] | |
184 | types_release(ast) | |
185 | env_release(env) | |
186 | return "!\"Invalid argument length for 'let*'. Expects exactly 2 arguments, supplied " (len - 1) "." | |
187 | } | |
188 | params = types_heap[idx][1] | |
189 | if (params !~ /^[([]/) { | |
190 | types_release(ast) | |
191 | env_release(env) | |
192 | return "!\"Incompatible type for argument 1 of 'let*'. Expects list or vector, supplied " types_typename(params) "." | |
193 | } | |
194 | params_idx = substr(params, 2) | |
195 | params_len = types_heap[params_idx]["len"] | |
196 | if (params_len % 2 != 0) { | |
197 | types_release(ast) | |
198 | env_release(env) | |
199 | return "!\"Invalid elements count for argument 1 of 'let*'. Expects even number of elements, supplied " params_len "." | |
200 | } | |
201 | new_env = env_new(env) | |
202 | env_release(env) | |
203 | for (i = 0; i < params_len; i += 2) { | |
204 | sym = types_heap[params_idx][i] | |
205 | if (sym !~ /^'/) { | |
206 | types_release(ast) | |
207 | env_release(new_env) | |
208 | return "!\"Incompatible type for odd element of argument 1 of 'let*'. Expects symbol, supplied " types_typename(sym) "." | |
209 | } | |
210 | ret = EVAL(types_addref(types_heap[params_idx][i + 1]), new_env) | |
211 | if (ret ~ /^!/) { | |
212 | types_release(ast) | |
213 | env_release(new_env) | |
214 | return ret | |
215 | } | |
216 | env_set(new_env, sym, ret) | |
217 | } | |
218 | types_addref(body = types_heap[idx][2]) | |
219 | types_release(ast) | |
220 | ret_env[0] = new_env | |
221 | return body | |
222 | } | |
223 | ||
224 | function EVAL_defmacro(ast, env, idx, sym, ret, len) | |
225 | { | |
226 | idx = substr(ast, 2) | |
227 | if (types_heap[idx]["len"] != 3) { | |
228 | len = types_heap[idx]["len"] | |
229 | types_release(ast) | |
230 | env_release(env) | |
231 | return "!\"Invalid argument length for 'defmacro!'. Expects exactly 2 arguments, supplied" (len - 1) "." | |
232 | } | |
233 | sym = types_heap[idx][1] | |
234 | if (sym !~ /^'/) { | |
235 | types_release(ast) | |
236 | env_release(env) | |
237 | return "!\"Incompatible type for argument 1 of 'defmacro!'. Expects symbol, supplied " types_typename(sym) "." | |
238 | } | |
239 | ret = EVAL(types_addref(types_heap[idx][2]), env) | |
240 | types_release(ast) | |
241 | if (ret ~ /^!/) { | |
242 | env_release(env) | |
243 | return ret | |
244 | } | |
245 | if (ret !~ /^\$/) { | |
246 | types_release(ret) | |
247 | env_release(env) | |
248 | return "!\"Incompatible type for argument 2 of 'defmacro!'. Expects function, supplied " types_typename(ret) "." | |
249 | } | |
250 | types_heap[substr(ret, 2)]["is_macro"] = 1 | |
251 | env_set(env, sym, ret) | |
252 | types_addref(ret) | |
253 | env_release(env) | |
254 | return ret | |
255 | } | |
256 | ||
257 | function EVAL_do(ast, env, idx, len, i, body, ret) | |
258 | { | |
259 | idx = substr(ast, 2) | |
260 | len = types_heap[idx]["len"] | |
261 | if (len == 1) { | |
262 | types_release(ast) | |
263 | env_release(env) | |
264 | return "!\"Invalid argument length for 'do'. Expects at least 1 argument, supplied" (len - 1) "." | |
265 | } | |
266 | for (i = 1; i < len - 1; ++i) { | |
267 | ret = EVAL(types_addref(types_heap[idx][i]), env) | |
268 | if (ret ~ /^!/) { | |
269 | types_release(ast) | |
270 | env_release(env) | |
271 | return ret | |
272 | } | |
273 | types_release(ret) | |
274 | } | |
275 | types_addref(body = types_heap[idx][len - 1]) | |
276 | types_release(ast) | |
277 | return body | |
278 | } | |
279 | ||
280 | function EVAL_if(ast, env, idx, len, ret, body) | |
281 | { | |
282 | idx = substr(ast, 2) | |
283 | len = types_heap[idx]["len"] | |
284 | if (len != 3 && len != 4) { | |
285 | types_release(ast) | |
286 | return "!\"Invalid argument length for 'if'. Expects 2 or 3 arguments, supplied " (len - 1) "." | |
287 | } | |
288 | ret = EVAL(types_addref(types_heap[idx][1]), env) | |
289 | if (ret ~ /^!/) { | |
290 | types_release(ast) | |
291 | return ret | |
292 | } | |
293 | types_release(ret) | |
294 | switch (ret) { | |
295 | case "#nil": | |
296 | case "#false": | |
297 | if (len == 3) { | |
298 | body = "#nil" | |
299 | } else { | |
300 | types_addref(body = types_heap[idx][3]) | |
301 | } | |
302 | break | |
303 | default: | |
304 | types_addref(body = types_heap[idx][2]) | |
305 | break | |
306 | } | |
307 | types_release(ast) | |
308 | return body | |
309 | } | |
310 | ||
311 | function EVAL_fn(ast, env, idx, params, params_idx, params_len, i, sym, f_idx, len) | |
312 | { | |
313 | idx = substr(ast, 2) | |
314 | if (types_heap[idx]["len"] != 3) { | |
315 | len = types_heap[idx]["len"] | |
316 | types_release(ast) | |
317 | env_release(env) | |
318 | return "!\"Invalid argument length for 'fn*'. Expects exactly 2 arguments, supplied " (len - 1) "." | |
319 | } | |
320 | params = types_heap[idx][1] | |
321 | if (params !~ /^[([]/) { | |
322 | types_release(ast) | |
323 | env_release(env) | |
324 | return "!\"Incompatible type for argument 1 of 'fn*'. Expects list or vector, supplied " types_typename(params) "." | |
325 | } | |
326 | params_idx = substr(params, 2) | |
327 | params_len = types_heap[params_idx]["len"] | |
328 | for (i = 0; i < params_len; ++i) { | |
329 | sym = types_heap[params_idx][i] | |
330 | if (sym !~ /^'/) { | |
331 | types_release(ast) | |
332 | env_release(env) | |
333 | return "!\"Incompatible type for element of argument 1 of 'fn*'. Expects symbol, supplied " types_typename(sym) "." | |
334 | } | |
335 | if (sym == "'&" && i + 2 != params_len) { | |
336 | types_release(ast) | |
337 | env_release(env) | |
338 | return "!\"Symbol '&' should be followed by last parameter. Parameter list length is " params_len ", position of symbol '&' is " (i + 1) "." | |
339 | } | |
340 | } | |
341 | f_idx = types_allocate() | |
342 | types_addref(types_heap[f_idx]["params"] = types_heap[idx][1]) | |
343 | types_addref(types_heap[f_idx]["body"] = types_heap[idx][2]) | |
344 | types_heap[f_idx]["env"] = env | |
345 | types_release(ast) | |
346 | return "$" f_idx | |
347 | } | |
348 | ||
349 | function EVAL(ast, env, body, new_ast, ret, idx, len, f, f_idx, ret_env) | |
350 | { | |
351 | env_addref(env) | |
352 | for (;;) { | |
353 | if (ast !~ /^\(/) { | |
354 | ret = eval_ast(ast, env) | |
355 | types_release(ast) | |
356 | env_release(env) | |
357 | return ret | |
358 | } | |
359 | if (types_heap[substr(ast, 2)]["len"] == 0) { | |
360 | env_release(env) | |
361 | return ast | |
362 | } | |
363 | ast = macroexpand(ast, env) | |
364 | if (ast ~ /^!/) { | |
365 | env_release(env) | |
366 | return ast | |
367 | } | |
368 | if (ast !~ /^\(/) { | |
369 | ret = eval_ast(ast, env) | |
370 | types_release(ast) | |
371 | env_release(env) | |
372 | return ret | |
373 | } | |
374 | idx = substr(ast, 2) | |
375 | len = types_heap[idx]["len"] | |
376 | switch (types_heap[idx][0]) { | |
377 | case "'def!": | |
378 | return EVAL_def(ast, env) | |
379 | case "'let*": | |
380 | ast = EVAL_let(ast, env, ret_env) | |
381 | if (ast ~ /^!/) { | |
382 | return ast | |
383 | } | |
384 | env = ret_env[0] | |
385 | continue | |
386 | case "'quote": | |
387 | if (len != 2) { | |
388 | types_release(ast) | |
389 | env_release(env) | |
390 | return "!\"Invalid argument length for 'quote'. Expects exactly 1 argument, supplied " (len - 1) "." | |
391 | } | |
392 | types_addref(body = types_heap[idx][1]) | |
393 | types_release(ast) | |
394 | env_release(env) | |
395 | return body | |
396 | case "'quasiquote": | |
397 | if (len != 2) { | |
398 | types_release(ast) | |
399 | env_release(env) | |
400 | return "!\"Invalid argument length for 'quasiquote'. Expects exactly 1 argument, supplied " (len - 1) "." | |
401 | } | |
402 | types_addref(body = types_heap[idx][1]) | |
403 | types_release(ast) | |
404 | ast = quasiquote(body) | |
405 | if (ast ~ /^!/) { | |
406 | env_release(env) | |
407 | return ast | |
408 | } | |
409 | continue | |
410 | case "'defmacro!": | |
411 | return EVAL_defmacro(ast, env) | |
412 | case "'macroexpand": | |
413 | if (len != 2) { | |
414 | types_release(ast) | |
415 | env_release(env) | |
416 | return "!\"Invalid argument length for 'macroexpand'. Expects exactly 1 argument, supplied " (len - 1) "." | |
417 | } | |
418 | types_addref(body = types_heap[idx][1]) | |
419 | types_release(ast) | |
420 | ret = macroexpand(body, env) | |
421 | env_release(env) | |
422 | return ret | |
423 | case "'do": | |
424 | ast = EVAL_do(ast, env) | |
425 | if (ast ~ /^!/) { | |
426 | return ast | |
427 | } | |
428 | continue | |
429 | case "'if": | |
430 | ast = EVAL_if(ast, env) | |
431 | if (ast !~ /^['([{]/) { | |
432 | env_release(env) | |
433 | return ast | |
434 | } | |
435 | continue | |
436 | case "'fn*": | |
437 | return EVAL_fn(ast, env) | |
438 | default: | |
439 | new_ast = eval_ast(ast, env) | |
440 | types_release(ast) | |
441 | env_release(env) | |
442 | if (new_ast ~ /^!/) { | |
443 | return new_ast | |
444 | } | |
445 | idx = substr(new_ast, 2) | |
446 | f = types_heap[idx][0] | |
447 | f_idx = substr(f, 2) | |
448 | switch (f) { | |
449 | case /^\$/: | |
450 | env = env_new(types_heap[f_idx]["env"], types_heap[f_idx]["params"], idx) | |
451 | if (env ~ /^!/) { | |
452 | types_release(new_ast) | |
453 | return env | |
454 | } | |
455 | types_addref(ast = types_heap[f_idx]["body"]) | |
456 | types_release(new_ast) | |
457 | continue | |
458 | case /^&/: | |
459 | ret = @f_idx(idx) | |
460 | types_release(new_ast) | |
461 | return ret | |
462 | default: | |
463 | types_release(new_ast) | |
464 | return "!\"First element of list must be function, supplied " types_typename(f) "." | |
465 | } | |
466 | } | |
467 | } | |
468 | } | |
469 | ||
470 | function PRINT(expr, str) | |
471 | { | |
472 | str = printer_pr_str(expr, 1) | |
473 | types_release(expr) | |
474 | return str | |
475 | } | |
476 | ||
477 | function rep(str, ast, expr) | |
478 | { | |
479 | ast = READ(str) | |
480 | if (ast ~ /^!/) { | |
481 | return ast | |
482 | } | |
483 | expr = EVAL(ast, repl_env) | |
484 | if (expr ~ /^!/) { | |
485 | return expr | |
486 | } | |
487 | return PRINT(expr) | |
488 | } | |
489 | ||
490 | function eval(idx) | |
491 | { | |
492 | if (types_heap[idx]["len"] != 2) { | |
493 | return "!\"Invalid argument length for builtin function 'eval'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "." | |
494 | } | |
495 | return EVAL(types_addref(types_heap[idx][1]), repl_env) | |
496 | } | |
497 | ||
498 | function main(str, ret, i, idx) | |
499 | { | |
500 | repl_env = env_new() | |
501 | for (i in core_ns) { | |
502 | env_set(repl_env, i, core_ns[i]) | |
503 | } | |
504 | ||
505 | env_set(repl_env, "'eval", "&eval") | |
506 | ||
507 | rep("(def! not (fn* (a) (if a false true)))") | |
e6d41de4 | 508 | rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))") |
8c7587af | 509 | rep("(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))") |
8c7587af MK |
510 | |
511 | idx = types_allocate() | |
512 | env_set(repl_env, "'*ARGV*", "(" idx) | |
513 | if (ARGC > 1) { | |
514 | for (i = 2; i < ARGC; ++i) { | |
515 | types_heap[idx][i - 2] = "\"" ARGV[i] | |
516 | } | |
517 | types_heap[idx]["len"] = ARGC - 2 | |
518 | ARGC = 1 | |
519 | rep("(load-file \"" ARGV[1] "\")") | |
520 | return | |
521 | } | |
522 | types_heap[idx]["len"] = 0 | |
523 | ||
524 | while (1) { | |
525 | printf("user> ") | |
526 | if (getline str <= 0) { | |
527 | break | |
528 | } | |
529 | ret = rep(str) | |
530 | if (ret ~ /^!/) { | |
531 | print "ERROR: " printer_pr_str(substr(ret, 2)) | |
532 | } else { | |
533 | print ret | |
534 | } | |
535 | } | |
536 | } | |
537 | ||
538 | BEGIN { | |
539 | main() | |
540 | env_check(0) | |
541 | env_dump() | |
542 | types_dump() | |
543 | exit(0) | |
544 | } |