-
Notifications
You must be signed in to change notification settings - Fork 6
/
runtime-native-funcs.mal
549 lines (458 loc) · 18.4 KB
/
runtime-native-funcs.mal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
;;
;; Declare LLVM functions (implemented in header.ll)
;;
(defnativefn + mal_add [a b])
(defnativefn - mal_sub [a b])
(defnativefn * mal_mul [a b])
(defnativefn / mal_div [a b])
(defnativefn _integer_equal? mal_integer_equal_q [a b])
(defnativefn > mal_integer_gt_q [a b])
(defnativefn >= mal_integer_gte_q [a b])
(defnativefn < mal_integer_lt_q [a b])
(defnativefn <= mal_integer_lte_q [a b])
(defnativefn integer? mal_integer_q [obj])
(defnativefn nil? mal_nil_q [obj])
(defnativefn false? mal_false_q [obj])
(defnativefn true? mal_true_q [obj])
(defnativefn _make_elementarray_obj mal_make_elementarray_obj [objtype len_elements])
(defnativefn _get_type mal_get_type [obj])
(defnativefn _get_len mal_get_len [obj])
(defnativefn _set_elementarray_item mal_set_elementarray_item [obj item_index new_item])
(defnativefn _get_elementarray_item mal_get_elementarray_item [obj item_index])
(defnativefn _concat_elementarrays mal_concat_elementarrays [objtype a b])
(defnativefn _slice_elementarray mal_slice_elementarray [newobjtype obj from len])
(defnativefn _bytearray_equal? mal_bytearray_equal_q [a b])
(defnativefn _empty_bytearray_obj mal_empty_bytearray_obj [objtype len_bytes])
(defnativefn _set_bytearray_range mal_set_bytearray_range [dstobj offset len srcobj])
(defnativefn _set_bytearray_char mal_set_bytearray_char [dstobj offset ascii_value])
(defnativefn _get_bytearray_char mal_get_bytearray_char [dstobj offset])
(defnativefn _integer_to_string mal_integer_to_string [intobj])
(defnativefn _raw_obj_to_integer mal_raw_obj_to_integer [obj])
(defnativefn _printbytearray mal_printbytearray [obj])
(defnativefn native-func-apply-list mal_native_func_apply_list [fn argslist])
(defnativefn func-apply-list mal_func_apply_list [fn argslist])
(defnativefn meta mal_get_meta [obj])
(defnativefn with-meta mal_with_meta [obj new_meta])
(defnativefn time-ms mal_time_ms [])
(defnativefn os-exit mal_os_exit [exitcode])
(defnativefn gc-get-heap-size mal_gc_get_heap_size [])
(defnativefn gc-get-total-bytes mal_gc_get_total_bytes [])
(defnativefn readline mal_readline [prompt])
(defnativefn slurp mal_slurp [filename])
(defnativefn throw mal_throw [obj])
(defnativefn c-argc mal_c_argc [])
(defnativefn c-argv-str mal_c_argv_str [argindex])
;;
;; Forward declaration
;;
(defnativefn = equal_Q [a b])
(defnativefn _pr_str_one _pr_str_one [obj readable])
(defnativefn deref deref [atm])
(defnativefn contains? contains_Q [hm key])
(defnativefn get get [hm key])
(defnativefn keys keys [hm])
;;
;; Mal object constructors
;;
(defnativefn make-list make_list [len] (_make_elementarray_obj 33 len))
(defnativefn make-vector make_vector [len] (_make_elementarray_obj 34 len))
(defnativefn make-map make_map [len] (_make_elementarray_obj 35 len))
(defnativefn make-atom make_atom [] (_make_elementarray_obj 49 1))
(defnativefn make-env make_env [] (_make_elementarray_obj 65 2))
(defnativefn make-func make_func [] (_make_elementarray_obj 66 3))
(defnativefn make-native-func make_native_func [] (_make_elementarray_obj 67 3))
;;
;; Mal type predicates
;;
(defnativefn symbol? symbol_Q [obj] (_integer_equal? 17 (_get_type obj)))
(defnativefn string? string_Q [obj] (_integer_equal? 18 (_get_type obj)))
(defnativefn keyword? keyword_Q [obj] (_integer_equal? 19 (_get_type obj)))
(defnativefn number? number_Q [obj] (integer? obj))
(defnativefn list? list_Q [obj] (_integer_equal? 33 (_get_type obj)))
(defnativefn vector? vector_Q [obj] (_integer_equal? 34 (_get_type obj)))
(defnativefn map? map_Q [obj] (_integer_equal? 35 (_get_type obj)))
(defnativefn atom? atom_Q [obj] (_integer_equal? 49 (_get_type obj)))
(defnativefn function? function_Q [obj] (_integer_equal? 66 (_get_type obj)))
(defnativefn native-function? native_function_Q [obj] (_integer_equal? 67 (_get_type obj)))
(defnativefn fn? fn_Q [obj] (if (native-function? obj) true (function? obj)))
(defnativefn sequential? sequential_Q [obj]
(if (list? obj) true (vector? obj)))
(defnativefn equal_bytearray_content? equal_bytearray_content_Q [a b]
(if (_integer_equal? (_get_len a) (_get_len b))
(_bytearray_equal? a b)
false))
(defnativefn equal_elementarray_content? equal_elementarray_content_Q [len a b index]
(if (>= index len)
true
(if (= (_get_elementarray_item a index) (_get_elementarray_item b index))
(equal_elementarray_content? len a b (+ 1 index))
false)))
(defnativefn sequential_equal? _sequential_equal_Q [a b]
(if (_integer_equal? (_get_len a) (_get_len b))
(equal_elementarray_content? (_get_len a) a b 0)
false))
(defnativefn _hashmap_equal_one_val? _hashmap_equal_one_val_Q [a b key]
(if (contains? b key)
(= (get a key) (get b key))
false))
(defnativefn _hashmap_equal_vals? _hashmap_equal_vals_Q [a b keys_list len index]
(if (>= index len)
true
(if (_hashmap_equal_one_val? a b (_get_elementarray_item keys_list index))
(_hashmap_equal_vals? a b keys_list len (+ 1 index))
false)))
(defnativefn _hashmap_equal_keys? _hashmap_equal_keys_Q [a b keys_a keys_b]
(if (_integer_equal? (_get_len keys_a) (_get_len keys_b))
(_hashmap_equal_vals? a b keys_a (_get_len keys_a) 0)
false))
(defnativefn hashmap_equal? _hashmap_equal_Q [a b]
(_hashmap_equal_keys? a b (keys a) (keys b)))
(defnativefn = equal_Q [a b]
(cond
(nil? a) (nil? b)
(true? a) (true? b)
(false? a) (false? b)
(integer? a) (if (integer? b) (_integer_equal? a b) false)
(symbol? a) (if (symbol? b) (equal_bytearray_content? a b) false)
(string? a) (if (string? b) (equal_bytearray_content? a b) false)
(keyword? a) (if (keyword? b) (equal_bytearray_content? a b) false)
(atom? a) (if (atom? b) (= @a @b) false)
(sequential? a) (if (sequential? b) (sequential_equal? a b) false)
(map? a) (if (map? b) (hashmap_equal? a b) false)
:else false))
(defnativefn count count [obj]
(if (nil? obj) 0 (_get_len obj)))
(defnativefn empty? empty_Q [obj]
(= 0 (count obj)))
(defnativefn first first [seq]
(if (empty? seq)
nil
(_get_elementarray_item seq 0)))
(defnativefn last last [seq]
(if (empty? seq)
nil
(_get_elementarray_item seq (- (_get_len seq) 1))))
(defnativefn drop drop [seq nitems]
(if (> (count seq) nitems)
(_slice_elementarray 33 seq nitems (- (count seq) nitems))
(make-list 0)))
(defnativefn rest rest [seq]
(drop seq 1))
(defnativefn nth nth [seq index]
(if (>= index (count seq))
(throw "nth: index out of range")
(_get_elementarray_item seq index)))
(defnativefn cons cons [e lst]
(_concat_elementarrays 33 [e] lst))
(defnativefn concat-helper concat_helper [result lists]
(if (empty? lists)
result
(concat-helper (_concat_elementarrays 33 result (first lists)) (rest lists))))
(defnativefn hash-map-from-list hash_map_from_list [lst]
(_concat_elementarrays 35 lst []))
(defnativefn get-helper get_helper [hm key index]
(if (>= index (_get_len hm))
nil
(if (= (nth hm index) key)
(nth hm (+ 1 index))
(get-helper hm key (+ 2 index)))))
(defnativefn get get [hm key]
(if (nil? hm) nil (get-helper hm key 0)))
(defnativefn contains-helper contains_helper [hm key index]
(if (>= index (_get_len hm))
false
(if (= (nth hm index) key)
true
(contains-helper hm key (+ 2 index)))))
(defnativefn contains? contains_Q [hm key]
(contains-helper hm key 0))
(defnativefn dissoc1-helper dissoc1_helper [hm key index result]
(if (>= index (_get_len hm))
result
(if (= (nth hm index) key)
(dissoc1-helper hm key (+ 2 index) result)
(dissoc1-helper hm key (+ 2 index) (_concat_elementarrays 35 result [(nth hm index) (nth hm (+ 1 index))])))))
(defnativefn dissoc1 dissoc1 [hm key]
(if (contains? hm key)
(dissoc1-helper hm key 0 {})
hm))
(defnativefn assoc1 assoc1 [hm key val]
(_concat_elementarrays 35 (dissoc1 hm key) [key val]))
(defnativefn keys-vals-helper keys_vals_helper [hm hm_index result result_index]
(if (>= hm_index (_get_len hm))
result
(do
(_set_elementarray_item result result_index (nth hm hm_index))
(keys-vals-helper hm (+ 2 hm_index) result (+ 1 result_index)))))
(defnativefn keys keys [hm]
(keys-vals-helper hm 0 (make-list (/ (_get_len hm) 2)) 0))
(defnativefn vals vals [hm]
(keys-vals-helper hm 1 (make-list (/ (_get_len hm) 2)) 0))
;;
;; Atoms
;;
(defnativefn atom atom [val]
(_set_elementarray_item (make-atom) 0 val))
(defnativefn deref deref [atm]
(_get_elementarray_item atm 0))
(defnativefn reset! reset_BANG [atm val]
(do
(_set_elementarray_item atm 0 val)
val))
;;
;; Env
;;
(defnativefn env-bind-vars env_bind_vars [res binds exprs index]
(if (>= index (count binds))
res
(if (= '& (nth binds index))
(assoc1 res (nth binds (+ 1 index)) (drop exprs index))
(env-bind-vars (assoc1 res (nth binds index) (nth exprs index)) binds exprs (+ 1 index)))))
(defnativefn init-env init_env [outer data]
(_set_elementarray_item (_set_elementarray_item (make-env) 0 outer) 1 data))
(defnativefn new-env new_env [outer binds exprs]
(init-env outer (env-bind-vars (make-map 0) binds exprs 0)))
(defnativefn new-singlevar-env new_singlevar_env [outer varname varvalue]
(init-env outer (assoc1 (make-map 0) varname varvalue)))
(defnativefn new-root-env new_root_env []
(new-env nil [] []))
(defnativefn env-outer env_outer [env] (first env))
(defnativefn env-data env_data [env] (nth env 1))
(defnativefn env-find env_find [env k]
(if (contains? (env-data env) k)
env
(if (env-outer env)
(env-find (env-outer env) k)
nil)))
(defnativefn env-get-helper env_get_helper [found-env k]
(if found-env
(get (env-data found-env) k)
(throw [k "not found"])))
(defnativefn env-get env_get [env k]
(env-get-helper (env-find env k) k))
(defnativefn env-set env_set [env k v]
(do
(_set_elementarray_item env 1 (assoc1 (env-data env) k v))
v))
;;
;; apply and map
(defnativefn apply-helper apply_helper [fn argslist]
(if (native-function? fn)
(native-func-apply-list fn argslist)
(func-apply-list fn argslist)))
(defnativefn map-helper map_helper [result index fn seq]
(if (>= index (count seq))
result
(do
(_set_elementarray_item result index (apply-helper fn [(nth seq index)]))
(map-helper result (+ 1 index) fn seq))))
(defnativefn map map [fn seq]
(map-helper (make-list (count seq)) 0 fn seq))
;;
;; Function
;;
(defnativefn fn-args-names fn_args_names [fn]
(_get_elementarray_item fn 0))
(defnativefn fn-env fn_env [fn]
(_get_elementarray_item fn 1))
(defnativefn fn-func-ptr fn_func_ptr [fn]
(_get_elementarray_item fn 2))
(defnativefn nativefn-name nativefn_name [fn]
(_get_elementarray_item fn 1))
;;
;; Keyword and symbol
;;
(defnativefn keyword keyword [s]
(_set_bytearray_char
(_set_bytearray_range
(_empty_bytearray_obj 19 (+ 1 (_get_len s)))
1 (_get_len s) s)
0 58)) ; = colon char
(defnativefn symbol symbol [s]
(_set_bytearray_range (_empty_bytearray_obj 17 (_get_len s)) 0 (_get_len s) s))
;;
;; conj
;;
(defnativefn conj-list conj_list [lst args]
(if (empty? args)
lst
(conj-list (cons (first args) lst) (rest args))))
(defnativefn conj-vector conj_vector [vec args]
(_concat_elementarrays 34 vec args))
;;
;; Seq
;;
(defnativefn _vector_to_list _vector_to_list [vec]
(_concat_elementarrays 33 vec []))
(defnativefn _extract_one_char _extract_one_char [s index]
(_set_bytearray_char (_empty_bytearray_obj 18 1) 0 (_get_bytearray_char s index)))
(defnativefn _seq_string_helper _seq_string_helper [s res index len]
(if (>= index len)
res
(do
(_set_elementarray_item res index (_extract_one_char s index))
(_seq_string_helper s res (+ 1 index) len))))
(defnativefn _seq_string _seq_string [s]
(_seq_string_helper s (make-list (_get_len s)) 0 (_get_len s)))
(defnativefn seq seq [obj]
(cond
(nil? obj) nil
(list? obj) (if (empty? obj) nil obj)
(vector? obj) (if (empty? obj) nil (_vector_to_list obj))
(string? obj) (if (= 0 (_get_len obj)) nil (_seq_string obj))
:else (throw "illegal type for seq")))
;;
;; pr_str / str
;;
(defnativefn _concat_strings_helper _concat_strings_helper [seq index buffer offset]
(if (>= index (count seq))
buffer
(do
(_set_bytearray_range buffer offset (_get_len (nth seq index)) (nth seq index))
(_concat_strings_helper seq (+ 1 index) buffer (+ offset (_get_len (nth seq index)))))))
(defnativefn _concat_strings_calc_result_size _concat_strings_calc_result_size [seq index size]
(if (>= index (count seq))
size
(_concat_strings_calc_result_size seq (+ 1 index) (+ size (_get_len (nth seq index))))))
(defnativefn _concat_strings _concat_strings [seq]
(_concat_strings_helper seq 0 (_empty_bytearray_obj 18 (_concat_strings_calc_result_size seq 0 0)) 0))
(defnativefn _join_strings_helper _join_strings_helper [delim seq index result]
(if (>= index (count seq))
result
(do
(if (> index 0)
(_set_elementarray_item result (- (* 2 index) 1) delim))
(_set_elementarray_item result (* 2 index) (nth seq index))
(_join_strings_helper delim seq (+ 1 index) result))))
(defnativefn _join_strings _join_strings [delim seq]
(if (empty? seq)
""
(_concat_strings
(_join_strings_helper delim seq 0 (make-list (- (* 2 (count seq)) 1))))))
(defnativefn _symbol_to_string _symbol_to_string [sym]
(_set_bytearray_range (_empty_bytearray_obj 18 (_get_len sym)) 0 (_get_len sym) sym))
(defnativefn _keyword_to_string keyword_to_string [keyw]
(_set_bytearray_range (_empty_bytearray_obj 18 (_get_len keyw)) 0 (_get_len keyw) keyw))
(defnativefn _is_special_char _is_special_char [ascii_value]
(cond
(= 10 ascii_value) true ; newline
(= 34 ascii_value) true ; quote
(= 92 ascii_value) true ; backslash
:else false))
(defnativefn _count_special_chars _count_special_chars [s index result]
(if (>= index (_get_len s))
result
(if (_is_special_char (_get_bytearray_char s index))
(_count_special_chars s (+ 1 index) (+ 1 result))
(_count_special_chars s (+ 1 index) result))))
(defnativefn _size_of_readable_string _size_of_readable_string [s]
(+ 2 (+ (_get_len s) (_count_special_chars s 0 0))))
(defnativefn _escape_char _escape_char [char dst dstindex]
(cond
(= 10 char)
(do
(_set_bytearray_char dst dstindex 92) ; backslash
(_set_bytearray_char dst (+ 1 dstindex) 110) ; n
(+ 2 dstindex))
(= 34 char)
(do
(_set_bytearray_char dst dstindex 92) ; backslash
(_set_bytearray_char dst (+ 1 dstindex) 34) ; quote
(+ 2 dstindex))
(= 92 char)
(do
(_set_bytearray_char dst dstindex 92) ; backslash
(_set_bytearray_char dst (+ 1 dstindex) 92) ; backslash
(+ 2 dstindex))
:else
(do
(_set_bytearray_char dst dstindex char)
(+ 1 dstindex))))
(defnativefn _escape_string_helper _escape_string_helper [src srcindex dst dstindex]
(if (>= srcindex (_get_len src))
dst
(_escape_string_helper
src (+ 1 srcindex)
dst (_escape_char (_get_bytearray_char src srcindex) dst dstindex))))
(defnativefn _put_surrounding_quotes _add_surrounding_quotes [s]
(do
(_set_bytearray_char s 0 34)
(_set_bytearray_char s (- (_get_len s) 1) 34)
s))
(defnativefn _escape_string _escape_string [s]
(_put_surrounding_quotes
(_escape_string_helper s 0 (_empty_bytearray_obj 18 (_size_of_readable_string s)) 1)))
(defnativefn _map_seq_pr_str _map_seq_pr_str [result index seq readable]
(if (>= index (count seq))
result
(do
(_set_elementarray_item result index (_pr_str_one (nth seq index) readable))
(_map_seq_pr_str result (+ 1 index) seq readable))))
(defnativefn _pr_str_sequence _pr_str_sequence [readable start delim end seq]
(_concat_strings [start
(_join_strings delim (_map_seq_pr_str (make-list (count seq)) 0 seq readable))
end]))
(defnativefn _pr_str_one _pr_str_one [obj readable]
(cond
(nil? obj) "nil"
(false? obj) "false"
(true? obj) "true"
(integer? obj) (_integer_to_string obj)
(symbol? obj) (_symbol_to_string obj)
(keyword? obj) (_keyword_to_string obj)
(string? obj) (if readable (_escape_string obj) obj)
(list? obj) (_pr_str_sequence readable "(" " " ")" obj)
(vector? obj) (_pr_str_sequence readable "[" " " "]" obj)
(map? obj) (_pr_str_sequence readable "{" " " "}" obj)
(atom? obj) (_concat_strings ["(atom " (_pr_str_one (deref obj) true) ")"])
(function? obj)
(_concat_strings ["#<function args="
(_pr_str_one (fn-args-names obj) readable)
">"])
(native-function? obj)
(_concat_strings ["#<native-function "
(nativefn-name obj)
" args="
(_pr_str_one (fn-args-names obj) readable)
">"])
:else
(_concat_strings ["#<DONT-KNOW-HOW-TO-PRINT:raw="
(_integer_to_string (_raw_obj_to_integer obj))
">"])))
;;
;; *ARGV*
;;
(defnativefn prepare_argv_list prepare_argv_list [index argc result]
(if (>= index argc)
result
(do
(_set_elementarray_item result (- index 1) (c-argv-str index))
(prepare_argv_list (+ 1 index) argc result))))
(defnativefn mal_init_globals mal_init_globals [env]
(do
(env-set env '*host-language* "malc")
(env-set env '*ARGV0* (c-argv-str 0))
(env-set env '*ARGV* (prepare_argv_list 1 (c-argc) (make-list (- (c-argc) 1))))))
;;
;; Public (exported) native functions
;;
(exportnativefn =
throw
nil? true? false? string?
symbol symbol? keyword keyword? number? fn?
readline slurp
< <= > >= + - * /
list? vector? map? get contains? keys vals
sequential? cons nth first rest empty? count map
seq
meta with-meta atom atom? deref reset!
time-ms os-exit gc-get-heap-size gc-get-total-bytes
; TODO - the following functions are used by
; runtime-core-funcs.mal but should not be exposed to user code
apply-helper concat-helper
assoc1 dissoc1
hash-map-from-list
conj-list conj-vector
drop last
_printbytearray _pr_str_sequence
_concat_elementarrays _slice_elementarray)