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