Commit | Line | Data |
---|---|---|
33a37291 DM |
1 | #ifndef __core__ |
2 | #define __core__ | |
3 | ||
4 | #include "types.rexx" | |
5 | ||
6 | mal_equal?: procedure expose values. /* mal_equal?(a, b) */ | |
7 | return new_boolean(equal?(arg(1), arg(2))) | |
8 | ||
9 | mal_throw: procedure expose values. err /* mal_throw(a) */ | |
10 | err = "__MAL_EXCEPTION__" arg(1) | |
11 | return "ERR" | |
12 | ||
13 | mal_nil?: procedure expose values. /* mal_nil?(a) */ | |
14 | return new_boolean(nil?(arg(1))) | |
15 | ||
16 | mal_true?: procedure expose values. /* mal_true?(a) */ | |
17 | return new_boolean(true?(arg(1))) | |
18 | ||
19 | mal_false?: procedure expose values. /* mal_false?(a) */ | |
20 | return new_boolean(false?(arg(1))) | |
21 | ||
22 | mal_string?: procedure expose values. /* mal_string?(a) */ | |
23 | return new_boolean(string?(arg(1))) | |
24 | ||
25 | mal_symbol: procedure expose values. /* mal_symbol(a) */ | |
26 | return new_symbol(obj_val(arg(1))) | |
27 | ||
28 | mal_symbol?: procedure expose values. /* mal_symbol?(a) */ | |
29 | return new_boolean(symbol?(arg(1))) | |
30 | ||
31 | mal_keyword: procedure expose values. /* mal_keyword(a) */ | |
32 | return new_keyword(obj_val(arg(1))) | |
33 | ||
34 | mal_keyword?: procedure expose values. /* mal_keyword?(a) */ | |
35 | return new_boolean(keyword?(arg(1))) | |
36 | ||
7cecb87a DM |
37 | mal_number?: procedure expose values. /* mal_number?(a) */ |
38 | return new_boolean(number?(arg(1))) | |
39 | ||
40 | mal_fn?: procedure expose values. /* mal_fn?(a) */ | |
41 | return new_boolean(nativefn?(arg(1)) | (func?(arg(1)) & (func_is_macro(arg(1)) \= 1))) | |
42 | ||
43 | mal_macro?: procedure expose values. /* mal_macro?(a) */ | |
44 | return new_boolean(func_macro?(arg(1))) | |
45 | ||
33a37291 DM |
46 | mal_pr_str: procedure expose values. /* mal_pr_str(...) */ |
47 | res = "" | |
48 | do i=1 to arg() | |
49 | element = pr_str(arg(i), 1) | |
50 | if i == 1 then | |
51 | res = element | |
52 | else | |
53 | res = res || " " || element | |
54 | end | |
55 | return new_string(res) | |
56 | ||
57 | mal_str: procedure expose values. /* mal_str(...) */ | |
58 | res = "" | |
59 | do i=1 to arg() | |
60 | element = pr_str(arg(i), 0) | |
61 | if i == 1 then | |
62 | res = element | |
63 | else | |
64 | res = res || element | |
65 | end | |
66 | return new_string(res) | |
67 | ||
68 | mal_prn: procedure expose values. /* mal_prn(...) */ | |
69 | res = "" | |
70 | do i=1 to arg() | |
71 | element = pr_str(arg(i), 1) | |
72 | if i == 1 then | |
73 | res = element | |
74 | else | |
75 | res = res || " " || element | |
76 | end | |
77 | say res | |
78 | return new_nil() | |
79 | ||
80 | mal_println: procedure expose values. /* mal_println(...) */ | |
81 | res = "" | |
82 | do i=1 to arg() | |
83 | element = pr_str(arg(i), 0) | |
84 | if i == 1 then | |
85 | res = element | |
86 | else | |
87 | res = res || " " || element | |
88 | end | |
89 | say res | |
90 | return new_nil() | |
91 | ||
92 | mal_read_string: procedure expose values. /* mal_read_string(str) */ | |
93 | return read_str(obj_val(arg(1))) | |
94 | ||
95 | mal_readline: procedure expose values. /* mal_readline(prompt) */ | |
96 | line = readline(obj_val(arg(1))) | |
97 | if length(line) > 0 then return new_string(line) | |
98 | if lines() > 0 then return new_string("") | |
99 | return new_nil() | |
100 | ||
101 | mal_slurp: procedure expose values. /* mal_read_string(filename) */ | |
102 | file_content = charin(obj_val(arg(1)), , 100000) | |
103 | return new_string(file_content) | |
104 | ||
105 | mal_lt: procedure expose values. /* mal_lt(a, b) */ | |
106 | return new_boolean(obj_val(arg(1)) < obj_val(arg(2))) | |
107 | ||
108 | mal_lte: procedure expose values. /* mal_lte(a, b) */ | |
109 | return new_boolean(obj_val(arg(1)) <= obj_val(arg(2))) | |
110 | ||
111 | mal_gt: procedure expose values. /* mal_gt(a, b) */ | |
112 | return new_boolean(obj_val(arg(1)) > obj_val(arg(2))) | |
113 | ||
114 | mal_gte: procedure expose values. /* mal_gte(a, b) */ | |
115 | return new_boolean(obj_val(arg(1)) >= obj_val(arg(2))) | |
116 | ||
117 | mal_add: procedure expose values. /* mal_add(a, b) */ | |
118 | return new_number(obj_val(arg(1)) + obj_val(arg(2))) | |
119 | ||
120 | mal_sub: procedure expose values. /* mal_sub(a, b) */ | |
121 | return new_number(obj_val(arg(1)) - obj_val(arg(2))) | |
122 | ||
123 | mal_mul: procedure expose values. /* mal_mul(a, b) */ | |
124 | return new_number(obj_val(arg(1)) * obj_val(arg(2))) | |
125 | ||
126 | mal_div: procedure expose values. /* mal_div(a, b) */ | |
127 | return new_number(obj_val(arg(1)) / obj_val(arg(2))) | |
128 | ||
129 | mal_time_ms: procedure expose values. /* mal_time_ms() */ | |
130 | return new_number(trunc(time('E') * 1000)) | |
131 | ||
132 | mal_list: procedure expose values. /* mal_list(...) */ | |
133 | res = "" | |
134 | do i=1 to arg() | |
135 | if i == 1 then | |
136 | res = arg(i) | |
137 | else | |
138 | res = res || " " || arg(i) | |
139 | end | |
140 | return new_list(res) | |
141 | ||
142 | mal_list?: procedure expose values. /* mal_list?(a) */ | |
143 | return new_boolean(list?(arg(1))) | |
144 | ||
145 | mal_vector: procedure expose values. /* mal_vector(...) */ | |
146 | res = "" | |
147 | do i=1 to arg() | |
148 | if i == 1 then | |
149 | res = arg(i) | |
150 | else | |
151 | res = res || " " || arg(i) | |
152 | end | |
153 | return new_vector(res) | |
154 | ||
155 | mal_vector?: procedure expose values. /* mal_vector?(a) */ | |
156 | return new_boolean(vector?(arg(1))) | |
157 | ||
158 | mal_hash_map: procedure expose values. /* mal_hash_map(...) */ | |
159 | res = "" | |
160 | do i=1 to arg() | |
161 | if i == 1 then | |
162 | res = arg(i) | |
163 | else | |
164 | res = res || " " || arg(i) | |
165 | end | |
166 | return new_hashmap(res) | |
167 | ||
168 | mal_map?: procedure expose values. /* mal_map?(a) */ | |
169 | return new_boolean(hashmap?(arg(1))) | |
170 | ||
171 | mal_assoc: procedure expose values. /* mal_assoc(a, ...) */ | |
172 | hm = arg(1) | |
173 | res = "" | |
174 | do i=2 to arg() by 2 | |
175 | key_val = arg(i) || " " || arg(i + 1) | |
176 | if res == 2 then | |
177 | res = key_val | |
178 | else | |
179 | res = res || " " || key_val | |
180 | end | |
181 | hm_val = obj_val(hm) | |
182 | do i=1 to words(hm_val) by 2 | |
183 | if \contains?(res, word(hm_val, i)) then | |
184 | res = res || " " || word(hm_val, i) || " " || word(hm_val, i + 1) | |
185 | end | |
186 | return new_hashmap(res) | |
187 | ||
188 | mal_dissoc: procedure expose values. /* mal_dissoc(a, ...) */ | |
189 | hm = arg(1) | |
190 | res = "" | |
191 | hm_val = obj_val(hm) | |
192 | do i=1 to words(hm_val) by 2 | |
193 | key = word(hm_val, i) | |
194 | found = 0 | |
195 | do j=2 to arg() | |
196 | if equal?(key, arg(j)) then do | |
197 | found = 1 | |
198 | leave | |
199 | end | |
200 | end | |
201 | if \found then do | |
202 | if length(res) > 0 then res = res || " " | |
203 | res = res || key || " " || word(hm_val, i + 1) | |
204 | end | |
205 | end | |
206 | return new_hashmap(res) | |
207 | ||
208 | mal_get: procedure expose values. /* mal_get(a, b) */ | |
209 | res = hashmap_get(obj_val(arg(1)), arg(2)) | |
210 | if res == "" then | |
211 | return new_nil() | |
212 | else | |
213 | return res | |
214 | ||
215 | mal_contains?: procedure expose values. /* mal_contains?(a, b) */ | |
216 | return new_boolean(contains?(obj_val(arg(1)), arg(2))) | |
217 | ||
218 | mal_keys: procedure expose values. /* mal_keys(a) */ | |
219 | hm_val = obj_val(arg(1)) | |
220 | seq = "" | |
221 | do i=1 to words(hm_val) by 2 | |
222 | if i == 1 then | |
223 | seq = word(hm_val, i) | |
224 | else | |
225 | seq = seq || " " || word(hm_val, i) | |
226 | end | |
227 | return new_list(seq) | |
228 | ||
229 | mal_vals: procedure expose values. /* mal_vals(a) */ | |
230 | hm_val = obj_val(arg(1)) | |
231 | seq = "" | |
232 | do i=2 to words(hm_val) by 2 | |
233 | if i == 1 then | |
234 | seq = word(hm_val, i) | |
235 | else | |
236 | seq = seq || " " || word(hm_val, i) | |
237 | end | |
238 | return new_list(seq) | |
239 | ||
240 | mal_sequential?: procedure expose values. /* mal_sequential?(a) */ | |
241 | return new_boolean(sequential?(arg(1))) | |
242 | ||
243 | mal_cons: procedure expose values. /* mal_cons(a, b) */ | |
244 | return new_list(arg(1) || " " || obj_val(arg(2))) | |
245 | ||
246 | mal_concat: procedure expose values. /* mal_concat(...) */ | |
247 | seq = "" | |
248 | do i=1 to arg() | |
249 | if i == 1 then | |
250 | seq = obj_val(arg(i)) | |
251 | else | |
252 | seq = seq || " " || obj_val(arg(i)) | |
253 | end | |
254 | return new_list(seq) | |
255 | ||
256 | mal_nth: procedure expose values. err /* mal_nth(list, index) */ | |
257 | list_val = obj_val(arg(1)) | |
258 | i = obj_val(arg(2)) | |
259 | if i >= words(list_val) then do | |
260 | err = "nth: index out of range" | |
261 | return "ERR" | |
262 | end | |
263 | return word(list_val, i + 1) | |
264 | ||
265 | mal_first: procedure expose values. /* mal_first(a) */ | |
266 | if nil?(arg(1)) then return new_nil() | |
267 | list_val = obj_val(arg(1)) | |
268 | if words(list_val) == 0 then return new_nil() | |
269 | return word(list_val, 1) | |
270 | ||
271 | mal_rest: procedure expose values. /* mal_rest(a) */ | |
272 | return new_list(subword(obj_val(arg(1)), 2)) | |
273 | ||
274 | mal_empty?: procedure expose values. /* mal_empty?(a) */ | |
275 | if nil?(arg(1)) then return new_true() | |
276 | return new_boolean(count_elements(arg(1)) == 0) | |
277 | ||
278 | mal_count: procedure expose values. /* mal_count(a) */ | |
279 | if nil?(arg(1)) then return new_number(0) | |
280 | return new_number(count_elements(arg(1))) | |
281 | ||
282 | apply_function: procedure expose values. env. err /* apply_function(fn, lst) */ | |
283 | f = arg(1) | |
284 | call_args = arg(2) | |
285 | select | |
286 | when nativefn?(f) then do | |
287 | call_args_val = obj_val(call_args) | |
288 | call_list = "" | |
289 | do i=1 to words(call_args_val) | |
290 | element = '"' || word(call_args_val, i) || '"' | |
291 | if i > 1 then | |
292 | call_list = call_list || ', ' || element | |
293 | else | |
294 | call_list = element | |
295 | end | |
296 | res = "" | |
297 | interpret "res = " || obj_val(f) || "(" || call_list || ")" | |
298 | return res | |
299 | end | |
300 | when func?(f) then do | |
301 | apply_env_idx = new_env(func_env_idx(f), func_binds(f), call_args) | |
302 | return eval(func_body_ast(f), apply_env_idx) | |
303 | end | |
304 | otherwise | |
305 | err = "Unsupported function object type: " || obj_type(f) | |
306 | return "ERR" | |
307 | end | |
308 | ||
309 | mal_apply: procedure expose values. env. err /* mal_apply(fn, ..., lst) */ | |
310 | fn = arg(1) | |
311 | seq = "" | |
312 | do i=2 to (arg() - 1) | |
313 | if i == 2 then | |
314 | seq = arg(i) | |
315 | else | |
316 | seq = seq || " " || arg(i) | |
317 | end | |
318 | if arg() > 1 then do | |
319 | seq = seq || " " || obj_val(arg(arg())) | |
320 | end | |
321 | return apply_function(fn, new_list(seq)) | |
322 | ||
323 | mal_map: procedure expose values. env. err /* mal_map(f, lst) */ | |
324 | fn = arg(1) | |
325 | lst_val = obj_val(arg(2)) | |
326 | res = "" | |
327 | do i=1 to words(lst_val) | |
328 | element = word(lst_val, i) | |
329 | mapped_element = apply_function(fn, new_list(element)) | |
330 | if mapped_element == "ERR" then return "ERR" | |
331 | if i == 1 then | |
332 | res = mapped_element | |
333 | else | |
334 | res = res || " " || mapped_element | |
335 | end | |
336 | return new_list(res) | |
337 | ||
338 | mal_conj: procedure expose values. env. err /* mal_conj(a, ...) */ | |
339 | a = arg(1) | |
340 | select | |
341 | when list?(a) then do | |
342 | do i=2 to arg() | |
343 | a = mal_cons(arg(i), a) | |
344 | end | |
345 | return a | |
346 | end | |
347 | when vector?(a) then do | |
348 | seq = obj_val(a) | |
349 | do i=2 to arg() | |
350 | if length(seq) > 0 then seq = seq || " " | |
351 | seq = seq || arg(i) | |
352 | end | |
353 | return new_vector(seq) | |
354 | end | |
355 | otherwise | |
356 | err = "conj requires list or vector" | |
357 | return "ERR" | |
358 | end | |
359 | ||
360 | mal_seq: procedure expose values. env. err /* mal_conj(a) */ | |
361 | a = arg(1) | |
362 | select | |
363 | when string?(a) then do | |
364 | str = obj_val(a) | |
365 | if length(str) == 0 then return new_nil() | |
366 | seq = "" | |
367 | do i=1 to length(str) | |
368 | element = new_string(substr(str, i, 1)) | |
369 | if i == 1 then | |
370 | seq = element | |
371 | else | |
372 | seq = seq || " " || element | |
373 | end | |
374 | return new_list(seq) | |
375 | end | |
376 | when list?(a) then do | |
377 | if count_elements(a) == 0 then return new_nil() | |
378 | return a | |
379 | end | |
380 | when vector?(a) then do | |
381 | if count_elements(a) == 0 then return new_nil() | |
382 | return new_list(obj_val(a)) | |
383 | end | |
384 | when nil?(a) then return new_nil() | |
385 | otherwise | |
386 | err = "seq requires string or list or vector or nil" | |
387 | return "ERR" | |
388 | end | |
389 | ||
390 | mal_with_meta: procedure expose values. /* mal_with_meta(a, b) */ | |
391 | new_obj = obj_clone_and_set_meta(arg(1), arg(2)) | |
392 | if new_obj == "" then return arg(1) | |
393 | return new_obj | |
394 | ||
395 | mal_meta: procedure expose values. /* mal_meta(a) */ | |
396 | meta = obj_meta(arg(1)) | |
397 | if meta == "" then return new_nil() | |
398 | return meta | |
399 | ||
400 | mal_atom: procedure expose values. /* mal_atom(a) */ | |
401 | return new_atom(arg(1)) | |
402 | ||
403 | mal_atom?: procedure expose values. /* mal_atom?(a) */ | |
404 | return new_boolean(atom?(arg(1))) | |
405 | ||
406 | mal_deref: procedure expose values. /* mal_deref(a) */ | |
407 | return obj_val(arg(1)) | |
408 | ||
409 | mal_reset!: procedure expose values. /* mal_reset!(a, new_val) */ | |
410 | return atom_set(arg(1), arg(2)) | |
411 | ||
412 | mal_swap!: procedure expose values. env. err /* mal_swap!(a, fn, ...) */ | |
413 | atom = arg(1) | |
414 | fn = arg(2) | |
415 | atom_val = obj_val(atom) | |
416 | seq = atom_val | |
417 | do i=3 to arg() | |
418 | seq = seq || " " || arg(i) | |
419 | end | |
420 | new_val = apply_function(fn, new_list(seq)) | |
421 | if new_val == "ERR" then return "ERR" | |
422 | return atom_set(atom, new_val) | |
423 | ||
424 | mal_rexx_eval: procedure expose values. /* mal_rexx_eval(..., a) */ | |
425 | do i=1 to (arg() - 1) | |
426 | interpret obj_val(arg(i)) | |
427 | end | |
428 | last_arg = arg(arg()) | |
429 | if nil?(last_arg) then return new_nil() | |
430 | last_arg_str = obj_val(last_arg) | |
431 | if length(last_arg_str) == 0 then return new_nil() | |
432 | rexx_eval_res = "" | |
433 | interpret "rexx_eval_res = " || last_arg_str | |
434 | if datatype(rexx_eval_res) == "NUM" then | |
435 | return new_number(rexx_eval_res) | |
436 | else | |
437 | return new_string(rexx_eval_res) | |
438 | ||
439 | get_core_ns: procedure /* get_core_ns() */ | |
440 | return "= mal_equal?" , | |
441 | "throw mal_throw" , | |
442 | , | |
443 | "nil? mal_nil?" , | |
444 | "true? mal_true?" , | |
445 | "false? mal_false?" , | |
446 | "string? mal_string?" , | |
447 | "symbol mal_symbol" , | |
448 | "symbol? mal_symbol?" , | |
449 | "keyword mal_keyword" , | |
450 | "keyword? mal_keyword?" , | |
7cecb87a DM |
451 | "number? mal_number?" , |
452 | "fn? mal_fn?" , | |
453 | "macro? mal_macro?" , | |
33a37291 DM |
454 | , |
455 | "pr-str mal_pr_str" , | |
456 | "str mal_str" , | |
457 | "prn mal_prn" , | |
458 | "println mal_println" , | |
459 | "read-string mal_read_string" , | |
460 | "readline mal_readline" , | |
461 | "slurp mal_slurp" , | |
462 | , | |
463 | "< mal_lt" , | |
464 | "<= mal_lte" , | |
465 | "> mal_gt" , | |
466 | ">= mal_gte" , | |
467 | "+ mal_add" , | |
468 | "- mal_sub" , | |
469 | "* mal_mul" , | |
470 | "/ mal_div" , | |
471 | "time-ms mal_time_ms" , | |
472 | , | |
473 | "list mal_list" , | |
474 | "list? mal_list?" , | |
475 | "vector mal_vector" , | |
476 | "vector? mal_vector?" , | |
477 | "hash-map mal_hash_map" , | |
478 | "map? mal_map?" , | |
479 | "assoc mal_assoc" , | |
480 | "dissoc mal_dissoc" , | |
481 | "get mal_get" , | |
482 | "contains? mal_contains?" , | |
483 | "keys mal_keys" , | |
484 | "vals mal_vals" , | |
485 | , | |
486 | "sequential? mal_sequential?" , | |
487 | "cons mal_cons" , | |
488 | "concat mal_concat" , | |
489 | "nth mal_nth" , | |
490 | "first mal_first" , | |
491 | "rest mal_rest" , | |
492 | "empty? mal_empty?" , | |
493 | "count mal_count" , | |
494 | "apply mal_apply" , | |
495 | "map mal_map" , | |
496 | , | |
497 | "conj mal_conj" , | |
498 | "seq mal_seq" , | |
499 | , | |
500 | "meta mal_meta" , | |
501 | "with-meta mal_with_meta" , | |
502 | "atom mal_atom" , | |
503 | "atom? mal_atom?" , | |
504 | "deref mal_deref" , | |
505 | "reset! mal_reset!" , | |
506 | "swap! mal_swap!" , | |
507 | , | |
508 | "rexx-eval mal_rexx_eval" | |
509 | ||
510 | #endif |