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