miloignis/kraken
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Starting to port over & self-host!

Browse Source
This commit is contained in:
Nathan Braswell
2022-03-03 00:33:25 -05:00
parent 4a273c9ba2
commit 8cdf41826b
2 changed files with 179 additions and 54 deletions
Download Patch File Download Diff File Expand all files Collapse all files

81
partial_eval.scm
View File

@@ -59,6 +59,8 @@
((eof-object? x) '()) ((eof-object? x) '())
(#t (begin (cons x (loop (read-char input-port))))))))))) (#t (begin (cons x (loop (read-char input-port)))))))))))
(define speed_hack #t)
(let* ( (let* (
(lapply apply) (lapply apply)
(= equal?) (= equal?)
@@ -136,9 +138,10 @@
(#t (append (f (car l)) (recurse f (cdr l))))) (#t (append (f (car l)) (recurse f (cdr l)))))
)) f l))) )) f l)))
(str (if speed_hack (lambda args "") str))
(print (lambda args (print (apply str args)))) (print (lambda args (print (apply str args))))
(true_print print) (true_print print)
(print (lambda x 0)) (print (if speed_hack (lambda x 0) print))
;(true_print print) ;(true_print print)
(println print) (println print)
@@ -146,7 +149,7 @@
; Ok, actual definitions ; Ok, actual definitions
(in_array (let ((helper (rec-lambda recurse (x a i) (cond ((= i (len a)) false) (in_array (dlet ((helper (rec-lambda recurse (x a i) (cond ((= i (len a)) false)
((= x (idx a i)) true) ((= x (idx a i)) true)
(true (recurse x a (+ i 1))))))) (true (recurse x a (+ i 1)))))))
(lambda (x a) (helper x a 0)))) (lambda (x a) (helper x a 0))))
@@ -225,7 +228,7 @@
(hash_array (lambda (is_val attempted a) (foldl combine_hash (if is_val 17 (cond ((int? attempted) (combine_hash attempted 19)) (hash_array (lambda (is_val attempted a) (foldl combine_hash (if is_val 17 (cond ((int? attempted) (combine_hash attempted 19))
(attempted 61) (attempted 61)
(true 107))) (map .hash a)))) (true 107))) (map .hash a))))
(hash_env (lambda (progress_idxs dbi arrs) (combine_hash (mif dbi (hash_num dbi) 59) (let* ( (hash_env (lambda (progress_idxs dbi arrs) (combine_hash (mif dbi (hash_num dbi) 59) (dlet (
;(_ (begin (true_print "pre slice " (slice arrs 0 -2)) 0)) ;(_ (begin (true_print "pre slice " (slice arrs 0 -2)) 0))
;(_ (begin (true_print "about to do a fold " progress_idxs " and " (slice arrs 0 -2)) 0)) ;(_ (begin (true_print "about to do a fold " progress_idxs " and " (slice arrs 0 -2)) 0))
(inner_hash (foldl (dlambda (c (s v)) (combine_hash c (combine_hash (hash_symbol true s) (.hash v)))) (inner_hash (foldl (dlambda (c (s v)) (combine_hash c (combine_hash (hash_symbol true s) (.hash v))))
@@ -329,7 +332,7 @@
(indent_str (rec-lambda recurse (i) (mif (= i 0) "" (indent_str (rec-lambda recurse (i) (mif (= i 0) ""
(str " " (recurse (- i 1)))))) (str " " (recurse (- i 1))))))
(indent_str (lambda (i) "")) (indent_str (if speed_hack (lambda (i) "") indent_str))
(str_strip (lambda args (apply str (concat (slice args 0 -2) (array (idx ((rec-lambda recurse (x done_envs) (str_strip (lambda args (apply str (concat (slice args 0 -2) (array (idx ((rec-lambda recurse (x done_envs)
(cond ((= nil x) (array "<nil>" done_envs)) (cond ((= nil x) (array "<nil>" done_envs))
@@ -364,7 +367,7 @@
) )
) (idx args -1) (array)) 0)))))) ) (idx args -1) (array)) 0))))))
(true_str_strip str_strip) (true_str_strip str_strip)
;(str_strip (lambda args 0)) (str_strip (if speed_hack (lambda args 0) str_strip))
;(true_str_strip str_strip) ;(true_str_strip str_strip)
(print_strip (lambda args (println (apply str_strip args)))) (print_strip (lambda args (println (apply str_strip args))))
@@ -374,9 +377,9 @@
(true (recurse dict key (+ i 1) fail success))))) (true (recurse dict key (+ i 1) fail success)))))
(env-lookup (lambda (env key) (env-lookup-helper (.env_marked env) key 0 (lambda () (error (str key " not found in env " (str_strip env)))) (lambda (x) x)))) (env-lookup (lambda (env key) (env-lookup-helper (.env_marked env) key 0 (lambda () (error (str key " not found in env " (str_strip env)))) (lambda (x) x))))
(strip (let ((helper (rec-lambda recurse (x need_value) (strip (dlet ((helper (rec-lambda recurse (x need_value)
(cond ((val? x) (.val x)) (cond ((val? x) (.val x))
((marked_array? x) (let ((stripped_values (map (lambda (x) (recurse x need_value)) (.marked_array_values x)))) ((marked_array? x) (dlet ((stripped_values (map (lambda (x) (recurse x need_value)) (.marked_array_values x))))
(mif (.marked_array_is_val x) stripped_values (mif (.marked_array_is_val x) stripped_values
(error (str "needed value for this strip but got" x))))) (error (str "needed value for this strip but got" x)))))
((marked_symbol? x) (mif (.marked_symbol_is_val x) (.marked_symbol_value x) ((marked_symbol? x) (mif (.marked_symbol_is_val x) (.marked_symbol_value x)
@@ -388,7 +391,7 @@
((marked_env? x) (error "got env for strip, won't work")) ((marked_env? x) (error "got env for strip, won't work"))
(true (error (str "some other strip? " x))) (true (error (str "some other strip? " x)))
) )
))) (lambda (x) (let* ( ))) (lambda (x) (dlet (
;(_ (print_strip "stripping: " x)) ;(_ (print_strip "stripping: " x))
(r (helper x true)) (r (helper x true))
;(_ (println "result of strip " r)) ;(_ (println "result of strip " r))
@@ -575,9 +578,9 @@
) )
(if (or force hashes_now progress_now) (if (or force hashes_now progress_now)
(cond ((val? x) (array pectx nil x)) (cond ((val? x) (array pectx nil x))
((marked_env? x) (let ((dbi (.marked_env_idx x))) ((marked_env? x) (dlet ((dbi (.marked_env_idx x)))
; compiler calls with empty env stack ; compiler calls with empty env stack
(mif dbi (let* ( (new_env ((rec-lambda rec (i) (cond ((= i (len env_stack)) nil) (mif dbi (dlet ( (new_env ((rec-lambda rec (i) (cond ((= i (len env_stack)) nil)
((= dbi (.marked_env_idx (idx env_stack i))) (idx env_stack i)) ((= dbi (.marked_env_idx (idx env_stack i))) (idx env_stack i))
(true (rec (+ i 1))))) (true (rec (+ i 1)))))
0)) 0))
@@ -711,12 +714,12 @@
(drop_redundent_veval partial_eval_helper x env env_stack pectx indent)))) (drop_redundent_veval partial_eval_helper x env env_stack pectx indent))))
)) ))
(needs_params_val_lambda (lambda (f_sym actual_function) (let* ( (needs_params_val_lambda (lambda (f_sym actual_function) (dlet (
(handler (rec-lambda recurse (only_head de env_stack pectx params indent) (handler (rec-lambda recurse (only_head de env_stack pectx params indent)
(array pectx nil (mark false (apply actual_function (map strip params)))))) (array pectx nil (mark false (apply actual_function (map strip params))))))
) (array f_sym (marked_prim_comb handler f_sym 1 false))))) ) (array f_sym (marked_prim_comb handler f_sym 1 false)))))
(give_up_eval_params (lambda (f_sym actual_function) (let* ( (give_up_eval_params (lambda (f_sym actual_function) (dlet (
(handler (lambda (only_head de env_stack pectx params indent) (array pectx 'LATER nil))) (handler (lambda (only_head de env_stack pectx params indent) (array pectx 'LATER nil)))
) (array f_sym (marked_prim_comb handler f_sym 1 false))))) ) (array f_sym (marked_prim_comb handler f_sym 1 false)))))
@@ -803,7 +806,6 @@
(array 'cond (marked_prim_comb ((rec-lambda recurse (already_stripped) (lambda (only_head de env_stack pectx params indent) (array 'cond (marked_prim_comb ((rec-lambda recurse (already_stripped) (lambda (only_head de env_stack pectx params indent)
(mif (!= 0 (% (len params) 2)) (array pectx (str "partial eval cond with odd params " params) nil) (mif (!= 0 (% (len params) 2)) (array pectx (str "partial eval cond with odd params " params) nil)
(dlet ( (dlet (
;(_ (error "This will have to evaluate the other sides? Also, if we figure out veval re-val, maybe this can collapse back into cond"))
(eval_helper (lambda (to_eval pectx) (eval_helper (lambda (to_eval pectx)
(dlet (((ok unvald) (if already_stripped (array true to_eval) (dlet (((ok unvald) (if already_stripped (array true to_eval)
(try_unval to_eval (lambda (_) nil))))) (try_unval to_eval (lambda (_) nil)))))
@@ -950,7 +952,7 @@
; Note that the shift must be arithmatic ; Note that the shift must be arithmatic
(encode_LEB128 (rec-lambda recurse (x) (encode_LEB128 (rec-lambda recurse (x)
(let ((b (band #x7F x)) (dlet ((b (band #x7F x))
(v (>> x 7))) (v (>> x 7)))
(cond ((or (and (= v 0) (= (band b #x40) 0)) (and (= v -1) (!= (band b #x40) 0))) (array b)) (cond ((or (and (= v 0) (= (band b #x40) 0)) (and (= v -1) (!= (band b #x40) 0))) (array b))
@@ -963,7 +965,7 @@
(encode_name (lambda (name) (encode_name (lambda (name)
(encode_vector (lambda (x) (array x)) (map char->integer (string->list name))) (encode_vector (lambda (x) (array x)) (map char->integer (string->list name)))
)) ))
(hex_digit (lambda (digit) (let ((d (char->integer digit))) (hex_digit (lambda (digit) (dlet ((d (char->integer digit)))
(cond ((< d #x3A) (- d #x30)) (cond ((< d #x3A) (- d #x30))
((< d #x47) (- d #x37)) ((< d #x47) (- d #x37))
(true (- d #x57)))))) (true (- d #x57))))))
@@ -1003,7 +1005,7 @@
((= t 'externref) (array #x6F)) ((= t 'externref) (array #x6F))
(true (error (str "Bad ref type " t)))))) (true (error (str "Bad ref type " t))))))
(encode_type_section (lambda (x) (encode_type_section (lambda (x)
(let ( (dlet (
(encoded (encode_vector encode_function_type x)) (encoded (encode_vector encode_function_type x))
) (concat (array #x01) (encode_LEB128 (len encoded)) encoded )) ) (concat (array #x01) (encode_LEB128 (len encoded)) encoded ))
)) ))
@@ -1020,7 +1022,7 @@
) )
)) ))
(encode_import_section (lambda (x) (encode_import_section (lambda (x)
(let ( (dlet (
(encoded (encode_vector encode_import x)) (encoded (encode_vector encode_import x))
) (concat (array #x02) (encode_LEB128 (len encoded)) encoded )) ) (concat (array #x02) (encode_LEB128 (len encoded)) encoded ))
)) ))
@@ -1028,12 +1030,12 @@
(encode_table_type (lambda (t) (concat (encode_ref_type (idx t 0)) (encode_limits (idx t 1))))) (encode_table_type (lambda (t) (concat (encode_ref_type (idx t 0)) (encode_limits (idx t 1)))))
(encode_table_section (lambda (x) (encode_table_section (lambda (x)
(let ( (dlet (
(encoded (encode_vector encode_table_type x)) (encoded (encode_vector encode_table_type x))
) (concat (array #x04) (encode_LEB128 (len encoded)) encoded )) ) (concat (array #x04) (encode_LEB128 (len encoded)) encoded ))
)) ))
(encode_memory_section (lambda (x) (encode_memory_section (lambda (x)
(let ( (dlet (
(encoded (encode_vector encode_limits x)) (encoded (encode_vector encode_limits x))
) (concat (array #x05) (encode_LEB128 (len encoded)) encoded )) ) (concat (array #x05) (encode_LEB128 (len encoded)) encoded ))
)) ))
@@ -1050,7 +1052,7 @@
)) ))
)) ))
(encode_export_section (lambda (x) (encode_export_section (lambda (x)
(let ( (dlet (
;(_ (print "encoding element " x)) ;(_ (print "encoding element " x))
(encoded (encode_vector encode_export x)) (encoded (encode_vector encode_export x))
;(_ (print "donex")) ;(_ (print "donex"))
@@ -1059,12 +1061,12 @@
(encode_start_section (lambda (x) (encode_start_section (lambda (x)
(cond ((= 0 (len x)) (array)) (cond ((= 0 (len x)) (array))
((= 1 (len x)) (let ((encoded (encode_LEB128 (idx x 0)))) (concat (array #x08) (encode_LEB128 (len encoded)) encoded ))) ((= 1 (len x)) (dlet ((encoded (encode_LEB128 (idx x 0)))) (concat (array #x08) (encode_LEB128 (len encoded)) encoded )))
(true (error (str "bad lenbgth for start section " (len x) " was " x)))) (true (error (str "bad lenbgth for start section " (len x) " was " x))))
)) ))
(encode_function_section (lambda (x) (encode_function_section (lambda (x)
(let* ( ; nil functions are placeholders for improted functions (dlet ( ; nil functions are placeholders for improted functions
;(_ (println "encoding function section " x)) ;(_ (println "encoding function section " x))
(filtered (filter (lambda (i) (!= nil i)) x)) (filtered (filter (lambda (i) (!= nil i)) x))
;(_ (println "post filtered " filtered)) ;(_ (println "post filtered " filtered))
@@ -1077,7 +1079,7 @@
))) )))
(encode_ins (rec-lambda recurse (ins) (encode_ins (rec-lambda recurse (ins)
(let ( (dlet (
(op (idx ins 0)) (op (idx ins 0))
) (cond ((= op 'unreachable) (array #x00)) ) (cond ((= op 'unreachable) (array #x00))
((= op 'nop) (array #x01)) ((= op 'nop) (array #x01))
@@ -1194,7 +1196,7 @@
) (concat (encode_LEB128 (len code_bytes)) code_bytes)) ) (concat (encode_LEB128 (len code_bytes)) code_bytes))
)) ))
(encode_code_section (lambda (x) (encode_code_section (lambda (x)
(let ( (dlet (
(encoded (encode_vector encode_code x)) (encoded (encode_vector encode_code x))
) (concat (array #x0A) (encode_LEB128 (len encoded)) encoded )) ) (concat (array #x0A) (encode_LEB128 (len encoded)) encoded ))
)) ))
@@ -1203,7 +1205,7 @@
((= (idx t 1) 'mut) (array #x01)) ((= (idx t 1) 'mut) (array #x01))
(true (error (str "bad mutablity " (idx t 1)))))))) (true (error (str "bad mutablity " (idx t 1))))))))
(encode_global_section (lambda (global_section) (encode_global_section (lambda (global_section)
(let ( (dlet (
;(_ (print "encoding exprs " global_section)) ;(_ (print "encoding exprs " global_section))
(encoded (encode_vector (lambda (x) (concat (encode_global_type (idx x 0)) (encode_expr (idx x 1)))) global_section)) (encoded (encode_vector (lambda (x) (concat (encode_global_type (idx x 0)) (encode_expr (idx x 1)))) global_section))
) (concat (array #x06) (encode_LEB128 (len encoded)) encoded )) ) (concat (array #x06) (encode_LEB128 (len encoded)) encoded ))
@@ -1212,7 +1214,7 @@
; only supporting one type of element section for now, active funcrefs with offset ; only supporting one type of element section for now, active funcrefs with offset
(encode_element (lambda (x) (concat (array #x00) (encode_expr (idx x 0)) (encode_vector encode_LEB128 (idx x 1))))) (encode_element (lambda (x) (concat (array #x00) (encode_expr (idx x 0)) (encode_vector encode_LEB128 (idx x 1)))))
(encode_element_section (lambda (x) (encode_element_section (lambda (x)
(let ( (dlet (
;(_ (print "encoding element " x)) ;(_ (print "encoding element " x))
(encoded (encode_vector encode_element x)) (encoded (encode_vector encode_element x))
;(_ (print "donex")) ;(_ (print "donex"))
@@ -1225,7 +1227,7 @@
((= 3 (len data)) (concat (array #x02) (encode_LEB128 (idx data 0)) (encode_expr (idx data 1)) (encode_bytes (idx data 2)))) ((= 3 (len data)) (concat (array #x02) (encode_LEB128 (idx data 0)) (encode_expr (idx data 1)) (encode_bytes (idx data 2))))
(true (error (str "bad data" data)))))) (true (error (str "bad data" data))))))
(encode_data_section (lambda (x) (encode_data_section (lambda (x)
(let ( (dlet (
(encoded (encode_vector encode_data x)) (encoded (encode_vector encode_data x))
) (concat (array #x0B) (encode_LEB128 (len encoded)) encoded )) ) (concat (array #x0B) (encode_LEB128 (len encoded)) encoded ))
)) ))
@@ -1248,12 +1250,12 @@
(elem (encode_element_section element_section)) (elem (encode_element_section element_section))
(code (encode_code_section code_section)) (code (encode_code_section code_section))
(data (encode_data_section data_section)) (data (encode_data_section data_section))
;data_count (let (body (encode_LEB128 (len data_section))) (concat (array #x0C) (encode_LEB128 (len body)) body)) ;data_count (dlet (body (encode_LEB128 (len data_section))) (concat (array #x0C) (encode_LEB128 (len body)) body))
(data_count (array)) (data_count (array))
) (concat magic version type import function table memory global export data_count start elem code data)) ) (concat magic version type import function table memory global export data_count start elem code data))
)) ))
(module (lambda args (let ( (module (lambda args (dlet (
(helper (rec-lambda recurse (entries i name_dict type import function table memory global export start elem code data) (helper (rec-lambda recurse (entries i name_dict type import function table memory global export start elem code data)
(if (= i (len entries)) (array type import function table memory global export start elem code data) (if (= i (len entries)) (array type import function table memory global export start elem code data)
(dlet ( (dlet (
@@ -1428,7 +1430,7 @@
(memory.copy (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'memory.copy)))))) (memory.copy (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'memory.copy))))))
(block_like_body (lambda (name_dict name inner) (let* ( (block_like_body (lambda (name_dict name inner) (dlet (
(new_depth (+ 1 (get-value name_dict 'depth))) (new_depth (+ 1 (get-value name_dict 'depth)))
(inner_env (put (put name_dict name new_depth) 'depth new_depth)) (inner_env (put (put name_dict name new_depth) 'depth new_depth))
) (flat_map (lambda (inss) (map (lambda (ins) (ins inner_env)) inss)) inner)))) ) (flat_map (lambda (inss) (map (lambda (ins) (ins inner_env)) inss)) inner))))
@@ -1549,7 +1551,7 @@
(nil_val #b0101) (nil_val #b0101)
(true_val #b000111001) (true_val #b000111001)
(false_val #b000011001) (false_val #b000011001)
(alloc_data (dlambda (d (watermark datas)) (cond ((str? d) (let ((size (+ 8 (band (len d) -8)))) (alloc_data (dlambda (d (watermark datas)) (cond ((str? d) (dlet ((size (+ 8 (band (len d) -8))))
(array (+ watermark 8) (array (+ watermark 8)
(len d) (len d)
(array (+ watermark 8 size) (array (+ watermark 8 size)
@@ -3359,7 +3361,7 @@
(unreachable) (unreachable)
)))) ))))
(get_passthrough (dlambda (hash (datasi funcs memo env pectx)) (let ((r (get-value-or-false memo hash))) (get_passthrough (dlambda (hash (datasi funcs memo env pectx)) (dlet ((r (get-value-or-false memo hash)))
(if r (array r nil nil (array datasi funcs memo env pectx)) #f)))) (if r (array r nil nil (array datasi funcs memo env pectx)) #f))))
; This is the second run at this, and is a little interesting ; This is the second run at this, and is a little interesting
@@ -3371,7 +3373,7 @@
; ctx is (datasi funcs memo env pectx) ; ctx is (datasi funcs memo env pectx)
; return is (value? code? error? (datasi funcs memo env pectx)) ; return is (value? code? error? (datasi funcs memo env pectx))
(compile-inner (rec-lambda compile-inner (ctx c need_value) (cond (compile-inner (rec-lambda compile-inner (ctx c need_value) (cond
((val? c) (let ((v (.val c))) ((val? c) (dlet ((v (.val c)))
(cond ((int? v) (array (<< v 1) nil nil ctx)) (cond ((int? v) (array (<< v 1) nil nil ctx))
((= true v) (array true_val nil nil ctx)) ((= true v) (array true_val nil nil ctx))
((= false v) (array false_val nil nil ctx)) ((= false v) (array false_val nil nil ctx))
@@ -3416,7 +3418,7 @@
(result (mif val (call '$dup val))) (result (mif val (call '$dup val)))
) (array nil result err (array datasi funcs memo env pectx)))))) ) (array nil result err (array datasi funcs memo env pectx))))))
((marked_array? c) (if (.marked_array_is_val c) (or (get_passthrough (.hash c) ctx) ((marked_array? c) (if (.marked_array_is_val c) (or (get_passthrough (.hash c) ctx)
(let ((actual_len (len (.marked_array_values c)))) (dlet ((actual_len (len (.marked_array_values c))))
(if (= 0 actual_len) (array nil_val nil nil ctx) (if (= 0 actual_len) (array nil_val nil nil ctx)
(dlet ( ((comp_values err ctx) (foldr (dlambda (x (a err ctx)) (dlet (((v c e ctx) (compile-inner ctx x need_value))) (dlet ( ((comp_values err ctx) (foldr (dlambda (x (a err ctx)) (dlet (((v c e ctx) (compile-inner ctx x need_value)))
(array (cons v a) (or (mif err err false) (mif e e false) (mif c (str "got code " c) false)) ctx))) (array (array) nil ctx) (.marked_array_values c))) (array (cons v a) (or (mif err err false) (mif e e false) (mif c (str "got code " c) false)) ctx))) (array (array) nil ctx) (.marked_array_values c)))
@@ -4197,7 +4199,7 @@
(print "ok, hexify of 10 is " (i64_le_hexify 10)) (print "ok, hexify of 10 is " (i64_le_hexify 10))
(print "ok, hexify of 15 is " (i64_le_hexify 15)) (print "ok, hexify of 15 is " (i64_le_hexify 15))
(print "ok, hexfy of 15 << 60 is " (i64_le_hexify (<< 15 60))) (print "ok, hexfy of 15 << 60 is " (i64_le_hexify (<< 15 60)))
(let* ( (dlet (
;(output1 (wasm_to_binary (module))) ;(output1 (wasm_to_binary (module)))
;(output2 (wasm_to_binary (module ;(output2 (wasm_to_binary (module
; (import "wasi_unstable" "path_open" ; (import "wasi_unstable" "path_open"
@@ -4412,10 +4414,10 @@
(_ (write_file "./csc_out.wasm" output3)) (_ (write_file "./csc_out.wasm" output3))
) void))) ) void)))
(run-compiler (lambda () (run-compiler (lambda (f)
(let* ( (dlet (
(_ (true_print "reading in!")) (_ (true_print "reading in!"))
(read_in (read-string (slurp "to_compile.kp"))) (read_in (read-string (slurp f)))
(_ (true_print "read in, now evaluating")) (_ (true_print "read in, now evaluating"))
(evaled (partial_eval read_in)) (evaled (partial_eval read_in))
(_ (true_print "done partialy evaling, now compiling")) (_ (true_print "done partialy evaling, now compiling"))
@@ -4430,7 +4432,8 @@
(begin (begin
;(test-most) ;(test-most)
;(single-test) ;(single-test)
(run-compiler) ;(run-compiler "small_test.kp")
(run-compiler "to_compile.kp")
(profile-dump-html) (profile-dump-html)
;(profile-dump-list) ;(profile-dump-list)
) )

152
to_compile.kp
View File

@@ -136,23 +136,49 @@
reverse (lambda (x) (foldl (lambda (acc i) (cons i acc)) (array) x)) reverse (lambda (x) (foldl (lambda (acc i) (cons i acc)) (array) x))
zip (lambda (& xs) (lapply foldr (concat (array (lambda (a & ys) (cons ys a)) (array)) xs))) zip (lambda (& xs) (lapply foldr (concat (array (lambda (a & ys) (cons ys a)) (array)) xs)))
id (lambda (x) x)
dlet (vau se (inners body) (vapply let (array (lapply concat inners) body) se))
test7 ((rec-lambda recurse (n) (cond (= 0 n) 1
true (* n (recurse (- n 1))))) 5)
nil (array)
cond (vau se (& inners) (vapply cond (lapply concat inners) se))
test18 ((rec-lambda recurse (n) (cond ((= 0 n) 1)
(true (* n (recurse (- n 1)))))) 5)
;test0 (map (lambda (x) (+ x 1)) (array 1 2))
;test1 (map_i (lambda (i x) (+ x i 1)) (array 1 2))
;test2 (filter_i (lambda (i x) (> i 0)) (array 1 2))
;test2 (filter (lambda ( x) (> x 1)) (array 1 2))
;test3 (not 1)
;test4 (flat_map (lambda (x) (array 1 x 2)) (array 1 2))
;test5 (flat_map_i (lambda (i x) (array i x 2)) (array 1 2))
;test6 (let ( (a b) (array 1 2) c (+ a b) ) c)
;test8 ((lambda (a b c) (+ a b c)) 1 13 14)
;test9 ((lambda (a (b c)) (+ a b c)) 1 (array 13 14))
test0 (map (lambda (x) (+ x 1)) (array 1 2)) ;test10 (foldl + 0 (array 1 2 3 4 1337 6 4 4 4 1337 1 2 3 4 1337 6 4 4 4 1337 1 2 3 4 1337 6 4 4 4 1337 1 2 3 4 1337 6 4 4 4 13371 2 3 4 1337 6 4 4 4 1337 1 2 3 4 1337 6 4 4 4 1337 1 2 3 4 1337 6 4 4 4 1337 1 2 3 4 1337 6 4 4 4 1337))
test1 (map_i (lambda (i x) (+ x i 1)) (array 1 2)) ;test11 (foldl + 0 (array 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 13371 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337))
test2 (filter_i (lambda (i x) (> i 0)) (array 1 2)) ;test12 (foldl + 0 (array 1 2 3 4 1337 6 4 4 4 1337 1 2 3 4 1337 6 4 4 4 1337 1 2 3 4 1337 6 4 4 4 1337 1 2 3 4 1337 6 4 4 4 13371 2 3 4 1337 6 4 4 4 1337 1 2 3 4 1337 6 4 4 4 1337 1 2 3 4 1337 6 4 4 4 1337 1 2 3 4 1337 6 4 4 4 1337))
test2 (filter (lambda ( x) (> x 1)) (array 1 2)) ;test13 (foldl + 0 (array 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 13371 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337))
test3 (not 1)
test4 (flat_map (lambda (x) (array 1 x 2)) (array 1 2)) ;test10 (foldl + 0 (array 1 2 3 4 1337 6 4 4 4 1337 1 2 3 4 1337 6 4 4 4 1337 1 2 3 4 1337 6 4 4 4 1337 1 2 3 4 1337 6 4 4 4 1337))
test5 (flat_map_i (lambda (i x) (array i x 2)) (array 1 2)) ;test11 (foldl + 0 (array 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337))
test6 (let ( (a b) (array 1 2) c (+ a b) ) c)
test7 ((rec-lambda recurse (n) (cond (= 0 n) 1 ;test10 (foldl + 0 (array 1 2 3 4 1337 6 4 4 4 1337 1 2 3 4 1337 6 4 4 4 1337))
true (* n (recurse (- n 1))))) 5) ;test11 (foldl + 0 (array 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337))
test8 ((lambda (a b c) (+ a b c)) 1 13 14) ;test12 (foldl + 0 (array 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337))
test9 ((lambda (a (b c)) (+ a b c)) 1 (array 13 14)) ;test13 (foldl + 0 (array 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337))
test10 (foldl + 0 (array 1 2 3 4 1337))
;test14 (foldr + 0 (array 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337))
;test15 (reverse (array 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337))
;test16 (zip (array 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337) (array 2 3 4 5 1338 2 3 4 5 1338 2 3 4 5 1338 2 3 4 5 1338))
;monad (array 'open 3 "test_self_out" (lambda (fd code) ;monad (array 'open 3 "test_self_out" (lambda (fd code)
; (array 'write fd "wabcdefghijklmnopqrstuvwx" (lambda (written code) ; (array 'write fd "wabcdefghijklmnopqrstuvwx" (lambda (written code)
@@ -172,11 +198,107 @@
;monad (array 'write 1 "test_self_out2" (vau (written code) test10)) ;monad (array 'write 1 "test_self_out2" (vau (written code) test10))
monad (array 'write 1 "test_self_out2" (vau (written code) (foldl + 0 (array written code 1337))))
;monad (array 'write 1 "test_self_out2" (vau (written code) (foldl + 0 (array written code 1337))))
;monad (array 'write 1 "test_self_out2" (vau (written code) test14))
;monad (array 'write 1 "test_self_out2" (vau (written code) (foldr + 0 (array written code 1337))))
;monad (array 'write 1 "test_self_out2" (vau (written code) test15))
;monad (array 'write 1 "test_self_out2" (vau (written code) (reverse (array written code 1337))))
;monad (array 'write 1 "test_self_out2" (vau (written code) test16))
monad (array 'write 1 "test_self_out2" (vau (written code) (zip (array 1 2 3) (array written code 1337))))
test17 (dlet ( (a 1) (b 2) ((c d) (array 3 4)) ) (+ a b c d))
;monad (array 'write 1 "test_self_out2" (vau (written code) test17))
;monad (array 'write 1 "test_self_out2" (vau (written code) (+ test7 test18)))
;monad (array 'write 1 "test_self_out2" (vau (written code) 7)) ;monad (array 'write 1 "test_self_out2" (vau (written code) 7))
print log
println log
) )
monad ; monad
(dlet (
(in_array (dlet ((helper (rec-lambda recurse (x a i) (cond ((= i (len a)) false)
((= x (idx a i)) true)
(true (recurse x a (+ i 1)))))))
(lambda (x a) (helper x a 0))))
(val? (lambda (x) (= 'val (idx x 0))))
(marked_array? (lambda (x) (= 'marked_array (idx x 0))))
(marked_symbol? (lambda (x) (= 'marked_symbol (idx x 0))))
(comb? (lambda (x) (= 'comb (idx x 0))))
(prim_comb? (lambda (x) (= 'prim_comb (idx x 0))))
(marked_env? (lambda (x) (= 'env (idx x 0))))
(.hash (lambda (x) (idx x 1)))
(.val (lambda (x) (idx x 2)))
(.marked_array_is_val (lambda (x) (idx x 2)))
(.marked_array_is_attempted (lambda (x) (idx x 3)))
(.marked_array_needed_for_progress (lambda (x) (idx x 4)))
(.marked_array_values (lambda (x) (idx x 5)))
(.marked_symbol_needed_for_progress (lambda (x) (idx x 2)))
(.marked_symbol_is_val (lambda (x) (= nil (.marked_symbol_needed_for_progress x))))
(.marked_symbol_value (lambda (x) (idx x 3)))
(.comb (lambda (x) (slice x 2 -1)))
(.comb_id (lambda (x) (idx x 3)))
(.comb_des (lambda (x) (idx x 4)))
(.comb_env (lambda (x) (idx x 5)))
(.comb_body (lambda (x) (idx x 8)))
(.comb_wrap_level (lambda (x) (idx x 2)))
(.prim_comb_sym (lambda (x) (idx x 3)))
(.prim_comb_handler (lambda (x) (idx x 2)))
(.prim_comb_wrap_level (lambda (x) (idx x 4)))
(.prim_comb_val_head_ok (lambda (x) (idx x 5)))
(.prim_comb (lambda (x) (slice x 2 -1)))
(.marked_env (lambda (x) (slice x 2 -1)))
(.marked_env_has_vals (lambda (x) (idx x 2)))
(.marked_env_needed_for_progress (lambda (x) (idx x 3)))
(.marked_env_idx (lambda (x) (idx x 4)))
(.marked_env_upper (lambda (x) (idx (idx x 5) -1)))
(.env_marked (lambda (x) (idx x 5)))
(marked_env_real? (lambda (x) (= nil (.marked_env_needed_for_progress x))))
(.any_comb_wrap_level (lambda (x) (cond ((prim_comb? x) (.prim_comb_wrap_level x))
((comb? x) (.comb_wrap_level x))
(true (error "bad .any_comb_level")))))
; The actual needed_for_progress values are either
; #t - any eval will do something
; nil - is a value, no eval will do anything
; (3 4 1...) - list of env ids that would allow forward progress
; But these are paired with another list of hashes that if you're not inside
; of an evaluation of, then it could progress futher. These are all caused by
; the infinite recursion stopper.
(needed_for_progress (rec-lambda needed_for_progress (x) (cond ((marked_array? x) (.marked_array_needed_for_progress x))
((marked_symbol? x) (array (.marked_symbol_needed_for_progress x) nil))
((marked_env? x) (array (.marked_env_needed_for_progress x) nil))
;((comb? x) (dlet ((id (.comb_id x))
; (body_needed (idx (needed_for_progress (.comb_body x)) 0))
; (se_needed (idx (needed_for_progress (.comb_env x)) 0)))
; (if (or (= true body_needed) (= true se_needed)) (array true nil)
; (array (foldl (lambda (a xi) (if (or (= id xi) (in_array xi a)) a (cons xi a)))
; (array) (concat body_needed se_needed)) nil)
; )))
((prim_comb? x) (array nil nil))
((val? x) (array nil nil))
(true (error (str "what is this? in need for progress" x))))))
(needed_for_progress_slim (lambda (x) (idx (needed_for_progress x) 0)))
(monad (array 'write 1 "test_self_out2" (vau (written code) (dlet ((_ (print 1234))) (in_array 0 (array written code))))))
) monad)
) )
;(array 'write 1 "test_self_out2" (vau (written code) 7)) ;(array 'write 1 "test_self_out2" (vau (written code) 7))
; end of all lets ; end of all lets