HCoop / jackhill / mal.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
DISABLE FDs (REMOVE ME).
[jackhill/mal.git] / 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
631function core_nth(idx, lst, num, n, lst_idx)
632{
633 if (types_heap[idx]["len"] != 3) {
634 return "!\"Invalid argument length for builtin function 'nth'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "."
635 }
636 lst = types_heap[idx][1]
637 if (lst !~ /^[([]/) {
638 return "!\"Incompatible type for argument 1 of builtin function 'nth'. Expects list or vector, supplied " types_typename(lst) "."
639 }
640 num = types_heap[idx][2]
641 if (num !~ /^\+/) {
642 return "!\"Incompatible type for argument 2 of builtin function 'nth'. Expects number, supplied " types_typename(num) "."
643 }
644 n = substr(num, 2) + 0
645 lst_idx = substr(lst, 2)
646 if (n < 0 || types_heap[lst_idx]["len"] <= n) {
647 return "!\"Index out of range. Sequence length is " types_heap[lst_idx]["len"] ", supplied " n "."
648 }
649 return types_addref(types_heap[lst_idx][n])
650}
651
652function core_first(idx, lst, lst_idx)
653{
654 if (types_heap[idx]["len"] != 2) {
655 return "!\"Invalid argument length for builtin function 'first'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "."
656 }
657 lst = types_heap[idx][1]
6832696b
DM		 658 if (lst == "#nil") {
659 return "#nil"
660 }
8c7587af 661 if (lst !~ /^[([]/) {
6832696b 662 return "!\"Incompatible type for argument 1 of builtin function 'first'. Expects list, vector or nil, supplied " types_typename(lst) "."
8c7587af
MK		 663 }
664 lst_idx = substr(lst, 2)
665 return types_heap[lst_idx]["len"] == 0 ? "#nil" : types_addref(types_heap[lst_idx][0])
666}
667
668function core_rest(idx, lst, lst_idx, lst_len, new_idx, i)
669{
670 if (types_heap[idx]["len"] != 2) {
671 return "!\"Invalid argument length for builtin function 'rest'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "."
672 }
673 lst = types_heap[idx][1]
6832696b
DM		 674 if (lst == "#nil") {
675 new_idx = types_allocate()
676 types_heap[new_idx]["len"] = 0
677 return "(" new_idx
678 }
8c7587af 679 if (lst !~ /^[([]/) {
6832696b 680 return "!\"Incompatible type for argument 1 of builtin function 'rest'. Expects list, vector or nil, supplied " types_typename(lst) "."
8c7587af
MK		 681 }
682 lst_idx = substr(lst, 2)
683 lst_len = types_heap[lst_idx]["len"]
684 new_idx = types_allocate()
685 for (i = 1; i < lst_len; ++i) {
686 types_addref(types_heap[new_idx][i - 1] = types_heap[lst_idx][i])
687 }
688 types_heap[new_idx]["len"] = lst_len - 1
689 return "(" new_idx
690}
691
692function core_emptyp(idx, lst)
693{
694 if (types_heap[idx]["len"] != 2) {
695 return "!\"Invalid argument length for builtin function 'empty?'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "."
696 }
697 lst = types_heap[idx][1]
698 if (lst !~ /^[([]/) {
699 return "!\"Incompatible type for argument 1 of builtin function 'empty?'. Expects list or vector, supplied " types_typename(lst) "."
700 }
701 return types_heap[substr(lst, 2)]["len"] == 0 ? "#true" : "#false"
702}
703
704function core_count(idx, lst)
705{
706 if (types_heap[idx]["len"] != 2) {
707 return "!\"Invalid argument length for builtin function 'count'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "."
708 }
709 lst = types_heap[idx][1]
710 if (lst ~ /^[([]/) {
711 return "+" types_heap[substr(lst, 2)]["len"]
712 }
713 if (lst == "#nil") {
714 return "+0"
715 }
716 return "!\"Incompatible type for argument 1 of builtin function 'count'. Expects list, vector or nil, supplied " types_typename(lst) "."
717}
718
719function core_apply(idx, len, f, lst, new_idx, i, lst_idx, lst_len, f_idx, env, ret)
720{
721 len = types_heap[idx]["len"]
722 if (len < 3) {
723 return "!\"Invalid argument length for builtin function 'apply'. Expects at least 2 arguments, supplied " (len - 1) "."
724 }
725 f = types_heap[idx][1]
726 if (f !~ /^[$&%]/) {
727 return "!\"Incompatible type for argument 1 of builtin function 'apply'. Expects function, supplied " types_typename(f) "."
728 }
729 lst = types_heap[idx][len - 1]
730 if (lst !~ /^[([]/) {
731 return "!\"Incompatible type for argument ' (len - 1) ' of builtin function 'apply'. Expects list or vector, supplied " types_typename(lst) "."
732 }
733
734 new_idx = types_allocate()
735 types_addref(types_heap[new_idx][0] = f)
736 for (i = 2; i < len - 1; ++i) {
737 types_addref(types_heap[new_idx][i - 1] = types_heap[idx][i])
738 }
739 lst_idx = substr(lst, 2)
740 lst_len = types_heap[lst_idx]["len"]
741 for (i = 0; i < lst_len; ++i) {
742 types_addref(types_heap[new_idx][len + i - 2] = types_heap[lst_idx][i])
743 }
744 types_heap[new_idx]["len"] = len + lst_len - 2
745
746 f_idx = substr(f, 2)
747 switch (f) {
748 case /^\$/:
749 env = env_new(types_heap[f_idx]["env"], types_heap[f_idx]["params"], new_idx)
750 types_release("(" new_idx)
751 if (env ~ /^!/) {
752 return env
753 }
754 ret = EVAL(types_addref(types_heap[f_idx]["body"]), env)
755 env_release(env)
756 return ret
757 case /^%/:
758 f_idx = types_heap[f_idx]["func"]
759 case /^&/:
760 ret = @f_idx(new_idx)
761 types_release("(" new_idx)
762 return ret
763 }
764}
765
766function core_map(idx, f, lst, f_idx, lst_idx, lst_len, new_idx, expr_idx, i, env, ret, val)
767{
768 if (types_heap[idx]["len"] != 3) {
769 return "!\"Invalid argument length for builtin function 'map'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "."
770 }
771 f = types_heap[idx][1]
772 if (f !~ /^[$&%]/) {
773 return "!\"Incompatible type for argument 1 of builtin function 'map'. Expects function, supplied " types_typename(f) "."
774 }
775 lst = types_heap[idx][2]
776 if (lst !~ /^[([]/) {
777 return "!\"Incompatible type for argument 2 of builtin function 'map'. Expects list or vector, supplied " types_typename(lst) "."
778 }
779 f_idx = substr(f, 2)
780 lst_idx = substr(lst, 2)
781 lst_len = types_heap[lst_idx]["len"]
782 new_idx = types_allocate()
783 types_heap[new_idx][0] = f
784 types_heap[new_idx]["len"] = 2
785 expr_idx = types_allocate()
786 for (i = 0; i < lst_len; ++i) {
787 types_heap[new_idx][1] = types_heap[lst_idx][i]
788 switch (f) {
789 case /^\$/:
790 env = env_new(types_heap[f_idx]["env"], types_heap[f_idx]["params"], new_idx)
791 if (env ~ /^!/) {
792 types_heap[expr_idx]["len"] = i
793 types_heap[new_idx]["len"] = 0
794 types_release("(" expr_idx)
795 types_release("(" new_idx)
796 return env
797 }
798 ret = EVAL(types_addref(types_heap[f_idx]["body"]), env)
799 env_release(env)
800 break
801 case /^%/:
802 f_idx = types_heap[f_idx]["func"]
803 case /^&/:
804 ret = @f_idx(new_idx)
805 break
806 }
807 if (ret ~ /^!/) {
808 types_heap[expr_idx]["len"] = i
809 types_heap[new_idx]["len"] = 0
810 types_release("(" expr_idx)
811 types_release("(" new_idx)
812 return ret
813 }
814 types_heap[expr_idx][i] = ret
815 }
816 types_heap[expr_idx]["len"] = lst_len
817 types_heap[new_idx]["len"] = 0
818 types_release("(" new_idx)
819 return "(" expr_idx
820}
821
822
823
824function core_conj(idx, len, lst, lst_idx, lst_len, new_idx, i, j)
825{
826 len = types_heap[idx]["len"]
827 if (len < 3) {
828 return "!\"Invalid argument length for builtin function 'conj'. Expects at least 2 arguments, supplied " (len - 1) "."
829 }
830 lst = types_heap[idx][1]
831 if (lst !~ /^[([]/) {
832 return "!\"Incompatible type for argument 1 of builtin function 'conj'. Expects list or vector, supplied " types_typename(lst) "."
833 }
834 lst_idx = substr(lst, 2)
835 lst_len = types_heap[lst_idx]["len"]
836 new_idx = types_allocate()
837 j = 0
838 if (lst ~ /^\(/) {
839 for (i = len - 1; i >= 2; --i) {
840 types_addref(types_heap[new_idx][j++] = types_heap[idx][i])
841 }
842 for (i = 0; i < lst_len; ++i) {
843 types_addref(types_heap[new_idx][j++] = types_heap[lst_idx][i])
844 }
845 } else {
846 for (i = 0; i < lst_len; ++i) {
847 types_addref(types_heap[new_idx][j++] = types_heap[lst_idx][i])
848 }
849 for (i = 2; i < len; ++i) {
850 types_addref(types_heap[new_idx][j++] = types_heap[idx][i])
851 }
852 }
853 types_addref(types_heap[new_idx]["meta"] = types_heap[lst_idx]["meta"])
854 types_heap[new_idx]["len"] = j
855 return substr(lst, 1, 1) new_idx
856}
857
48f757da
JM		 858function core_seq(idx, obj, obj_idx, new_idx, i, len, chars)
859{
860 if (types_heap[idx]["len"] != 2) {
861 return "!\"Invalid argument length for builtin function 'seq'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "."
862 }
863 obj = types_heap[idx][1]
864 if (obj ~ /^[(]/) {
865 if (types_heap[substr(obj, 2)]["len"] == 0) {
866 return "#nil"
867 }
868 return types_addref(obj)
869 } else if (obj ~ /^\[/) {
870 obj_idx = substr(obj, 2)
871 len = types_heap[obj_idx]["len"]
872 if (len == 0) { return "#nil" }
873 new_idx = types_allocate()
874 for (i = 0; i < len; ++i) {
875 types_addref(types_heap[new_idx][i] = types_heap[obj_idx][i])
876 }
877 types_heap[new_idx]["len"] = len
878 return "(" new_idx
879 } else if (obj ~ /^"/) {
880 obj_idx = substr(obj, 2)
881 len = length(obj_idx)
882 if (len == 0) { return "#nil" }
883 new_idx = types_allocate()
884 split(obj_idx, chars, "")
885 for (i = 0; i <= len; ++i) {
886 types_heap[new_idx][i] = "\"" chars[i+1]
887 }
888 types_heap[new_idx]["len"] = len
889 return "(" new_idx
890 } else if (obj == "#nil") {
891 return "#nil"
892 } else {
893 return "!\"seq: called on non-sequence"
894 }
895}
8c7587af
MK		 896
897
898function core_meta(idx, obj, obj_idx)
899{
900 if (types_heap[idx]["len"] != 2) {
901 return "!\"Invalid argument length for builtin function 'meta'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "."
902 }
903 obj = types_heap[idx][1]
904 if (obj ~ /^[([{$%]/ && "meta" in types_heap[obj_idx = substr(obj, 2)]) {
905 return types_addref(types_heap[obj_idx]["meta"])
906 }
907 return "#nil"
908}
909
910function core_with_meta(idx, obj, obj_idx, new_idx, i, len)
911{
912 if (types_heap[idx]["len"] != 3) {
913 return "!\"Invalid argument length for builtin function 'with-meta'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "."
914 }
915 obj = types_heap[idx][1]
916 obj_idx = substr(obj, 2)
917 new_idx = types_allocate()
918 types_addref(types_heap[new_idx]["meta"] = types_heap[idx][2])
919 switch (obj) {
920 case /^[([]/:
921 len = types_heap[obj_idx]["len"]
922 for (i = 0; i < len; ++i) {
923 types_addref(types_heap[new_idx][i] = types_heap[obj_idx][i])
924 }
925 types_heap[new_idx]["len"] = len
926 return substr(obj, 1, 1) new_idx
927 case /^\{/:
928 for (i in types_heap[obj_idx]) {
929 if (i ~ /^[":]/) {
930 types_addref(types_heap[new_idx][i] = types_heap[obj_idx][i])
931 }
932 }
933 return "{" new_idx
934 case /^\$/:
935 types_addref(types_heap[new_idx]["params"] = types_heap[obj_idx]["params"])
936 types_addref(types_heap[new_idx]["body"] = types_heap[obj_idx]["body"])
937 env_addref(types_heap[new_idx]["env"] = types_heap[obj_idx]["env"])
938 return "$" new_idx
939 case /^&/:
940 types_heap[new_idx]["func"] = obj_idx
941 return "%" new_idx
942 case /^%/:
943 types_heap[new_idx]["func"] = types_heap[obj_idx]["func"]
944 return "%" new_idx
945 default:
946 types_release("{" new_idx)
947 return "!\"Incompatible type for argument 1 of builtin function 'with-meta'. Expects list, vector, hash-map or function, supplied " types_typename(lst) "."
948 }
949}
950
951function core_atom(idx, atom_idx)
952{
953 if (types_heap[idx]["len"] != 2) {
954 return "!\"Invalid argument length for builtin function 'atom'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "."
955 }
956 atom_idx = types_allocate()
957 types_addref(types_heap[atom_idx]["obj"] = types_heap[idx][1])
958 return "?" atom_idx
959}
960
961function core_atomp(idx)
962{
963 if (types_heap[idx]["len"] != 2) {
964 return "!\"Invalid argument length for builtin function 'atom?'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "."
965 }
966 return types_heap[idx][1] ~ /^\?/ ? "#true" : "#false"
967}
968
969function core_deref(idx, atom)
970{
971 if (types_heap[idx]["len"] != 2) {
972 return "!\"Invalid argument length for builtin function 'deref'. Expects exactly 1 argument, supplied " (types_heap[idx]["len"] - 1) "."
973 }
974 atom = types_heap[idx][1]
975 if (atom !~ /^\?/) {
976 return "!\"Incompatible type for argument 1 of builtin function 'deref'. Expects atom, supplied " types_typename(atom) "."
977 }
978 return types_addref(types_heap[substr(atom, 2)]["obj"])
979}
980
981function core_reset(idx, atom, atom_idx)
982{
983 if (types_heap[idx]["len"] != 3) {
984 return "!\"Invalid argument length for builtin function 'reset!'. Expects exactly 2 arguments, supplied " (types_heap[idx]["len"] - 1) "."
985 }
986 atom = types_heap[idx][1]
987 if (atom !~ /^\?/) {
988 return "!\"Incompatible type for argument 1 of builtin function 'reset!'. Expects atom, supplied " types_typename(atom) "."
989 }
990 atom_idx = substr(atom, 2)
991 types_release(types_heap[atom_idx]["obj"])
992 return types_addref(types_heap[atom_idx]["obj"] = types_heap[idx][2])
993}
994
995function core_swap(idx, expr, atom, f, lst_idx, ret, f_idx, env, i, len, atom_idx)
996{
997 len = types_heap[idx]["len"]
998 if (len < 3) {
999 return "!\"Invalid argument length for builtin function 'swap!'. Expects at least 2 arguments, supplied " (len - 1) "."
1000 }
1001 atom = types_heap[idx][1]
1002 if (atom !~ /^\?/) {
1003 return "!\"Incompatible type for argument 1 of builtin function 'swap!'. Expects atom, supplied " types_typename(atom) "."
1004 }
1005 f = types_heap[idx][2]
1006 if (f !~ /^[&$%]/) {
1007 return "!\"Incompatible type for argument 2 of builtin function 'swap!'. Expects function, supplied " types_typename(f) "."
1008 }
1009 lst_idx = types_allocate()
1010 atom_idx = substr(atom, 2)
1011 types_addref(types_heap[lst_idx][0] = f)
1012 types_addref(types_heap[lst_idx][1] = types_heap[atom_idx]["obj"])
1013 for (i = 3; i < len; ++i) {
1014 types_addref(types_heap[lst_idx][i - 1] = types_heap[idx][i])
1015 }
1016 types_heap[lst_idx]["len"] = len - 1
1017
1018 f_idx = substr(f, 2)
1019 switch (f) {
1020 case /^\$/:
1021 env = env_new(types_heap[f_idx]["env"], types_heap[f_idx]["params"], lst_idx)
1022 types_release("(" lst_idx)
1023 if (env ~ /^!/) {
1024 return env
1025 }
1026 ret = EVAL(types_addref(types_heap[f_idx]["body"]), env)
1027 env_release(env)
1028 break
1029 case /^%/:
1030 f_idx = types_heap[f_idx]["func"]
1031 case /^&/:
1032 ret = @f_idx(lst_idx)
1033 types_release("(" lst_idx)
1034 break
1035 }
1036
1037 if (ret ~ /^!/) {
1038 return ret
1039 }
1040 types_release(types_heap[atom_idx]["obj"])
1041 return types_addref(types_heap[atom_idx]["obj"] = ret)
1042}
1043
1044function core_init()
1045{
1046 core_ns["'="] = "&core_eq"
1047 core_ns["'throw"] = "&core_throw"
1048
1049 core_ns["'nil?"] = "&core_nilp"
1050 core_ns["'true?"] = "&core_truep"
1051 core_ns["'false?"] = "&core_falsep"
48f757da 1052 core_ns["'string?"] = "&core_stringp"
8c7587af
MK		 1053 core_ns["'symbol"] = "&core_symbol"
1054 core_ns["'symbol?"] = "&core_symbolp"
1055 core_ns["'keyword"] = "&core_keyword"
1056 core_ns["'keyword?"] = "&core_keywordp"
d90be1a9
DM		 1057 core_ns["'number?"] = "&core_numberp"
1058 core_ns["'fn?"] = "&core_fnp"
1059 core_ns["'macro?"] = "&core_macrop"
8c7587af
MK		 1060
1061 core_ns["'pr-str"] = "&core_pr_str"
1062 core_ns["'str"] = "&core_str"
1063 core_ns["'prn"] = "&core_prn"
1064 core_ns["'println"] = "&core_println"
1065 core_ns["'read-string"] = "&core_read_string"
1066 core_ns["'readline"] = "&core_readline"
1067 core_ns["'slurp"] = "&core_slurp"
1068
1069 core_ns["'<"] = "&core_lt"
1070 core_ns["'<="] = "&core_le"
1071 core_ns["'>"] = "&core_gt"
1072 core_ns["'>="] = "&core_ge"
1073 core_ns["'+"] = "&core_add"
1074 core_ns["'-"] = "&core_subtract"
1075 core_ns["'*"] = "&core_multiply"
1076 core_ns["'/"] = "&core_divide"
1077 core_ns["'time-ms"] = "&core_time_ms"
1078
1079 core_ns["'list"] = "&core_list"
1080 core_ns["'list?"] = "&core_listp"
1081 core_ns["'vector"] = "&core_vector"
1082 core_ns["'vector?"] = "&core_vectorp"
1083 core_ns["'hash-map"] = "&core_hash_map"
1084 core_ns["'map?"] = "&core_mapp"
1085 core_ns["'assoc"] = "&core_assoc"
1086 core_ns["'dissoc"] = "&core_dissoc"
1087 core_ns["'get"] = "&core_get"
1088 core_ns["'contains?"] = "&core_containsp"
1089 core_ns["'keys"] = "&core_keys"
1090 core_ns["'vals"] = "&core_vals"
1091
1092 core_ns["'sequential?"] = "&core_sequentialp"
1093 core_ns["'cons"] = "&core_cons"
1094 core_ns["'concat"] = "&core_concat"
1095 core_ns["'nth"] = "&core_nth"
1096 core_ns["'first"] = "&core_first"
1097 core_ns["'rest"] = "&core_rest"
1098 core_ns["'empty?"] = "&core_emptyp"
1099 core_ns["'count"] = "&core_count"
1100 core_ns["'apply"] = "&core_apply"
1101 core_ns["'map"] = "&core_map"
1102
1103 core_ns["'conj"] = "&core_conj"
48f757da 1104 core_ns["'seq"] = "&core_seq"
8c7587af
MK		 1105
1106 core_ns["'meta"] = "&core_meta"
1107 core_ns["'with-meta"] = "&core_with_meta"
1108 core_ns["'atom"] = "&core_atom"
1109 core_ns["'atom?"] = "&core_atomp"
1110 core_ns["'deref"] = "&core_deref"
1111 core_ns["'reset!"] = "&core_reset"
1112 core_ns["'swap!"] = "&core_swap"
1113}
1114
1115
1116
1117BEGIN {
1118 core_init()
1119}
Make a Lisp: jackhill's copy of https://github.com/kanaka/mal