HCoop / jackhill / mal.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Change quasiquote algorithm
[jackhill/mal.git] / impls / awk / core.awk
CommitLineData
8c7587af
MK		 1@load "readfile"
2@load "time"
3
4function core_eq_sub(lhs, rhs, i, len)
5{
6 if (lhs ~ /^[([]/ && rhs ~ /^[([]/) {
7 lhs = substr(lhs, 2)
8 rhs = substr(rhs, 2)
9 len = types_heap[lhs]["len"]
10 if (len != types_heap[rhs]["len"]) {
11 return 0
12 }
13 for (i = 0; i < len; ++i) {
14 if (!core_eq_sub(types_heap[lhs][i], types_heap[rhs][i])) {
15 return 0
16 }
17 }
18 return 1
19 } else if (lhs ~ /^\{/ && rhs ~ /^\{/) {
20 lhs = substr(lhs, 2)
21 rhs = substr(rhs, 2)
22 if (length(types_heap[lhs]) != length(types_heap[rhs])) {
23 return 0
24 }
25 for (i in types_heap[lhs]) {
26 if (types_heap[lhs][i] ~ /^["':+#([{?&$%]/ &&
27 !core_eq_sub(types_heap[lhs][i], types_heap[rhs][i])) {
28 return 0
29 }
30 }
31 return 1
32 } else {
33 return lhs == rhs
34 }
35}
36
37function core_eq(idx)
38{
39 if (types_heap[idx]["len"] != 3) {
40 return "!\"Invalid argument length for builtin function '='. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "."
41 }
42 return core_eq_sub(types_heap[idx][1], types_heap[idx][2]) ? "#true" : "#false"
43}
44
45function core_throw(idx)
46{
47 if (types_heap[idx]["len"] != 2) {
48 return "!\"Invalid argument length for builtin function 'throw'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "."
49 }
50 return "!" types_addref(types_heap[idx][1])
51}
52
53
54
55function core_nilp(idx)
56{
57 if (types_heap[idx]["len"] != 2) {
58 return "!\"Invalid argument length for builtin function 'nil?'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "."
59 }
60 return types_heap[idx][1] == "#nil" ? "#true" : "#false"
61}
62
63function core_truep(idx)
64{
65 if (types_heap[idx]["len"] != 2) {
66 return "!\"Invalid argument length for builtin function 'true?'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "."
67 }
68 return types_heap[idx][1] == "#true" ? "#true" : "#false"
69}
70
71function core_falsep(idx)
72{
73 if (types_heap[idx]["len"] != 2) {
74 return "!\"Invalid argument length for builtin function 'false?'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "."
75 }
76 return types_heap[idx][1] == "#false" ? "#true" : "#false"
77}
78
48f757da
JM		 79function core_stringp(idx)
80{
81 if (types_heap[idx]["len"] != 2) {
82 return "!\"Invalid argument length for builtin function 'string?'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "."
83 }
84 return types_heap[idx][1] ~ /^"/ ? "#true" : "#false"
85}
86
8c7587af
MK		 87function core_symbol(idx, str)
88{
89 if (types_heap[idx]["len"] != 2) {
90 return "!\"Invalid argument length for builtin function 'symbol'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "."
91 }
92 str = types_heap[idx][1]
93 if (str !~ /^"/) {
94 return "!\"Incompatible type for argument 1 of builtin function 'symbol'. Expects string, supplied " types_typename(str) "."
95 }
96 return "'" substr(str, 2)
97}
98
99function core_symbolp(idx)
100{
101 if (types_heap[idx]["len"] != 2) {
102 return "!\"Invalid argument length for builtin function 'symbol?'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "."
103 }
104 return types_heap[idx][1] ~ /^'/ ? "#true" : "#false"
105}
106
107function core_keyword(idx, str)
108{
109 if (types_heap[idx]["len"] != 2) {
110 return "!\"Invalid argument length for builtin function 'keyword'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "."
111 }
112 str = types_heap[idx][1]
113 switch (str) {
114 case /^:/:
115 return str
116 case /^"/:
117 return "::" substr(str, 2)
118 }
119 return "!\"Incompatible type for argument 1 of builtin function 'keyword'. Expects string or keyword, supplied " types_typename(str) "."
120}
121
122function core_keywordp(idx)
123{
124 if (types_heap[idx]["len"] != 2) {
125 return "!\"Invalid argument length for builtin function 'keyword?'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "."
126 }
127 return types_heap[idx][1] ~ /^:/ ? "#true" : "#false"
128}
129
d90be1a9
DM		 130function core_numberp(idx)
131{
132 if (types_heap[idx]["len"] != 2) {
133 return "!\"Invalid argument length for builtin function 'number?'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "."
134 }
135 return types_heap[idx][1] ~ /^\+/ ? "#true" : "#false"
136}
137
138function core_fnp(idx)
139{
140 if (types_heap[idx]["len"] != 2) {
141 return "!\"Invalid argument length for builtin function 'fn?'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "."
142 }
143 f = types_heap[idx][1]
144 return f ~ /^[$&%]/ && !types_heap[substr(f, 2)]["is_macro"] ? "#true" : "#false"
145}
146
147function core_macrop(idx)
148{
149 if (types_heap[idx]["len"] != 2) {
150 return "!\"Invalid argument length for builtin function 'macro?'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "."
151 }
152 f = types_heap[idx][1]
153 return f ~ /^\$/ && types_heap[substr(f, 2)]["is_macro"] ? "#true" : "#false"
154}
155
8c7587af
MK		 156
157
158function core_pr_str(idx, i, len, result)
159{
160 len = types_heap[idx]["len"]
161 for (i = 1; i < len; ++i) {
162 result = result printer_pr_str(types_heap[idx][i], 1) " "
163 }
164 return "\"" substr(result, 1, length(result) - 1)
165}
166
167function core_str(idx, i, len, result)
168{
169 len = types_heap[idx]["len"]
170 for (i = 1; i < len; ++i) {
171 result = result printer_pr_str(types_heap[idx][i], 0)
172 }
173 return "\"" result
174}
175
176function core_prn(idx, i, len, result)
177{
178 len = types_heap[idx]["len"]
179 for (i = 1; i < len; ++i) {
180 result = result printer_pr_str(types_heap[idx][i], 1) " "
181 }
182 print substr(result, 1, length(result) - 1)
183 return "#nil"
184}
185
186function core_println(idx, i, len, result)
187{
188 len = types_heap[idx]["len"]
189 for (i = 1; i < len; ++i) {
190 result = result printer_pr_str(types_heap[idx][i], 0) " "
191 }
192 print substr(result, 1, length(result) - 1)
193 return "#nil"
194}
195
196function core_read_string(idx, str)
197{
198 if (types_heap[idx]["len"] != 2) {
199 return "!\"Invalid argument length for builtin function 'read-string'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "."
200 }
201 str = types_heap[idx][1]
202 if (str !~ /^"/) {
203 return "!\"Incompatible type for argument 1 of builtin function 'read-string'. Expects string, supplied " types_typename(str) "."
204 }
205 return reader_read_str(substr(str, 2))
206}
207
208function core_readline(idx, prompt, var)
209{
210 if (types_heap[idx]["len"] != 2) {
211 return "!\"Invalid argument length for builtin function 'readline'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "."
212 }
213 prompt = types_heap[idx][1]
214 if (prompt !~ /^"/) {
215 return "!\"Incompatible type for argument 1 of builtin function 'readline'. Expects string, supplied " types_typename(prompt) "."
216 }
217 printf("%s", printer_pr_str(prompt, 0))
218 return getline var <= 0 ? "#nil" : "\"" var
219}
220
221function core_slurp(idx, filename, str)
222{
223 if (types_heap[idx]["len"] != 2) {
224 return "!\"Invalid argument length for builtin function 'slurp'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "."
225 }
226 filename = types_heap[idx][1]
227 if (filename !~ /^"/) {
228 return "!\"Incompatible type for argument 1 of builtin function 'slurp'. Expects string, supplied " types_typename(filename) "."
229 }
230 str = readfile(substr(filename, 2))
231 if (str == "" && ERRNO != "") {
232 return "!\"cannot read file '" filename "', ERRNO = " ERRNO
233 }
234 return "\"" str
235}
236
237
238
239function core_lt(idx, lhs, rhs)
240{
241 if (types_heap[idx]["len"] != 3) {
242 return "!\"Invalid argument length for builtin function '<'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "."
243 }
244 lhs = types_heap[idx][1]
245 if (lhs !~ /^\+/) {
246 return "!\"Incompatible type for argument 1 of builtin function '<'. Expects number, supplied " types_typename(lhs) "."
247 }
248 rhs = types_heap[idx][2]
249 if (rhs !~ /^\+/) {
250 return "!\"Incompatible type for argument 2 of builtin function '<'. Expects number, supplied " types_typename(rhs) "."
251 }
252 return substr(lhs, 2) + 0 < substr(rhs, 2) + 0 ? "#true" : "#false"
253}
254
255function core_le(idx, lhs, rhs)
256{
257 if (types_heap[idx]["len"] != 3) {
258 return "!\"Invalid argument length for builtin function '<='. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "."
259 }
260 lhs = types_heap[idx][1]
261 if (lhs !~ /^\+/) {
262 return "!\"Incompatible type for argument 1 of builtin function '<='. Expects number, supplied " types_typename(lhs) "."
263 }
264 rhs = types_heap[idx][2]
265 if (rhs !~ /^\+/) {
266 return "!\"Incompatible type for argument 2 of builtin function '<='. Expects number, supplied " types_typename(rhs) "."
267 }
268 return substr(lhs, 2) + 0 <= substr(rhs, 2) + 0 ? "#true" : "#false"
269}
270
271function core_gt(idx, lhs, rhs)
272{
273 if (types_heap[idx]["len"] != 3) {
274 return "!\"Invalid argument length for builtin function '>'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "."
275 }
276 lhs = types_heap[idx][1]
277 if (lhs !~ /^\+/) {
278 return "!\"Incompatible type for argument 1 of builtin function '>'. Expects number, supplied " types_typename(lhs) "."
279 }
280 rhs = types_heap[idx][2]
281 if (rhs !~ /^\+/) {
282 return "!\"Incompatible type for argument 2 of builtin function '>'. Expects number, supplied " types_typename(rhs) "."
283 }
284 return substr(lhs, 2) + 0 > substr(rhs, 2) + 0 ? "#true" : "#false"
285}
286
287function core_ge(idx, lhs, rhs)
288{
289 if (types_heap[idx]["len"] != 3) {
290 return "!\"Invalid argument length for builtin function '>='. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "."
291 }
292 lhs = types_heap[idx][1]
293 if (lhs !~ /^\+/) {
294 return "!\"Incompatible type for argument 1 of builtin function '>='. Expects number, supplied " types_typename(lhs) "."
295 }
296 rhs = types_heap[idx][2]
297 if (rhs !~ /^\+/) {
298 return "!\"Incompatible type for argument 2 of builtin function '>='. Expects number, supplied " types_typename(rhs) "."
299 }
300 return substr(lhs, 2) + 0 >= substr(rhs, 2) + 0 ? "#true" : "#false"
301}
302
303function core_add(idx, lhs, rhs)
304{
305 if (types_heap[idx]["len"] != 3) {
306 return "!\"Invalid argument length for builtin function '+'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "."
307 }
308 lhs = types_heap[idx][1]
309 if (lhs !~ /^\+/) {
310 return "!\"Incompatible type for argument 1 of builtin function '+'. Expects number, supplied " types_typename(lhs) "."
311 }
312 rhs = types_heap[idx][2]
313 if (rhs !~ /^\+/) {
314 return "!\"Incompatible type for argument 2 of builtin function '+'. Expects number, supplied " types_typename(rhs) "."
315 }
316 return "+" (substr(lhs, 2) + substr(rhs, 2))
317}
318
319function core_subtract(idx, lhs, rhs)
320{
321 if (types_heap[idx]["len"] != 3) {
322 return "!\"Invalid argument length for builtin function '-'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "."
323 }
324 lhs = types_heap[idx][1]
325 if (lhs !~ /^\+/) {
326 return "!\"Incompatible type for argument 1 of builtin function '-'. Expects number, supplied " types_typename(lhs) "."
327 }
328 rhs = types_heap[idx][2]
329 if (rhs !~ /^\+/) {
330 return "!\"Incompatible type for argument 2 of builtin function '-'. Expects number, supplied " types_typename(rhs) "."
331 }
332 return "+" (substr(lhs, 2) - substr(rhs, 2))
333}
334
335function core_multiply(idx, lhs, rhs)
336{
337 if (types_heap[idx]["len"] != 3) {
338 return "!\"Invalid argument length for builtin function '*'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "."
339 }
340 lhs = types_heap[idx][1]
341 if (lhs !~ /^\+/) {
342 return "!\"Incompatible type for argument 1 of builtin function '*'. Expects number, supplied " types_typename(lhs) "."
343 }
344 rhs = types_heap[idx][2]
345 if (rhs !~ /^\+/) {
346 return "!\"Incompatible type for argument 2 of builtin function '*'. Expects number, supplied " types_typename(rhs) "."
347 }
348 return "+" (substr(lhs, 2) * substr(rhs, 2))
349}
350
351function core_divide(idx, lhs, rhs)
352{
353 if (types_heap[idx]["len"] != 3) {
354 return "!\"Invalid argument length for builtin function '/'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "."
355 }
356 lhs = types_heap[idx][1]
357 if (lhs !~ /^\+/) {
358 return "!\"Incompatible type for argument 1 of builtin function '/'. Expects number, supplied " types_typename(lhs) "."
359 }
360 rhs = types_heap[idx][2]
361 if (rhs !~ /^\+/) {
362 return "!\"Incompatible type for argument 2 of builtin function '/'. Expects number, supplied " types_typename(rhs) "."
363 }
364 return "+" int(substr(lhs, 2) / substr(rhs, 2))
365}
366
367function core_time_ms(idx)
368{
369 if (types_heap[idx]["len"] != 1) {
370 return "!\"Invalid argument length for builtin function 'time-ms'. Expects no arguments, supplied " (types_heap[idx]["len"] - 1) "."
371 }
372 return "+" int(gettimeofday() * 1000)
373}
374
375
376
377function core_list(idx, new_idx, len, i)
378{
379 new_idx = types_allocate()
380 len = types_heap[idx]["len"]
381 for (i = 1; i < len; ++i) {
382 types_addref(types_heap[new_idx][i - 1] = types_heap[idx][i])
383 }
384 types_heap[new_idx]["len"] = len - 1
385 return "(" new_idx
386}
387
388function core_listp(idx)
389{
390 if (types_heap[idx]["len"] != 2) {
391 return "!\"Invalid argument length for builtin function 'list?'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "."
392 }
393 return types_heap[idx][1] ~ /^\(/ ? "#true" : "#false"
394}
395
396function core_vector(idx, new_idx, len, i)
397{
398 new_idx = types_allocate()
399 len = types_heap[idx]["len"]
400 for (i = 1; i < len; ++i) {
401 types_addref(types_heap[new_idx][i - 1] = types_heap[idx][i])
402 }
403 types_heap[new_idx]["len"] = len - 1
404 return "[" new_idx
405}
406
407function core_vectorp(idx)
408{
409 if (types_heap[idx]["len"] != 2) {
410 return "!\"Invalid argument length for builtin function 'vector?'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "."
411 }
412 return types_heap[idx][1] ~ /^\[/ ? "#true" : "#false"
413}
414
415function core_hash_map(idx, len, new_idx, i, key)
416{
417 len = types_heap[idx]["len"]
418 if (len % 2 != 1) {
419 return "!\"Invalid argument length for builtin function 'hash-map'. Expects even number of arguments, supplied " (len - 1) "."
420 }
421 new_idx = types_allocate()
422 for (i = 1; i < len; i += 2) {
423 key = types_heap[idx][i]
424 if (key !~ /^[":]/) {
425 types_release("{" new_idx)
426 return "!\"Incompatible type for key argument of builtin function 'hash-map'. Expects string or keyword, supplied " types_typename(key) "."
427 }
428 if (key in types_heap[new_idx]) {
429 types_release(types_heap[new_idx][key])
430 }
431 types_addref(types_heap[new_idx][key] = types_heap[idx][i + 1])
432 }
433 return "{" new_idx
434}
435
436function core_mapp(idx)
437{
438 if (types_heap[idx]["len"] != 2) {
439 return "!\"Invalid argument length for builtin function 'map?'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "."
440 }
441 return types_heap[idx][1] ~ /^\{/ ? "#true" : "#false"
442}
443
444function core_assoc(idx, len, map, i, key, add_list, new_idx, map_idx)
445{
446 len = types_heap[idx]["len"]
447 if (len % 2 != 0) {
448 return "!\"Invalid argument length for builtin function 'assoc'. Expects odd number of arguments, supplied " (len - 1) "."
449 }
450 map = types_heap[idx][1]
451 if (map !~ /^\{/) {
452 return "!\"Incompatible type for argument 1 of builtin function 'assoc'. Expects hash-map, supplied " types_typename(map) "."
453 }
454 for (i = 2; i < len; i += 2) {
455 key = types_heap[idx][i]
456 if (key !~ /^[":]/) {
457 return "!\"Incompatible type for key argument of builtin function 'assoc'. Expects string or keyword, supplied " types_typename(key) "."
458 }
459 add_list[key] = types_heap[idx][i + 1]
460 }
461 new_idx = types_allocate()
462 map_idx = substr(map, 2)
463 for (key in types_heap[map_idx]) {
464 if (key ~ /^[":]|^meta$/ && !(key in add_list)) {
465 types_addref(types_heap[new_idx][key] = types_heap[map_idx][key])
466 }
467 }
468 for (key in add_list) {
469 types_addref(types_heap[new_idx][key] = add_list[key])
470 }
471 return "{" new_idx
472}
473
474function core_dissoc(idx, len, map, i, key, del_list, new_idx, map_idx)
475{
476 len = types_heap[idx]["len"]
477 if (len < 2) {
478 return "!\"Invalid argument length for builtin function 'dissoc'. Expects at least 1 argument, supplied " (len - 1) "."
479 }
480 map = types_heap[idx][1]
481 if (map !~ /^\{/) {
482 return "!\"Incompatible type for argument 1 of builtin function 'dissoc'. Expects hash-map, supplied " types_typename(map) "."
483 }
484 for (i = 2; i < len; ++i) {
485 key = types_heap[idx][i]
486 if (key !~ /^[":]/) {
487 return "!\"Incompatible type for key argument of builtin function 'dissoc'. Expects string or keyword, supplied " types_typename(key) "."
488 }
489 del_list[key] = "1"
490 }
491 new_idx = types_allocate()
492 map_idx = substr(map, 2)
493 for (key in types_heap[map_idx]) {
494 if (key ~ /^[":]|^meta$/ && !(key in del_list)) {
495 types_addref(types_heap[new_idx][key] = types_heap[map_idx][key])
496 }
497 }
498 return "{" new_idx
499}
500
501function core_get(idx, map, key, map_idx)
502{
503 if (types_heap[idx]["len"] != 3) {
504 return "!\"Invalid argument length for builtin function 'get'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "."
505 }
506 map = types_heap[idx][1]
507 if (map !~ /^\{/ && map != "#nil") {
508 return "!\"Incompatible type for argument 1 of builtin function 'get'. Expects hash-map or nil, supplied " types_typename(map) "."
509 }
510 key = types_heap[idx][2]
511 if (key !~ /^[":]/) {
512 return "!\"Incompatible type for argument 2 of builtin function 'get'. Expects string or keyword, supplied " types_typename(key) "."
513 }
514 if (map != "#nil" && key in types_heap[map_idx = substr(map, 2)]) {
515 return types_addref(types_heap[map_idx][key])
516 } else {
517 return "#nil"
518 }
519}
520
521function core_containsp(idx, map, key)
522{
523 if (types_heap[idx]["len"] != 3) {
524 return "!\"Invalid argument length for builtin function 'contains?'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "."
525 }
526 map = types_heap[idx][1]
527 if (map !~ /^\{/) {
528 return "!\"Incompatible type for argument 1 of builtin function 'contains?'. Expects hash-map, supplied " types_typename(map) "."
529 }
530 key = types_heap[idx][2]
531 if (key !~ /^[":]/) {
532 return "!\"Incompatible type for argument 2 of builtin function 'contains?'. Expects string or keyword, supplied " types_typename(key) "."
533 }
534 return key in types_heap[substr(map, 2)] ? "#true" : "#false"
535}
536
537function core_keys(idx, map, map_idx, new_idx, len, key)
538{
539 if (types_heap[idx]["len"] != 2) {
540 return "!\"Invalid argument length for builtin function 'keys'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "."
541 }
542 map = types_heap[idx][1]
543 if (map !~ /^\{/) {
544 return "!\"Incompatible type for argument 1 of builtin function 'keys'. Expects hash-map, supplied " types_typename(map) "."
545 }
546 map_idx = substr(map, 2)
547 new_idx = types_allocate()
548 len = 0
549 for (key in types_heap[map_idx]) {
550 if (key ~ /^[":]/) {
551 types_heap[new_idx][len++] = key
552 }
553 }
554 types_heap[new_idx]["len"] = len
555 return "(" new_idx
556}
557
558function core_vals(idx, map, map_idx, new_idx, len, key)
559{
560 if (types_heap[idx]["len"] != 2) {
561 return "!\"Invalid argument length for builtin function 'vals'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "."
562 }
563 map = types_heap[idx][1]
564 if (map !~ /^\{/) {
565 return "!\"Incompatible type for argument 1 of builtin function 'vals'. Expects hash-map, supplied " types_typename(map) "."
566 }
567 map_idx = substr(map, 2)
568 new_idx = types_allocate()
569 len = 0
570 for (key in types_heap[map_idx]) {
571 if (key ~ /^[":]/) {
572 types_addref(types_heap[new_idx][len++] = types_heap[map_idx][key])
573 }
574 }
575 types_heap[new_idx]["len"] = len
576 return "(" new_idx
577}
578
579
580
581function core_sequentialp(idx)
582{
583 if (types_heap[idx]["len"] != 2) {
584 return "!\"Invalid argument length for builtin function 'sequential?'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "."
585 }
586 return types_heap[idx][1] ~ /^[([]/ ? "#true" : "#false"
587}
588
589function core_cons(idx, lst, lst_idx, new_idx, len, i)
590{
591 if (types_heap[idx]["len"] != 3) {
592 return "!\"Invalid argument length for builtin function 'cons'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "."
593 }
594 lst = types_heap[idx][2]
595 if (lst !~ /^[([]/) {
596 return "!\"Incompatible type for argument 1 of builtin function 'cons'. Expects list or vector, supplied " types_typename(lst) "."
597 }
598 lst_idx = substr(lst, 2)
599 new_idx = types_allocate()
600 types_addref(types_heap[new_idx][0] = types_heap[idx][1])
601 len = types_heap[lst_idx]["len"]
602 for (i = 0; i < len; ++i) {
603 types_addref(types_heap[new_idx][i + 1] = types_heap[lst_idx][i])
604 }
605 types_heap[new_idx]["len"] = len + 1
606 return "(" new_idx
607}
608
609function core_concat(idx, new_idx, new_len, len, i, lst, lst_idx, lst_len, j)
610{
611 new_idx = types_allocate()
612 new_len = 0
613 len = types_heap[idx]["len"]
614 for (i = 1; i < len; ++i) {
615 lst = types_heap[idx][i]
616 if (lst !~ /^[([]/) {
617 types_heap[new_idx]["len"] = new_len
618 types_release("(" new_idx)
619 return "!\"Incompatible type for argument ' (i - 1) ' of builtin function 'concat'. Expects list or vector, supplied " types_typename(lst) "."
620 }
621 lst_idx = substr(lst, 2)
622 lst_len = types_heap[lst_idx]["len"]
623 for (j = 0; j < lst_len; ++j) {
624 types_addref(types_heap[new_idx][new_len++] = types_heap[lst_idx][j])
625 }
626 }
627 types_heap[new_idx]["len"] = new_len
628 return "(" new_idx
629}
630
fbfe6784
NB		 631function core_vec(idx, new_idx, len)
632{
633 len = types_heap[idx]["len"]
634 if (len != 2)
635 return "!\"Invalid argument length for builtin function 'vec'. Expects exactly 1 argument, supplied " (len - 1) "."
636 idx = types_heap[idx][1]
637 if (idx !~ /^[([]/) {
638 return "!\"Incompatible type for argument 1 of builtin function 'vec'. Expects list or vector, supplied " types_typename(idx) "."
639 }
640 idx = substr(idx, 2)
641 len = types_heap[idx]["len"]
642 new_idx = types_allocate()
643 types_heap[new_idx]["len"] = len
644 while (len--)
645 types_addref(types_heap[new_idx][len] = types_heap[idx][len])
646 return "[" new_idx
647}
648
8c7587af
MK		 649function core_nth(idx, lst, num, n, lst_idx)
650{
651 if (types_heap[idx]["len"] != 3) {
652 return "!\"Invalid argument length for builtin function 'nth'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "."
653 }
654 lst = types_heap[idx][1]
655 if (lst !~ /^[([]/) {
656 return "!\"Incompatible type for argument 1 of builtin function 'nth'. Expects list or vector, supplied " types_typename(lst) "."
657 }
658 num = types_heap[idx][2]
659 if (num !~ /^\+/) {
660 return "!\"Incompatible type for argument 2 of builtin function 'nth'. Expects number, supplied " types_typename(num) "."
661 }
662 n = substr(num, 2) + 0
663 lst_idx = substr(lst, 2)
664 if (n < 0 || types_heap[lst_idx]["len"] <= n) {
665 return "!\"Index out of range. Sequence length is " types_heap[lst_idx]["len"] ", supplied " n "."
666 }
667 return types_addref(types_heap[lst_idx][n])
668}
669
670function core_first(idx, lst, lst_idx)
671{
672 if (types_heap[idx]["len"] != 2) {
673 return "!\"Invalid argument length for builtin function 'first'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "."
674 }
675 lst = types_heap[idx][1]
6832696b
DM		 676 if (lst == "#nil") {
677 return "#nil"
678 }
8c7587af 679 if (lst !~ /^[([]/) {
6832696b 680 return "!\"Incompatible type for argument 1 of builtin function 'first'. Expects list, vector or nil, supplied " types_typename(lst) "."
8c7587af
MK		 681 }
682 lst_idx = substr(lst, 2)
683 return types_heap[lst_idx]["len"] == 0 ? "#nil" : types_addref(types_heap[lst_idx][0])
684}
685
686function core_rest(idx, lst, lst_idx, lst_len, new_idx, i)
687{
688 if (types_heap[idx]["len"] != 2) {
689 return "!\"Invalid argument length for builtin function 'rest'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "."
690 }
691 lst = types_heap[idx][1]
6832696b
DM		 692 if (lst == "#nil") {
693 new_idx = types_allocate()
694 types_heap[new_idx]["len"] = 0
695 return "(" new_idx
696 }
8c7587af 697 if (lst !~ /^[([]/) {
6832696b 698 return "!\"Incompatible type for argument 1 of builtin function 'rest'. Expects list, vector or nil, supplied " types_typename(lst) "."
8c7587af
MK		 699 }
700 lst_idx = substr(lst, 2)
701 lst_len = types_heap[lst_idx]["len"]
702 new_idx = types_allocate()
703 for (i = 1; i < lst_len; ++i) {
704 types_addref(types_heap[new_idx][i - 1] = types_heap[lst_idx][i])
705 }
706 types_heap[new_idx]["len"] = lst_len - 1
707 return "(" new_idx
708}
709
710function core_emptyp(idx, lst)
711{
712 if (types_heap[idx]["len"] != 2) {
713 return "!\"Invalid argument length for builtin function 'empty?'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "."
714 }
715 lst = types_heap[idx][1]
716 if (lst !~ /^[([]/) {
717 return "!\"Incompatible type for argument 1 of builtin function 'empty?'. Expects list or vector, supplied " types_typename(lst) "."
718 }
719 return types_heap[substr(lst, 2)]["len"] == 0 ? "#true" : "#false"
720}
721
722function core_count(idx, lst)
723{
724 if (types_heap[idx]["len"] != 2) {
725 return "!\"Invalid argument length for builtin function 'count'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "."
726 }
727 lst = types_heap[idx][1]
728 if (lst ~ /^[([]/) {
729 return "+" types_heap[substr(lst, 2)]["len"]
730 }
731 if (lst == "#nil") {
732 return "+0"
733 }
734 return "!\"Incompatible type for argument 1 of builtin function 'count'. Expects list, vector or nil, supplied " types_typename(lst) "."
735}
736
737function core_apply(idx, len, f, lst, new_idx, i, lst_idx, lst_len, f_idx, env, ret)
738{
739 len = types_heap[idx]["len"]
740 if (len < 3) {
741 return "!\"Invalid argument length for builtin function 'apply'. Expects at least 2 arguments, supplied " (len - 1) "."
742 }
743 f = types_heap[idx][1]
744 if (f !~ /^[$&%]/) {
745 return "!\"Incompatible type for argument 1 of builtin function 'apply'. Expects function, supplied " types_typename(f) "."
746 }
747 lst = types_heap[idx][len - 1]
748 if (lst !~ /^[([]/) {
749 return "!\"Incompatible type for argument ' (len - 1) ' of builtin function 'apply'. Expects list or vector, supplied " types_typename(lst) "."
750 }
751
752 new_idx = types_allocate()
753 types_addref(types_heap[new_idx][0] = f)
754 for (i = 2; i < len - 1; ++i) {
755 types_addref(types_heap[new_idx][i - 1] = types_heap[idx][i])
756 }
757 lst_idx = substr(lst, 2)
758 lst_len = types_heap[lst_idx]["len"]
759 for (i = 0; i < lst_len; ++i) {
760 types_addref(types_heap[new_idx][len + i - 2] = types_heap[lst_idx][i])
761 }
762 types_heap[new_idx]["len"] = len + lst_len - 2
763
764 f_idx = substr(f, 2)
765 switch (f) {
766 case /^\$/:
767 env = env_new(types_heap[f_idx]["env"], types_heap[f_idx]["params"], new_idx)
768 types_release("(" new_idx)
769 if (env ~ /^!/) {
770 return env
771 }
772 ret = EVAL(types_addref(types_heap[f_idx]["body"]), env)
773 env_release(env)
774 return ret
775 case /^%/:
776 f_idx = types_heap[f_idx]["func"]
777 case /^&/:
778 ret = @f_idx(new_idx)
779 types_release("(" new_idx)
780 return ret
781 }
782}
783
784function core_map(idx, f, lst, f_idx, lst_idx, lst_len, new_idx, expr_idx, i, env, ret, val)
785{
786 if (types_heap[idx]["len"] != 3) {
787 return "!\"Invalid argument length for builtin function 'map'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "."
788 }
789 f = types_heap[idx][1]
790 if (f !~ /^[$&%]/) {
791 return "!\"Incompatible type for argument 1 of builtin function 'map'. Expects function, supplied " types_typename(f) "."
792 }
793 lst = types_heap[idx][2]
794 if (lst !~ /^[([]/) {
795 return "!\"Incompatible type for argument 2 of builtin function 'map'. Expects list or vector, supplied " types_typename(lst) "."
796 }
797 f_idx = substr(f, 2)
798 lst_idx = substr(lst, 2)
799 lst_len = types_heap[lst_idx]["len"]
800 new_idx = types_allocate()
801 types_heap[new_idx][0] = f
802 types_heap[new_idx]["len"] = 2
803 expr_idx = types_allocate()
804 for (i = 0; i < lst_len; ++i) {
805 types_heap[new_idx][1] = types_heap[lst_idx][i]
806 switch (f) {
807 case /^\$/:
808 env = env_new(types_heap[f_idx]["env"], types_heap[f_idx]["params"], new_idx)
809 if (env ~ /^!/) {
810 types_heap[expr_idx]["len"] = i
811 types_heap[new_idx]["len"] = 0
812 types_release("(" expr_idx)
813 types_release("(" new_idx)
814 return env
815 }
816 ret = EVAL(types_addref(types_heap[f_idx]["body"]), env)
817 env_release(env)
818 break
819 case /^%/:
820 f_idx = types_heap[f_idx]["func"]
821 case /^&/:
822 ret = @f_idx(new_idx)
823 break
824 }
825 if (ret ~ /^!/) {
826 types_heap[expr_idx]["len"] = i
827 types_heap[new_idx]["len"] = 0
828 types_release("(" expr_idx)
829 types_release("(" new_idx)
830 return ret
831 }
832 types_heap[expr_idx][i] = ret
833 }
834 types_heap[expr_idx]["len"] = lst_len
835 types_heap[new_idx]["len"] = 0
836 types_release("(" new_idx)
837 return "(" expr_idx
838}
839
840
841
842function core_conj(idx, len, lst, lst_idx, lst_len, new_idx, i, j)
843{
844 len = types_heap[idx]["len"]
845 if (len < 3) {
846 return "!\"Invalid argument length for builtin function 'conj'. Expects at least 2 arguments, supplied " (len - 1) "."
847 }
848 lst = types_heap[idx][1]
849 if (lst !~ /^[([]/) {
850 return "!\"Incompatible type for argument 1 of builtin function 'conj'. Expects list or vector, supplied " types_typename(lst) "."
851 }
852 lst_idx = substr(lst, 2)
853 lst_len = types_heap[lst_idx]["len"]
854 new_idx = types_allocate()
855 j = 0
856 if (lst ~ /^\(/) {
857 for (i = len - 1; i >= 2; --i) {
858 types_addref(types_heap[new_idx][j++] = types_heap[idx][i])
859 }
860 for (i = 0; i < lst_len; ++i) {
861 types_addref(types_heap[new_idx][j++] = types_heap[lst_idx][i])
862 }
863 } else {
864 for (i = 0; i < lst_len; ++i) {
865 types_addref(types_heap[new_idx][j++] = types_heap[lst_idx][i])
866 }
867 for (i = 2; i < len; ++i) {
868 types_addref(types_heap[new_idx][j++] = types_heap[idx][i])
869 }
870 }
871 types_addref(types_heap[new_idx]["meta"] = types_heap[lst_idx]["meta"])
872 types_heap[new_idx]["len"] = j
873 return substr(lst, 1, 1) new_idx
874}
875
48f757da
JM		 876function core_seq(idx, obj, obj_idx, new_idx, i, len, chars)
877{
878 if (types_heap[idx]["len"] != 2) {
879 return "!\"Invalid argument length for builtin function 'seq'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "."
880 }
881 obj = types_heap[idx][1]
882 if (obj ~ /^[(]/) {
883 if (types_heap[substr(obj, 2)]["len"] == 0) {
884 return "#nil"
885 }
886 return types_addref(obj)
887 } else if (obj ~ /^\[/) {
888 obj_idx = substr(obj, 2)
889 len = types_heap[obj_idx]["len"]
890 if (len == 0) { return "#nil" }
891 new_idx = types_allocate()
892 for (i = 0; i < len; ++i) {
893 types_addref(types_heap[new_idx][i] = types_heap[obj_idx][i])
894 }
895 types_heap[new_idx]["len"] = len
896 return "(" new_idx
897 } else if (obj ~ /^"/) {
898 obj_idx = substr(obj, 2)
899 len = length(obj_idx)
900 if (len == 0) { return "#nil" }
901 new_idx = types_allocate()
902 split(obj_idx, chars, "")
903 for (i = 0; i <= len; ++i) {
904 types_heap[new_idx][i] = "\"" chars[i+1]
905 }
906 types_heap[new_idx]["len"] = len
907 return "(" new_idx
908 } else if (obj == "#nil") {
909 return "#nil"
910 } else {
911 return "!\"seq: called on non-sequence"
912 }
913}
8c7587af
MK		 914
915
916function core_meta(idx, obj, obj_idx)
917{
918 if (types_heap[idx]["len"] != 2) {
919 return "!\"Invalid argument length for builtin function 'meta'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "."
920 }
921 obj = types_heap[idx][1]
922 if (obj ~ /^[([{$%]/ && "meta" in types_heap[obj_idx = substr(obj, 2)]) {
923 return types_addref(types_heap[obj_idx]["meta"])
924 }
925 return "#nil"
926}
927
928function core_with_meta(idx, obj, obj_idx, new_idx, i, len)
929{
930 if (types_heap[idx]["len"] != 3) {
931 return "!\"Invalid argument length for builtin function 'with-meta'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "."
932 }
933 obj = types_heap[idx][1]
934 obj_idx = substr(obj, 2)
935 new_idx = types_allocate()
936 types_addref(types_heap[new_idx]["meta"] = types_heap[idx][2])
937 switch (obj) {
938 case /^[([]/:
939 len = types_heap[obj_idx]["len"]
940 for (i = 0; i < len; ++i) {
941 types_addref(types_heap[new_idx][i] = types_heap[obj_idx][i])
942 }
943 types_heap[new_idx]["len"] = len
944 return substr(obj, 1, 1) new_idx
945 case /^\{/:
946 for (i in types_heap[obj_idx]) {
947 if (i ~ /^[":]/) {
948 types_addref(types_heap[new_idx][i] = types_heap[obj_idx][i])
949 }
950 }
951 return "{" new_idx
952 case /^\$/:
953 types_addref(types_heap[new_idx]["params"] = types_heap[obj_idx]["params"])
954 types_addref(types_heap[new_idx]["body"] = types_heap[obj_idx]["body"])
955 env_addref(types_heap[new_idx]["env"] = types_heap[obj_idx]["env"])
956 return "$" new_idx
957 case /^&/:
958 types_heap[new_idx]["func"] = obj_idx
959 return "%" new_idx
960 case /^%/:
961 types_heap[new_idx]["func"] = types_heap[obj_idx]["func"]
962 return "%" new_idx
963 default:
964 types_release("{" new_idx)
965 return "!\"Incompatible type for argument 1 of builtin function 'with-meta'. Expects list, vector, hash-map or function, supplied " types_typename(lst) "."
966 }
967}
968
969function core_atom(idx, atom_idx)
970{
971 if (types_heap[idx]["len"] != 2) {
972 return "!\"Invalid argument length for builtin function 'atom'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "."
973 }
974 atom_idx = types_allocate()
975 types_addref(types_heap[atom_idx]["obj"] = types_heap[idx][1])
976 return "?" atom_idx
977}
978
979function core_atomp(idx)
980{
981 if (types_heap[idx]["len"] != 2) {
982 return "!\"Invalid argument length for builtin function 'atom?'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "."
983 }
984 return types_heap[idx][1] ~ /^\?/ ? "#true" : "#false"
985}
986
987function core_deref(idx, atom)
988{
989 if (types_heap[idx]["len"] != 2) {
990 return "!\"Invalid argument length for builtin function 'deref'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "."
991 }
992 atom = types_heap[idx][1]
993 if (atom !~ /^\?/) {
994 return "!\"Incompatible type for argument 1 of builtin function 'deref'. Expects atom, supplied " types_typename(atom) "."
995 }
996 return types_addref(types_heap[substr(atom, 2)]["obj"])
997}
998
999function core_reset(idx, atom, atom_idx)
1000{
1001 if (types_heap[idx]["len"] != 3) {
1002 return "!\"Invalid argument length for builtin function 'reset!'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "."
1003 }
1004 atom = types_heap[idx][1]
1005 if (atom !~ /^\?/) {
1006 return "!\"Incompatible type for argument 1 of builtin function 'reset!'. Expects atom, supplied " types_typename(atom) "."
1007 }
1008 atom_idx = substr(atom, 2)
1009 types_release(types_heap[atom_idx]["obj"])
1010 return types_addref(types_heap[atom_idx]["obj"] = types_heap[idx][2])
1011}
1012
1013function core_swap(idx, expr, atom, f, lst_idx, ret, f_idx, env, i, len, atom_idx)
1014{
1015 len = types_heap[idx]["len"]
1016 if (len < 3) {
1017 return "!\"Invalid argument length for builtin function 'swap!'. Expects at least 2 arguments, supplied " (len - 1) "."
1018 }
1019 atom = types_heap[idx][1]
1020 if (atom !~ /^\?/) {
1021 return "!\"Incompatible type for argument 1 of builtin function 'swap!'. Expects atom, supplied " types_typename(atom) "."
1022 }
1023 f = types_heap[idx][2]
1024 if (f !~ /^[&$%]/) {
1025 return "!\"Incompatible type for argument 2 of builtin function 'swap!'. Expects function, supplied " types_typename(f) "."
1026 }
1027 lst_idx = types_allocate()
1028 atom_idx = substr(atom, 2)
1029 types_addref(types_heap[lst_idx][0] = f)
1030 types_addref(types_heap[lst_idx][1] = types_heap[atom_idx]["obj"])
1031 for (i = 3; i < len; ++i) {
1032 types_addref(types_heap[lst_idx][i - 1] = types_heap[idx][i])
1033 }
1034 types_heap[lst_idx]["len"] = len - 1
1035
1036 f_idx = substr(f, 2)
1037 switch (f) {
1038 case /^\$/:
1039 env = env_new(types_heap[f_idx]["env"], types_heap[f_idx]["params"], lst_idx)
1040 types_release("(" lst_idx)
1041 if (env ~ /^!/) {
1042 return env
1043 }
1044 ret = EVAL(types_addref(types_heap[f_idx]["body"]), env)
1045 env_release(env)
1046 break
1047 case /^%/:
1048 f_idx = types_heap[f_idx]["func"]
1049 case /^&/:
1050 ret = @f_idx(lst_idx)
1051 types_release("(" lst_idx)
1052 break
1053 }
1054
1055 if (ret ~ /^!/) {
1056 return ret
1057 }
1058 types_release(types_heap[atom_idx]["obj"])
1059 return types_addref(types_heap[atom_idx]["obj"] = ret)
1060}
1061
1062function core_init()
1063{
1064 core_ns["'="] = "&core_eq"
1065 core_ns["'throw"] = "&core_throw"
1066
1067 core_ns["'nil?"] = "&core_nilp"
1068 core_ns["'true?"] = "&core_truep"
1069 core_ns["'false?"] = "&core_falsep"
48f757da 1070 core_ns["'string?"] = "&core_stringp"
8c7587af
MK		 1071 core_ns["'symbol"] = "&core_symbol"
1072 core_ns["'symbol?"] = "&core_symbolp"
1073 core_ns["'keyword"] = "&core_keyword"
1074 core_ns["'keyword?"] = "&core_keywordp"
d90be1a9
DM		 1075 core_ns["'number?"] = "&core_numberp"
1076 core_ns["'fn?"] = "&core_fnp"
1077 core_ns["'macro?"] = "&core_macrop"
8c7587af
MK		 1078
1079 core_ns["'pr-str"] = "&core_pr_str"
1080 core_ns["'str"] = "&core_str"
1081 core_ns["'prn"] = "&core_prn"
1082 core_ns["'println"] = "&core_println"
1083 core_ns["'read-string"] = "&core_read_string"
1084 core_ns["'readline"] = "&core_readline"
1085 core_ns["'slurp"] = "&core_slurp"
1086
1087 core_ns["'<"] = "&core_lt"
1088 core_ns["'<="] = "&core_le"
1089 core_ns["'>"] = "&core_gt"
1090 core_ns["'>="] = "&core_ge"
1091 core_ns["'+"] = "&core_add"
1092 core_ns["'-"] = "&core_subtract"
1093 core_ns["'*"] = "&core_multiply"
1094 core_ns["'/"] = "&core_divide"
1095 core_ns["'time-ms"] = "&core_time_ms"
1096
1097 core_ns["'list"] = "&core_list"
1098 core_ns["'list?"] = "&core_listp"
fbfe6784 1099 core_ns["'vec"] = "&core_vec"
8c7587af
MK		 1100 core_ns["'vector"] = "&core_vector"
1101 core_ns["'vector?"] = "&core_vectorp"
1102 core_ns["'hash-map"] = "&core_hash_map"
1103 core_ns["'map?"] = "&core_mapp"
1104 core_ns["'assoc"] = "&core_assoc"
1105 core_ns["'dissoc"] = "&core_dissoc"
1106 core_ns["'get"] = "&core_get"
1107 core_ns["'contains?"] = "&core_containsp"
1108 core_ns["'keys"] = "&core_keys"
1109 core_ns["'vals"] = "&core_vals"
1110
1111 core_ns["'sequential?"] = "&core_sequentialp"
1112 core_ns["'cons"] = "&core_cons"
1113 core_ns["'concat"] = "&core_concat"
1114 core_ns["'nth"] = "&core_nth"
1115 core_ns["'first"] = "&core_first"
1116 core_ns["'rest"] = "&core_rest"
1117 core_ns["'empty?"] = "&core_emptyp"
1118 core_ns["'count"] = "&core_count"
1119 core_ns["'apply"] = "&core_apply"
1120 core_ns["'map"] = "&core_map"
1121
1122 core_ns["'conj"] = "&core_conj"
48f757da 1123 core_ns["'seq"] = "&core_seq"
8c7587af
MK		 1124
1125 core_ns["'meta"] = "&core_meta"
1126 core_ns["'with-meta"] = "&core_with_meta"
1127 core_ns["'atom"] = "&core_atom"
1128 core_ns["'atom?"] = "&core_atomp"
1129 core_ns["'deref"] = "&core_deref"
1130 core_ns["'reset!"] = "&core_reset"
1131 core_ns["'swap!"] = "&core_swap"
1132}
1133
1134
1135
1136BEGIN {
1137 core_init()
1138}
Make a Lisp: jackhill's copy of https://github.com/kanaka/mal