From 8cdf41826bf6623aa6d772916fea6edef91c02a1 Mon Sep 17 00:00:00 2001 From: Nathan Braswell Date: Thu, 3 Mar 2022 00:33:25 -0500 Subject: [PATCH] Starting to port over & self-host! --- partial_eval.scm | 81 +++++++++++++------------ to_compile.kp | 152 ++++++++++++++++++++++++++++++++++++++++++----- 2 files changed, 179 insertions(+), 54 deletions(-) diff --git a/partial_eval.scm b/partial_eval.scm index e24717e..8c5d040 100644 --- a/partial_eval.scm +++ b/partial_eval.scm @@ -59,6 +59,8 @@ ((eof-object? x) '()) (#t (begin (cons x (loop (read-char input-port))))))))))) +(define speed_hack #t) + (let* ( (lapply apply) (= equal?) @@ -136,9 +138,10 @@ (#t (append (f (car l)) (recurse f (cdr l))))) )) f l))) + (str (if speed_hack (lambda args "") str)) (print (lambda args (print (apply str args)))) (true_print print) - (print (lambda x 0)) + (print (if speed_hack (lambda x 0) print)) ;(true_print print) (println print) @@ -146,7 +149,7 @@ ; 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) (true (recurse x a (+ i 1))))))) (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)) (attempted 61) (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 "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)))) @@ -329,7 +332,7 @@ (indent_str (rec-lambda recurse (i) (mif (= i 0) "" (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) (cond ((= nil x) (array "" done_envs)) @@ -364,7 +367,7 @@ ) ) (idx args -1) (array)) 0)))))) (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) (print_strip (lambda args (println (apply str_strip args)))) @@ -374,9 +377,9 @@ (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)))) - (strip (let ((helper (rec-lambda recurse (x need_value) + (strip (dlet ((helper (rec-lambda recurse (x need_value) (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 (error (str "needed value for this strip but got" 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")) (true (error (str "some other strip? " x))) ) - ))) (lambda (x) (let* ( + ))) (lambda (x) (dlet ( ;(_ (print_strip "stripping: " x)) (r (helper x true)) ;(_ (println "result of strip " r)) @@ -575,9 +578,9 @@ ) (if (or force hashes_now progress_now) (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 - (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)) (true (rec (+ i 1))))) 0)) @@ -711,12 +714,12 @@ (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) (array pectx nil (mark false (apply actual_function (map strip params)))))) ) (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))) ) (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) (mif (!= 0 (% (len params) 2)) (array pectx (str "partial eval cond with odd params " params) nil) (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) (dlet (((ok unvald) (if already_stripped (array true to_eval) (try_unval to_eval (lambda (_) nil))))) @@ -950,7 +952,7 @@ ; Note that the shift must be arithmatic (encode_LEB128 (rec-lambda recurse (x) - (let ((b (band #x7F x)) + (dlet ((b (band #x7F x)) (v (>> x 7))) (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_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)) ((< d #x47) (- d #x37)) (true (- d #x57)))))) @@ -1003,7 +1005,7 @@ ((= t 'externref) (array #x6F)) (true (error (str "Bad ref type " t)))))) (encode_type_section (lambda (x) - (let ( + (dlet ( (encoded (encode_vector encode_function_type x)) ) (concat (array #x01) (encode_LEB128 (len encoded)) encoded )) )) @@ -1020,7 +1022,7 @@ ) )) (encode_import_section (lambda (x) - (let ( + (dlet ( (encoded (encode_vector encode_import x)) ) (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_section (lambda (x) - (let ( + (dlet ( (encoded (encode_vector encode_table_type x)) ) (concat (array #x04) (encode_LEB128 (len encoded)) encoded )) )) (encode_memory_section (lambda (x) - (let ( + (dlet ( (encoded (encode_vector encode_limits x)) ) (concat (array #x05) (encode_LEB128 (len encoded)) encoded )) )) @@ -1050,7 +1052,7 @@ )) )) (encode_export_section (lambda (x) - (let ( + (dlet ( ;(_ (print "encoding element " x)) (encoded (encode_vector encode_export x)) ;(_ (print "donex")) @@ -1059,12 +1061,12 @@ (encode_start_section (lambda (x) (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)))) )) (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)) (filtered (filter (lambda (i) (!= nil i)) x)) ;(_ (println "post filtered " filtered)) @@ -1077,7 +1079,7 @@ ))) (encode_ins (rec-lambda recurse (ins) - (let ( + (dlet ( (op (idx ins 0)) ) (cond ((= op 'unreachable) (array #x00)) ((= op 'nop) (array #x01)) @@ -1194,7 +1196,7 @@ ) (concat (encode_LEB128 (len code_bytes)) code_bytes)) )) (encode_code_section (lambda (x) - (let ( + (dlet ( (encoded (encode_vector encode_code x)) ) (concat (array #x0A) (encode_LEB128 (len encoded)) encoded )) )) @@ -1203,7 +1205,7 @@ ((= (idx t 1) 'mut) (array #x01)) (true (error (str "bad mutablity " (idx t 1)))))))) (encode_global_section (lambda (global_section) - (let ( + (dlet ( ;(_ (print "encoding exprs " 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 )) @@ -1212,7 +1214,7 @@ ; 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_section (lambda (x) - (let ( + (dlet ( ;(_ (print "encoding element " x)) (encoded (encode_vector encode_element x)) ;(_ (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)))) (true (error (str "bad data" data)))))) (encode_data_section (lambda (x) - (let ( + (dlet ( (encoded (encode_vector encode_data x)) ) (concat (array #x0B) (encode_LEB128 (len encoded)) encoded )) )) @@ -1248,12 +1250,12 @@ (elem (encode_element_section element_section)) (code (encode_code_section code_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)) ) (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) (if (= i (len entries)) (array type import function table memory global export start elem code data) (dlet ( @@ -1428,7 +1430,7 @@ (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))) (inner_env (put (put name_dict name new_depth) 'depth new_depth)) ) (flat_map (lambda (inss) (map (lambda (ins) (ins inner_env)) inss)) inner)))) @@ -1549,7 +1551,7 @@ (nil_val #b0101) (true_val #b000111001) (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) (len d) (array (+ watermark 8 size) @@ -3359,7 +3361,7 @@ (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)))) ; This is the second run at this, and is a little interesting @@ -3371,7 +3373,7 @@ ; ctx is (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 - ((val? c) (let ((v (.val c))) + ((val? c) (dlet ((v (.val c))) (cond ((int? v) (array (<< v 1) nil nil ctx)) ((= true v) (array true_val nil nil ctx)) ((= false v) (array false_val nil nil ctx)) @@ -3416,7 +3418,7 @@ (result (mif val (call '$dup val))) ) (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) - (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) (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))) @@ -4197,7 +4199,7 @@ (print "ok, hexify of 10 is " (i64_le_hexify 10)) (print "ok, hexify of 15 is " (i64_le_hexify 15)) (print "ok, hexfy of 15 << 60 is " (i64_le_hexify (<< 15 60))) - (let* ( + (dlet ( ;(output1 (wasm_to_binary (module))) ;(output2 (wasm_to_binary (module ; (import "wasi_unstable" "path_open" @@ -4412,10 +4414,10 @@ (_ (write_file "./csc_out.wasm" output3)) ) void))) - (run-compiler (lambda () - (let* ( + (run-compiler (lambda (f) + (dlet ( (_ (true_print "reading in!")) - (read_in (read-string (slurp "to_compile.kp"))) + (read_in (read-string (slurp f))) (_ (true_print "read in, now evaluating")) (evaled (partial_eval read_in)) (_ (true_print "done partialy evaling, now compiling")) @@ -4430,7 +4432,8 @@ (begin ;(test-most) ;(single-test) - (run-compiler) + ;(run-compiler "small_test.kp") + (run-compiler "to_compile.kp") (profile-dump-html) ;(profile-dump-list) ) diff --git a/to_compile.kp b/to_compile.kp index d14986c..d1ac7e2 100644 --- a/to_compile.kp +++ b/to_compile.kp @@ -136,23 +136,49 @@ 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))) + 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)) - 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) - test7 ((rec-lambda recurse (n) (cond (= 0 n) 1 - true (* n (recurse (- n 1))))) 5) - test8 ((lambda (a b c) (+ a b c)) 1 13 14) - test9 ((lambda (a (b c)) (+ a b c)) 1 (array 13 14)) - test10 (foldl + 0 (array 1 2 3 4 1337)) + ;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)) + ;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)) + ;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)) + ;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)) + + ;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)) + ;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)) + + ;test10 (foldl + 0 (array 1 2 3 4 1337 6 4 4 4 1337 1 2 3 4 1337 6 4 4 4 1337)) + ;test11 (foldl + 0 (array 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337)) + ;test12 (foldl + 0 (array 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337)) + ;test13 (foldl + 0 (array 1 2 3 4 1337 1 2 3 4 1337 1 2 3 4 1337 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) ; (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) (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)) + + 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)) ; end of all lets