2022-01-05 01:05:16 -05:00
((wrap (vau root_env (quote)
((wrap (vau (let1)
(let1 lambda (vau se (p b1) (wrap (eval (array vau p b1) se)))
2022-01-28 00:26:46 -05:00
(let1 current-env (vau de () de)
2022-01-05 01:05:16 -05:00
(let1 cons (lambda (h t) (concat (array h) t))
2022-01-28 00:26:46 -05:00
(let1 Y (lambda (f3)
((lambda (x1) (x1 x1))
2022-04-17 01:52:01 -04:00
(lambda (x2) (f3 (wrap (vau app_env (& y) (lapply (x2 x2) y app_env)))))))
2022-01-26 01:55:38 -05:00
(let1 vY (lambda (f)
((lambda (x3) (x3 x3))
2022-02-03 02:41:14 -05:00
(lambda (x4) (f (vau de1 (& y) (vapply (x4 x4) y de1))))))
(let1 let (vY (lambda (recurse) (vau de2 (vs b) (cond (= (len vs) 0) (eval b de2)
true (vapply let1 (array (idx vs 0) (idx vs 1) (array recurse (slice vs 2 -1) b)) de2)))))
2022-02-07 00:31:51 -05:00
(let (
2022-02-19 00:14:36 -05:00
lcompose (lambda (g f) (lambda (& args) (lapply g (array (lapply f args)))))
2022-02-07 00:31:51 -05:00
rec-lambda (vau se (n p b) (eval (array Y (array lambda (array n) (array lambda p b))) se))
2022-03-13 15:11:30 -04:00
;if (vau de (con than & else) (cond (eval con de) (eval than de)
; (> (len else) 0) (eval (idx else 0) de)
; true false))
if (vau de (con than & else) (eval (array cond con than
true (cond (> (len else) 0) (idx else 0)
true false)) de))
2022-02-03 02:41:14 -05:00
2022-02-07 00:31:51 -05:00
map (lambda (f5 l5)
; now maybe errors on can't find helper?
(let (helper (rec-lambda recurse (f4 l4 n4 i4)
(cond (= i4 (len l4)) n4
2022-02-15 23:16:27 -05:00
(<= i4 (- (len l4) 4)) (recurse f4 l4 (concat n4 (array
(f4 (idx l4 (+ i4 0)))
(f4 (idx l4 (+ i4 1)))
(f4 (idx l4 (+ i4 2)))
(f4 (idx l4 (+ i4 3)))
)) (+ i4 4))
2022-02-07 00:31:51 -05:00
true (recurse f4 l4 (concat n4 (array (f4 (idx l4 i4)))) (+ i4 1)))))
(helper f5 l5 (array) 0)))
2022-02-19 00:14:36 -05:00
map_i (lambda (f l)
(let (helper (rec-lambda recurse (f l n i)
(cond (= i (len l)) n
(<= i (- (len l) 4)) (recurse f l (concat n (array
(f (+ i 0) (idx l (+ i 0)))
(f (+ i 1) (idx l (+ i 1)))
(f (+ i 2) (idx l (+ i 2)))
(f (+ i 3) (idx l (+ i 3)))
)) (+ i 4))
true (recurse f l (concat n (array (f i (idx l i)))) (+ i 1)))))
(helper f l (array) 0)))
filter_i (lambda (f l)
(let (helper (rec-lambda recurse (f l n i)
(if (= i (len l))
n
(if (f i (idx l i)) (recurse f l (concat n (array (idx l i))) (+ i 1))
(recurse f l n (+ i 1))))))
(helper f l (array) 0)))
filter (lambda (f l) (filter_i (lambda (i x) (f x)) l))
; Huge thanks to Oleg Kiselyov for his fantastic website
; http://okmij.org/ftp/Computation/fixed-point-combinators.html
Y* (lambda (& l)
((lambda (u) (u u))
(lambda (p)
(map (lambda (li) (lambda (& x) (lapply (lapply li (p p)) x))) l))))
vY* (lambda (& l)
((lambda (u) (u u))
(lambda (p)
(map (lambda (li) (vau ide (& x) (vapply (lapply li (p p)) x ide))) l))))
let-rec (vau de (name_func body)
(let (names (filter_i (lambda (i x) (= 0 (% i 2))) name_func)
funcs (filter_i (lambda (i x) (= 1 (% i 2))) name_func)
overwrite_name (idx name_func (- (len name_func) 2)))
(eval (array let (concat (array overwrite_name (concat (array Y*) (map (lambda (f) (array lambda names f)) funcs)))
(lapply concat (map_i (lambda (i n) (array n (array idx overwrite_name i))) names)))
body) de)))
let-vrec (vau de (name_func body)
(let (names (filter_i (lambda (i x) (= 0 (% i 2))) name_func)
funcs (filter_i (lambda (i x) (= 1 (% i 2))) name_func)
overwrite_name (idx name_func (- (len name_func) 2)))
(eval (array let (concat (array overwrite_name (concat (array vY*) (map (lambda (f) (array lambda names f)) funcs)))
(lapply concat (map_i (lambda (i n) (array n (array idx overwrite_name i))) names)))
body) de)))
flat_map (lambda (f l)
(let (helper (rec-lambda recurse (f l n i)
(if (= i (len l))
n
(recurse f l (concat n (f (idx l i))) (+ i 1)))))
(helper f l (array) 0)))
flat_map_i (lambda (f l)
(let (helper (rec-lambda recurse (f l n i)
(if (= i (len l))
n
(recurse f l (concat n (f i (idx l i))) (+ i 1)))))
(helper f l (array) 0)))
; with all this, we make a destrucutring-capable let
let (let (
destructure_helper (rec-lambda recurse (vs i r)
(cond (= (len vs) i) r
(array? (idx vs i)) (let (bad_sym (str-to-symbol (str (idx vs i)))
;new_vs (flat_map_i (lambda (i x) (array x (array idx bad_sym i))) (slice (idx vs i) 1 -1))
new_vs (flat_map_i (lambda (i x) (array x (array idx bad_sym i))) (idx vs i))
)
(recurse (concat new_vs (slice vs (+ i 2) -1)) 0 (concat r (array bad_sym (idx vs (+ i 1))))))
true (recurse vs (+ i 2) (concat r (slice vs i (+ i 2))))
))) (vau de (vs b) (vapply let (array (destructure_helper vs 0 (array)) b) de)))
; and a destructuring-capable lambda!
only_symbols (rec-lambda recurse (a i) (cond (= i (len a)) true
(symbol? (idx a i)) (recurse a (+ i 1))
true false))
2022-02-20 23:42:09 -05:00
; Note that if macro_helper is inlined, the mapping lambdas will close over
; se, and then not be able to be taken in as values to the maps, and the vau
; will fail to partially evaluate away.
lambda (let (macro_helper (lambda (p b) (let (
sym_params (map (lambda (param) (if (symbol? param) param
(str-to-symbol (str param)))) p)
body (array let (flat_map_i (lambda (i x) (array (idx p i) x)) sym_params) b)
) (array vau sym_params body))))
(vau se (p b) (if (only_symbols p 0) (vapply lambda (array p b) se)
(wrap (eval (macro_helper p b) se)))))
2022-02-19 00:14:36 -05:00
; and rec-lambda - yes it's the same definition again
rec-lambda (vau se (n p b) (eval (array Y (array lambda (array n) (array lambda p b))) se))
2022-03-03 09:28:01 -05:00
nil (array)
not (lambda (x) (if x false true))
or (let (macro_helper (rec-lambda recurse (bs i) (cond (= i (len bs)) false
(= (+ 1 i) (len bs)) (idx bs i)
true (array let (array 'tmp (idx bs i)) (array if 'tmp 'tmp (recurse bs (+ i 1)))))))
(vau se (& bs) (eval (macro_helper bs 0) se)))
and (let (macro_helper (rec-lambda recurse (bs i) (cond (= i (len bs)) true
(= (+ 1 i) (len bs)) (idx bs i)
true (array let (array 'tmp (idx bs i)) (array if 'tmp (recurse bs (+ i 1)) 'tmp)))))
(vau se (& bs) (eval (macro_helper bs 0) se)))
2022-02-19 00:14:36 -05:00
2022-03-02 01:44:20 -05:00
foldl (let (helper (rec-lambda recurse (f z vs i) (if (= i (len (idx vs 0))) z
(recurse f (lapply f (cons z (map (lambda (x) (idx x i)) vs))) vs (+ i 1)))))
(lambda (f z & vs) (helper f z vs 0)))
foldr (let (helper (rec-lambda recurse (f z vs i) (if (= i (len (idx vs 0))) z
(lapply f (cons (recurse f z vs (+ i 1)) (map (lambda (x) (idx x i)) vs))))))
(lambda (f z & vs) (helper f z vs 0)))
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)))
2022-03-08 02:54:26 -05:00
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Begin kludges to align with Scheme kludges
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2022-03-03 00:33:25 -05:00
dlet (vau se (inners body) (vapply let (array (lapply concat inners) body) se))
cond (vau se (& inners) (vapply cond (lapply concat inners) se))
2022-03-08 02:54:26 -05:00
print log
println log
dlambda lambda
2022-03-13 15:11:30 -04:00
mif (vau de (c & bs) (vapply if (cons (array let (array 'tmp c) (array and (array != 'tmp (array quote (array))) 'tmp)) bs) de))
2022-03-08 02:54:26 -05:00
;mif (vau de (c & bs) (eval (concat (array if (array let (array 'tmp c) (array and (array != 'tmp) 'tmp))) bs) de))
2022-03-02 01:44:20 -05:00
2022-03-03 00:33:25 -05:00
2022-02-07 00:31:51 -05:00
)
2022-03-03 00:33:25 -05:00
(dlet (
2022-03-08 02:54:26 -05:00
(empty_dict-list (array))
(put-list (lambda (m k v) (cons (array k v) m)))
(get-list (lambda (d k) ((rec-lambda recurse (k d len_d i) (cond ((= len_d i) false)
((= k (idx (idx d i) 0)) (idx d i))
(true (recurse k d len_d (+ 1 i)))))
k d (len d) 0)))
;(combine_hash (lambda (a b) (+ (* 37 a) b)))
(combine_hash (lambda (a b) (band #xFFFFFFFFFFFFFF (+ (* 37 a) b))))
(hash_bool (lambda (b) (if b 2 3)))
(hash_num (lambda (n) (combine_hash 5 n)))
;(hash_string (lambda (s) (foldl combine_hash 7 (map char->integer (string->list s)))))
(hash_string (lambda (s) (foldl combine_hash 7 s)))
;(hash_string (lambda (s) (foldl combine_hash 102233 (map char->integer (string->list s)))))
(empty_dict-tree nil)
(trans-key (lambda (k) (cond ((string? k) (hash_string k))
((symbol? k) (hash_string (get-text k)))
(true k))))
(put-helper (rec-lambda put-helper (m hk k v) (cond ((nil? m) (array hk k v nil nil))
((and (= hk (idx m 0))
(= k (idx m 1))) (array hk k v (idx m 3) (idx m 4)))
((< hk (idx m 0)) (array (idx m 0) (idx m 1) (idx m 2) (put-helper (idx m 3) hk k v) (idx m 4)))
(true (array (idx m 0) (idx m 1) (idx m 2) (idx m 3) (put-helper (idx m 4) hk k v))))))
(put-tree (lambda (m k v) (put-helper m (trans-key k) k v)))
(get-helper (rec-lambda get-helper (m hk k) (cond ((nil? m) false)
((and (= hk (idx m 0))
(= k (idx m 1))) (array k (idx m 2)))
((< hk (idx m 0)) (get-helper (idx m 3) hk k))
(true (get-helper (idx m 4) hk k)))))
(get-tree (lambda (m k) (get-helper m (trans-key k) k)))
;(empty_dict empty_dict-list)
;(put put-list)
;(get get-list)
(empty_dict empty_dict-tree)
(put put-tree)
(get get-tree)
(get-value (lambda (d k) (dlet ((result (get d k)))
(if (array? result) (idx result 1)
(error (str "could not find " k " in " d))))))
(get-value-or-false (lambda (d k) (dlet ((result (get d k)))
(if (array? result) (idx result 1)
false))))
(in_array (dlet ((helper (rec-lambda recurse (x a len_a i) (cond ((= i len_a) false)
((= x (idx a i)) true)
(true (recurse x a len_a (+ i 1)))))))
(lambda (x a) (helper x a (len a) 0))))
(array_item_union (lambda (a bi) (if (in_array bi a) a (cons bi a))))
(array_union (lambda (a b) (foldl array_item_union a b)))
(array_union_without (lambda (wo a b)
(foldl (lambda (o xi) (if (or (= wo xi) (in_array xi o)) o (cons xi o)))
(array) (concat a b))))
2022-03-03 00:33:25 -05:00
2022-03-10 01:06:44 -05:00
; just for now, should just add all normal linked list primitives
; as they should be
(car (lambda (x) (idx x 0)))
(cdr (lambda (x) (slice x 1 -1)))
(intset_word_size 64)
(in_intset (rec-lambda in_intset (x a) (cond ((nil? a) false)
((>= x intset_word_size) (in_intset (- x intset_word_size) (cdr a)))
(true (!= (band (>> (car a) x) 1) 0)))))
(intset_item_union (rec-lambda intset_item_union (a bi) (cond ((nil? a) (intset_item_union (array 0) bi))
((>= bi intset_word_size) (cons (car a) (intset_item_union (cdr a) (- bi intset_word_size))))
(true (cons (bor (car a) (<< 1 bi)) (cdr a))))))
(intset_item_remove (rec-lambda intset_item_remove (a bi) (cond ((nil? a) nil)
((>= bi intset_word_size) (dlet ((new_tail (intset_item_remove (cdr a) (- bi intset_word_size))))
(if (and (nil? new_tail) (= 0 (car a))) nil
(cons (car a) new_tail))))
(true (dlet ((new_int (band (car a) (bnot (<< 1 bi)))))
(if (and (nil? (cdr a)) (= 0 new_int)) nil
(cons new_int (cdr a))))))))
(intset_union (rec-lambda intset_union (a b) (cond ((and (nil? a) (nil? b)) nil)
((nil? a) b)
((nil? b) a)
(true (cons (bor (car a) (car b)) (intset_union (cdr a) (cdr b)))))))
(intset_intersection_nonempty (rec-lambda intset_intersection_nonempty (a b) (cond ((nil? a) false)
((nil? b) false)
(true (or (!= 0 (band (car a) (car b))) (intset_intersection_nonempty (cdr a) (cdr b)))))))
(intset_union_without (lambda (wo a b) (intset_item_remove (intset_union a b) wo)))
2022-03-03 00:33:25 -05:00
(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)))
2022-03-08 02:54:26 -05:00
(marked_env_real? (lambda (x) (= nil (idx (.marked_env_needed_for_progress x) 0))))
2022-03-03 00:33:25 -05:00
(.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))
2022-03-08 02:54:26 -05:00
((marked_symbol? x) (array (.marked_symbol_needed_for_progress x) nil nil))
((marked_env? x) (.marked_env_needed_for_progress x))
2022-03-03 09:28:01 -05:00
((comb? x) (dlet ((id (.comb_id x))
2022-03-08 02:54:26 -05:00
((body_needed _hashes extra1) (needed_for_progress (.comb_body x)))
((se_needed _hashes extra2) (needed_for_progress (.comb_env x))))
(if (or (= true body_needed) (= true se_needed)) (array true nil nil)
(array (array_union_without id body_needed se_needed)
nil (array_union_without id extra1 extra2))
2022-03-03 09:28:01 -05:00
)))
2022-03-08 02:54:26 -05:00
((prim_comb? x) (array nil nil nil))
((val? x) (array nil nil nil))
2022-03-03 00:33:25 -05:00
(true (error (str "what is this? in need for progress" x))))))
(needed_for_progress_slim (lambda (x) (idx (needed_for_progress x) 0)))
2022-03-08 02:54:26 -05:00
(hash_symbol (lambda (progress_idxs s) (combine_hash (if (= true progress_idxs) 11 (foldl combine_hash 13 (map (lambda (x) (if (= true x) 13 (+ 1 x))) progress_idxs))) (hash_string (get-text s)))))
(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 (has_vals progress_idxs dbi arrs) (combine_hash (if has_vals 107 109)
(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))))
(cond ((= nil progress_idxs) 23)
((= true progress_idxs) 29)
(true (foldl combine_hash 31 progress_idxs)))
(slice arrs 0 -2)))
(end (idx arrs -1))
(end_hash (mif end (.hash end) 41))
) (combine_hash inner_hash end_hash))))))
(hash_comb (lambda (wrap_level env_id de? se variadic params body)
(combine_hash 43
(combine_hash wrap_level
(combine_hash env_id
(combine_hash (mif de? (hash_symbol true de?) 47)
(combine_hash (.hash se)
(combine_hash (hash_bool variadic)
(combine_hash (foldl (lambda (c x) (combine_hash c (hash_symbol true x))) 53 params)
(.hash body))))))))))
(hash_prim_comb (lambda (handler_fun real_or_name wrap_level val_head_ok) (combine_hash (combine_hash 59 (hash_symbol true real_or_name))
(combine_hash (if val_head_ok 89 97) wrap_level))))
(hash_val (lambda (x) (cond ((bool? x) (hash_bool x))
((string? x) (hash_string x))
((int? x) (hash_num x))
(true (error (str "bad thing to hash_val " x))))))
; 113 127 131 137 139 149 151 157 163 167 173
(marked_symbol (lambda (progress_idxs x) (array 'marked_symbol (hash_symbol progress_idxs x) progress_idxs x)))
(marked_array (lambda (is_val attempted resume_hashes x) (dlet (
((sub_progress_idxs hashes extra) (foldl (dlambda ((a ahs aeei) (x xhs x_extra_env_ids))
(array (cond ((or (= true a) (= true x)) true)
(true (array_union a x)))
(array_union ahs xhs)
(array_union aeei x_extra_env_ids))
) (array (array) resume_hashes (array)) (map needed_for_progress x)))
(progress_idxs (cond ((and (= nil sub_progress_idxs) (not is_val) (= true attempted)) nil)
((and (= nil sub_progress_idxs) (not is_val) (= false attempted)) true)
((and (= nil sub_progress_idxs) (not is_val) (int? attempted)) (array attempted))
(true (if (int? attempted)
(array_item_union sub_progress_idxs attempted)
sub_progress_idxs))))
) (array 'marked_array (hash_array is_val attempted x) is_val attempted (array progress_idxs hashes extra) x))))
(marked_env (lambda (has_vals de? de ue dbi arrs) (dlet (
(de_entry (mif de? (array (array de? de)) (array)))
(full_arrs (concat arrs de_entry (array ue)))
((progress_idxs1 _hashes extra1) (mif ue (needed_for_progress ue) (array nil nil nil)))
((progress_idxs2 _hashes extra2) (mif de? (needed_for_progress de) (array nil nil nil)))
(progress_idxs (array_union progress_idxs1 progress_idxs2))
(extra (array_union extra1 extra2))
(progress_idxs (if (not has_vals) (cons dbi progress_idxs) progress_idxs))
(extra (if (!= nil progress_idxs) (cons dbi extra) extra))
) (array 'env (hash_env has_vals progress_idxs dbi full_arrs) has_vals (array progress_idxs nil extra) dbi full_arrs))))
(marked_val (lambda (x) (array 'val (hash_val x) x)))
(marked_comb (lambda (wrap_level env_id de? se variadic params body) (array 'comb (hash_comb wrap_level env_id de? se variadic params body) wrap_level env_id de? se variadic params body)))
(marked_prim_comb (lambda (handler_fun real_or_name wrap_level val_head_ok) (array 'prim_comb (hash_prim_comb handler_fun real_or_name wrap_level val_head_ok) handler_fun real_or_name wrap_level val_head_ok)))
(with_wrap_level (lambda (x new_wrap) (cond ((prim_comb? x) (dlet (((handler_fun real_or_name wrap_level val_head_ok) (.prim_comb x)))
(marked_prim_comb handler_fun real_or_name new_wrap val_head_ok)))
((comb? x) (dlet (((wrap_level env_id de? se variadic params body) (.comb x)))
(marked_comb new_wrap env_id de? se variadic params body)))
(true (error "bad with_wrap_level")))))
2022-03-10 01:06:44 -05:00
(later_head? (rec-lambda recurse (x) (or (and (marked_array? x) (or (= false (.marked_array_is_val x)) (foldl (lambda (a x) (or a (recurse x))) false (.marked_array_values x))))
(and (marked_symbol? x) (= false (.marked_symbol_is_val x)))
)))
; array and comb are the ones wherewhere (= nil (needed_for_progress_slim x)) == total_value? isn't true.
; Right now we only call functions when all parameters are values, which means you can't
; create a true_value array with non-value memebers (*right now* anyway), but it does mean that
; you can create a nil needed for progress array that isn't a value, namely for the give_up_*
; primitive functions (extra namely, log and error, which are our two main sources of non-purity besides implicit runtime errors).
; OR, currently, having your code stopped because of infinite recursion checker. This comes up with the Y combiner
; For combs, being a value is having your env-chain be real?
(total_value? (lambda (x) (if (marked_array? x) (.marked_array_is_val x)
(= nil (needed_for_progress_slim x)))))
(is_all_values (lambda (evaled_params) (foldl (lambda (a x) (and a (total_value? x))) true evaled_params)))
(is_all_head_values (lambda (evaled_params) (foldl (lambda (a x) (and a (not (later_head? x)))) true evaled_params)))
(false? (lambda (x) (cond ((and (marked_array? x) (= false (.marked_array_is_val x))) (error "got a later marked_array passed to false? " x))
((and (marked_symbol? x) (= false (.marked_symbol_is_val x))) (error "got a later marked_symbol passed to false? " x))
((val? x) (not (.val x)))
(true false))))
(mark (rec-lambda recurse (eval_pos x) (cond ((env? x) (error "called mark with an env " x))
((combiner? x) (error "called mark with a combiner " x))
((symbol? x) (cond ((= 'true x) (marked_val #t))
((= 'false x) (marked_val #f))
(#t (marked_symbol (if eval_pos true nil) x))))
((array? x) (marked_array (not eval_pos) false nil
(idx (foldl (dlambda ((ep a) x) (array false (concat a (array (recurse ep x)))))
(array eval_pos (array))
x)
1)
))
(true (marked_val x)))))
(indent_str (rec-lambda recurse (i) (mif (= i 0) ""
(str " " (recurse (- i 1))))))
(speed_hack true)
(true_str str)
(indent_str (if speed_hack (lambda (i) "") indent_str))
(str_strip (lambda (& args) (lapply true_str (concat (slice args 0 -2) (array (idx ((rec-lambda recurse (x done_envs)
(cond ((= nil x) (array "<nil>" done_envs))
((string? x) (array (true_str "<raw string " x ">") done_envs))
((val? x) (array (true_str (.val x)) done_envs))
((marked_array? x) (dlet (((stripped_values done_envs) (foldl (dlambda ((vs de) x) (dlet (((v de) (recurse x de))) (array (concat vs (array v)) de)))
(array (array) done_envs) (.marked_array_values x))))
(mif (.marked_array_is_val x) (array (true_str "[" stripped_values "]") done_envs)
(array (true_str stripped_values) done_envs))))
;(array (true_str "<a" (.marked_array_is_attempted x) ",r" (needed_for_progress x) ">" stripped_values) done_envs))))
((marked_symbol? x) (mif (.marked_symbol_is_val x) (array (true_str "'" (.marked_symbol_value x)) done_envs)
(array (true_str (.marked_symbol_needed_for_progress x) "#" (.marked_symbol_value x)) done_envs)))
((comb? x) (dlet (((wrap_level env_id de? se variadic params body) (.comb x))
((se_s done_envs) (recurse se done_envs))
((body_s done_envs) (recurse body done_envs)))
(array (true_str "<n (comb " wrap_level " " env_id " " de? " " se_s " " params " " body_s ")>") done_envs)))
((prim_comb? x) (array (true_str "<wl=" (.prim_comb_wrap_level x) " " (.prim_comb_sym x) ">") done_envs))
((marked_env? x) (dlet ((e (.env_marked x))
(index (.marked_env_idx x))
(u (idx e -1))
(already (in_array index done_envs))
(opening (true_str "{" (mif (marked_env_real? x) "real" "fake") (mif (.marked_env_has_vals x) " real vals" " fake vals") " ENV idx: " (true_str index) ", "))
((middle done_envs) (if already (array "" done_envs) (foldl (dlambda ((vs de) (k v)) (dlet (((x de) (recurse v de))) (array (concat vs (array (array k x))) de)))
(array (array) done_envs)
(slice e 0 -2))))
((upper done_envs) (if already (array "" done_envs) (mif u (recurse u done_envs) (array "no_upper_likely_root_env" done_envs))))
(done_envs (if already done_envs (cons index done_envs)))
) (array (if already (true_str opening "omitted}")
(if (> (len e) 30) (true_str "{" (len e) "env}")
(true_str opening middle " upper: " upper "}"))) done_envs)
))
(true (error (true_str "some other str_strip? |" x "|")))
)
) (idx args -1) (array)) 0))))))
(true_str_strip str_strip)
(str_strip (if speed_hack (lambda (& args) 0) str_strip))
;(true_str_strip str_strip)
(print_strip (lambda (& args) (println (lapply str_strip args))))
(env-lookup-helper (rec-lambda recurse (dict key i fail success) (cond ((and (= i (- (len dict) 1)) (= nil (idx dict i))) (fail))
((= i (- (len dict) 1)) (recurse (.env_marked (idx dict i)) key 0 fail success))
((= key (idx (idx dict i) 0)) (success (idx (idx dict i) 1)))
(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 (dlet ((helper (rec-lambda recurse (x need_value)
(cond ((val? x) (.val 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)
(error (str "needed value for this strip but got" x))))
((comb? x) (error "got comb for strip, won't work"))
((prim_comb? x) (idx x 2))
; env emitting doesn't pay attention to real value right now, not sure mif that makes sense
; TODO: properly handle de Bruijn indexed envs
((marked_env? x) (error "got env for strip, won't work"))
(true (error (str "some other strip? " x)))
)
))) (lambda (x) (dlet (
;(_ (print_strip "stripping: " x))
(r (helper x true))
;(_ (println "result of strip " r))
) r))))
(try_unval (rec-lambda recurse (x fail_f)
(cond ((marked_array? x) (mif (not (.marked_array_is_val x)) (array false (fail_f x))
(if (!= 0 (len (.marked_array_values x)))
(dlet ((values (.marked_array_values x))
((ok f) (recurse (idx values 0) fail_f))
) (array ok (marked_array false false nil (cons f (slice values 1 -1)))))
(array true (marked_array false false nil (array))))))
((marked_symbol? x) (mif (.marked_symbol_is_val x) (array true (marked_symbol true (.marked_symbol_value x)))
(array false (fail_f x))))
(true (array true x))
)
))
(try_unval_array (lambda (x) (foldl (dlambda ((ok a) x) (dlet (((nok p) (try_unval x (lambda (_) nil))))
(array (and ok nok) (concat a (array p)))))
(array true (array))
x)))
(check_for_env_id_in_result (lambda (s_env_id x) (idx ((rec-lambda check_for_env_id_in_result (memo s_env_id x)
(dlet (
((need _hashes extra) (needed_for_progress x))
(in_need (if (!= true need) (in_intset s_env_id need) false))
(in_extra (in_intset s_env_id extra))
) (cond ((or in_need in_extra) (array memo true))
((!= true need) (array memo false))
(true (dlet (
(old_way (dlet (
(hash (.hash x))
(result (if (marked_env? x) (get memo hash) false))
) (if (array? result) (array memo (idx result 1)) (cond
((marked_symbol? x) (array memo false))
((marked_array? x) (dlet (
(values (.marked_array_values x))
((memo result) ((rec-lambda recurse (memo i) (if (= (len values) i) (array memo false)
(dlet (((memo r) (check_for_env_id_in_result memo s_env_id (idx values i))))
(if r (array memo true)
(recurse memo (+ i 1))))))
memo 0))
) (array memo result)))
((prim_comb? x) (array memo false))
((val? x) (array memo false))
((comb? x) (dlet (
((wrap_level i_env_id de? se variadic params body) (.comb x))
((memo in_se) (check_for_env_id_in_result memo s_env_id se))
((memo total) (if (and (not in_se) (!= s_env_id i_env_id)) (check_for_env_id_in_result memo s_env_id body)
(array memo in_se)))
) (array memo total)))
((marked_env? x) (if (and (not (marked_env_real? x)) (= s_env_id (.marked_env_idx x))) (array memo true)
(dlet (
(values (slice (.env_marked x) 0 -2))
(upper (idx (.env_marked x) -1))
((memo result) ((rec-lambda recurse (memo i) (if (= (len values) i) (array memo false)
(dlet (((memo r) (check_for_env_id_in_result memo s_env_id (idx (idx values i) 1))))
(if r (array memo true)
(recurse memo (+ i 1))))))
memo 0))
((memo result) (if (or result (= nil upper)) (array memo result)
(check_for_env_id_in_result memo s_env_id upper)))
(memo (put memo hash result))
) (array memo result))))
(true (error (str "Something odd passed to check_for_env_id_in_result " x)))
))))
;(new_if_working (or in_need in_extra))
;(_ (if (and (!= true need) (!= new_if_working (idx old_way 1))) (error "GAH looking for " s_env_id " - " need " - " extra " - " new_if_working " " (idx old_way 1))))
) old_way))))) (array) s_env_id x) 1)))
(comb_takes_de? (lambda (x l) (cond
((comb? x) (!= nil (.comb_des x)))
((prim_comb? x) (cond ( (= (.prim_comb_sym x) 'vau) true)
((and (= (.prim_comb_sym x) 'eval) (= 1 l)) true)
((and (= (.prim_comb_sym x) 'veval) (= 1 l)) true)
( (= (.prim_comb_sym x) 'lapply) true)
( (= (.prim_comb_sym x) 'vapply) true)
( (= (.prim_comb_sym x) 'cond) true) ; but not vcond
(true false)))
((and (marked_array? x) (not (.marked_array_is_val x))) true)
((and (marked_symbol? x) (not (.marked_symbol_is_val x))) true)
(true (error (str "illegal comb_takes_de? param " x)))
)))
; Handles let 4.3 through macro level leaving it as (<comb wraplevel=1 (y) (+ y x 12)> 13)
; need handling of symbols (which is illegal for eval but ok for calls) to push it farther
(combiner_return_ok (rec-lambda combiner_return_ok (func_result env_id)
(cond ((not (later_head? func_result)) (not (check_for_env_id_in_result env_id func_result)))
; special cases now
; *(veval body {env}) => (combiner_return_ok {env})
; The reason we don't have to check body is that this form is only creatable in ways that body was origionally a value and only need {env}
; Either it's created by eval, in which case it's fine, or it's created by something like (eval (array veval x de) de2) and the array has checked it,
; or it's created via literal vau invocation, in which case the body is a value.
((and (marked_array? func_result)
(prim_comb? (idx (.marked_array_values func_result) 0))
(= 'veval (.prim_comb_sym (idx (.marked_array_values func_result) 0)))
(= 3 (len (.marked_array_values func_result)))
(combiner_return_ok (idx (.marked_array_values func_result) 2) env_id)) true)
; (func ...params) => (and (doesn't take de func) (foldl combiner_return_ok (cons func params)))
;
((and (marked_array? func_result)
(not (comb_takes_de? (idx (.marked_array_values func_result) 0) (len (.marked_array_values func_result))))
(foldl (lambda (a x) (and a (combiner_return_ok x env_id))) true (.marked_array_values func_result))) true)
; So that's enough for macro like, but we would like to take it farther
; For like (let1 a 12 (wrap (vau (x) (let1 y (+ a 1) (+ y x a)))))
; we get to (+ 13 x 12) not being a value, and it reconstructs
; (<comb wraplevel=1 (y) (+ y x 12)> 13)
; and that's what eval gets, and eval then gives up as well.
; That will get caught by the above cases to remain the expansion (<comb wraplevel=1 (y) (+ y x 12)> 13),
; but ideally we really want another case to allow (+ 13 x 12) to bubble up
; I think it would be covered by the (func ...params) case if a case is added to allow symbols to be bubbled up if their
; needed for progress wasn't true or the current environment, BUT this doesn't work for eval, just for functions,
; since eval changes the entire env chain (but that goes back to case 1, and might be eliminated at compile if it's an env reachable from the func).
;
;
; Do note a key thing to be avoided is allowing any non-val inside a comb, since that can cause a fake env's ID to
; reference the wrong env/comb in the chain.
; We do allow calling eval with a fake env, but since it's only callable withbody value and is strict (by calling this)
; about it's return conditions, and the env it's called with must be ok in the chain, and eval doesn't introduce a new scope, it works ok.
; We do have to be careful about allowing returned later symbols from it though, since it could be an entirely different env chain.
(true false)
)
))
(drop_redundent_veval (rec-lambda drop_redundent_veval (partial_eval_helper x de env_stack pectx indent) (dlet (
(env_id (.marked_env_idx de))
(r (if
(and (marked_array? x)
(not (.marked_array_is_val x)))
(if (and (prim_comb? (idx (.marked_array_values x) 0))
(= 'veval (.prim_comb_sym (idx (.marked_array_values x) 0)))
(= 3 (len (.marked_array_values x)))
(not (marked_env_real? (idx (.marked_array_values x) 2)))
(= env_id (.marked_env_idx (idx (.marked_array_values x) 2)))) (drop_redundent_veval partial_eval_helper (idx (.marked_array_values x) 1) de env_stack pectx (+ 1 indent))
; wait, can it do this? will this mess with eval?
; basically making sure that this comb's params are still good to eval
(if (and (or (prim_comb? (idx (.marked_array_values x) 0)) (comb? (idx (.marked_array_values x) 0)))
(!= -1 (.any_comb_wrap_level (idx (.marked_array_values x) 0))))
(dlet (((pectx err ress changed) (foldl (dlambda ((c er ds changed) p) (dlet (
(pre_hash (.hash p))
((c e d) (drop_redundent_veval partial_eval_helper p de env_stack c (+ 1 indent)))
(err (mif er er e))
(changed (mif err false (or (!= pre_hash (.hash d)) changed)))
) (array c err (concat ds (array d)) changed)))
(array pectx nil (array) false)
(.marked_array_values x)))
((pectx err new_array) (if (or (!= nil err) (not changed))
(array pectx err x)
(partial_eval_helper (marked_array false (.marked_array_is_attempted x) nil ress)
false de env_stack pectx (+ indent 1) true)))
) (array pectx err new_array))
(array pectx nil x))
) (array pectx nil x))))
r)))
(make_tmp_inner_env (lambda (params de? ue env_id)
(dlet ((param_entries (map (lambda (p) (array p (marked_symbol env_id p))) params))
(possible_de (mif (= nil de?) (array) (marked_symbol env_id de?)))
) (marked_env false de? possible_de ue env_id param_entries))))
(partial_eval_helper (rec-lambda partial_eval_helper (x only_head env env_stack pectx indent force)
(dlet (((for_progress for_progress_hashes extra_env_ids) (needed_for_progress x))
(_ (print_strip (indent_str indent) "for_progress " for_progress ", for_progress_hashes " for_progress_hashes " for " x))
((env_counter memo) pectx)
(hashes_now (foldl (lambda (a hash) (or a (= false (get-value-or-false memo hash)))) false for_progress_hashes))
)
(if (or force hashes_now (= for_progress true) (intset_intersection_nonempty for_progress (idx env_stack 0)))
(cond ((val? x) (array pectx nil x))
((marked_env? x) (dlet ((dbi (.marked_env_idx x)))
; compiler calls with empty env stack
(mif dbi (dlet ( (new_env ((rec-lambda rec (i len_env_stack) (cond ((= i len_env_stack) nil)
((= dbi (.marked_env_idx (idx (idx env_stack 1) i))) (idx (idx env_stack 1) i))
(true (rec (+ i 1) len_env_stack))))
0 (len (idx env_stack 1))))
(_ (println (str_strip "replacing " x) (str_strip " with (if nonnil) " new_env)))
)
(array pectx nil (if (!= nil new_env) new_env x)))
(array pectx nil x))))
((comb? x) (dlet (((wrap_level env_id de? se variadic params body) (.comb x)))
(mif (or (and (not (marked_env_real? env)) (not (marked_env_real? se))) ; both aren't real, re-evaluation of creation site
(and (marked_env_real? env) (not (marked_env_real? se)))) ; new env real, but se isn't - creation!
(dlet ((inner_env (make_tmp_inner_env params de? env env_id))
((pectx err evaled_body) (partial_eval_helper body false inner_env (array (idx env_stack 0) (cons inner_env (idx env_stack 1))) pectx (+ indent 1) false)))
(array pectx err (mif err nil (marked_comb wrap_level env_id de? env variadic params evaled_body))))
(array pectx nil x))))
((prim_comb? x) (array pectx nil x))
((marked_symbol? x) (mif (.marked_symbol_is_val x) x
(env-lookup-helper (.env_marked env) (.marked_symbol_value x) 0
(lambda () (array pectx (str "could't find " (str_strip x) " in " (str_strip env)) nil))
(lambda (x) (array pectx nil x)))))
; Does this ever happen? non-fully-value arrays?
((marked_array? x) (cond ((.marked_array_is_val x) (dlet ( ((pectx err inner_arr) (foldl (dlambda ((c er ds) p) (dlet (((c e d) (partial_eval_helper p false env env_stack c (+ 1 indent) false))) (array c (mif er er e) (concat ds (array d)))))
(array pectx nil (array))
(.marked_array_values x)))
) (array pectx err (mif err nil (marked_array true false nil inner_arr)))))
((= 0 (len (.marked_array_values x))) (array pectx "Partial eval on empty array" nil))
(true (dlet ((values (.marked_array_values x))
(_ (print_strip (indent_str indent) "partial_evaling comb " (idx values 0)))
(literal_params (slice values 1 -1))
((pectx err comb) (partial_eval_helper (idx values 0) true env env_stack pectx (+ 1 indent) false))
) (cond ((!= nil err) (array pectx err nil))
((later_head? comb) (array pectx nil (marked_array false true nil (cons comb literal_params))))
((not (or (comb? comb) (prim_comb? comb))) (array pectx (str "impossible comb value " x) nil))
(true (dlet (
; If we haven't evaluated the function before at all, we would like to partially evaluate it so we know
; what it needs. We'll see if this re-introduces exponentail (I think this should limit it to twice?)
((pectx comb_err comb) (if (and (= nil err) (= true (needed_for_progress_slim comb)))
(partial_eval_helper comb false env env_stack pectx (+ 1 indent) false)
(array pectx err comb)))
(_ (println (indent_str indent) "Going to do an array call!"))
(indent (+ 1 indent))
(_ (print_strip (indent_str indent) "total (in env " (.marked_env_idx env) ") is (proceeding err " err ") " x))
(map_rp_eval (lambda (pectx ps) (foldl (dlambda ((c er ds) p) (dlet ((_ (print_strip (indent_str indent) "rp_evaling " p)) ((c e d) (partial_eval_helper p false env env_stack c (+ 1 indent) false)) (_ (print_strip (indent_str indent) "result of rp_eval was err " e " and value " d))) (array c (mif er er e) (concat ds (array d)))))
(array pectx nil (array))
ps)))
(wrap_level (.any_comb_wrap_level comb))
; -1 is a minor hack for veval to prevent re-eval
; in the wrong env and vcond to prevent guarded
; infinate recursion
((remaining_wrap param_err evaled_params pectx) (if (= -1 wrap_level)
(array -1 nil literal_params pectx)
((rec-lambda param-recurse (wrap cparams pectx)
(dlet (
(_ (print (indent_str indent) "For initial rp_eval:"))
(_ (map (lambda (x) (print_strip (indent_str indent) "item " x)) cparams))
((pectx er pre_evaled) (map_rp_eval pectx cparams))
(_ (print (indent_str indent) "er for intial rp_eval: " er))
)
(mif er (array wrap er nil pectx)
(mif (!= 0 wrap)
(dlet (((ok unval_params) (try_unval_array pre_evaled)))
(mif (not ok) (array wrap nil pre_evaled pectx)
(param-recurse (- wrap 1) unval_params pectx)))
(array wrap nil pre_evaled pectx)))))
wrap_level literal_params pectx)))
(_ (println (indent_str indent) "Done evaluating parameters"))
(l_later_call_array (lambda () (marked_array false true nil (cons (with_wrap_level comb remaining_wrap) evaled_params))))
(ok_and_non_later (or (= -1 remaining_wrap)
(and (= 0 remaining_wrap) (if (and (prim_comb? comb) (.prim_comb_val_head_ok comb))
(is_all_head_values evaled_params)
(is_all_values evaled_params)))))
(_ (println (indent_str indent) "ok_and_non_later " ok_and_non_later))
) (cond ((!= nil comb_err) (array pectx comb_err nil))
((!= nil param_err) (array pectx param_err nil))
((not ok_and_non_later) (array pectx nil (l_later_call_array)))
((prim_comb? comb) (dlet (
(_ (println (indent_str indent) "Calling prim comb " (.prim_comb_sym comb)))
((pectx err result) ((.prim_comb_handler comb) only_head env env_stack pectx evaled_params (+ 1 indent)))
) (if (= 'LATER err) (array pectx nil (l_later_call_array))
(array pectx err result))))
((comb? comb) (dlet (
((wrap_level env_id de? se variadic params body) (.comb comb))
(final_params (mif variadic (concat (slice evaled_params 0 (- (len params) 1))
(array (marked_array true false nil (slice evaled_params (- (len params) 1) -1))))
evaled_params))
(de_env (mif (!= nil de?) env nil))
(inner_env (marked_env true de? de_env se env_id (zip params final_params)))
(_ (print_strip (indent_str indent) " with inner_env is " inner_env))
(_ (print_strip (indent_str indent) "going to eval " body))
; prevent infinite recursion
(hash (combine_hash (.hash body) (.hash inner_env)))
((env_counter memo) pectx)
((pectx func_err func_result rec_stop) (if (!= false (get-value-or-false memo hash))
(array pectx nil "stopping for infinite recursion" true)
(dlet (
(new_memo (put memo hash nil))
(pectx (array env_counter new_memo))
((pectx func_err func_result) (partial_eval_helper body only_head inner_env
(array (intset_item_union (idx env_stack 0) env_id)
(cons inner_env (idx env_stack 1)))
pectx (+ 1 indent) false))
((env_counter new_memo) pectx)
(pectx (array env_counter memo))
) (array pectx func_err func_result false))))
(_ (print_strip (indent_str indent) "evaled result of function call (in env " (.marked_env_idx env) ", with inner " env_id ") and err " func_err " is " func_result))
(must_stop_maybe_id (and (= nil func_err)
(or rec_stop (if (not (combiner_return_ok func_result env_id))
(if (!= nil de?) (.marked_env_idx env) true)
false))))
) (if (!= nil func_err) (array pectx func_err nil)
(if must_stop_maybe_id
(array pectx nil (marked_array false must_stop_maybe_id (if rec_stop (array hash) nil) (cons (with_wrap_level comb remaining_wrap) evaled_params)))
(drop_redundent_veval partial_eval_helper func_result env env_stack pectx indent)))))
)))
)))))
(true (array pectx (str "impossible partial_eval value " x) nil))
)
; otherwise, we can't make progress yet
(drop_redundent_veval partial_eval_helper x env env_stack pectx indent)))
))
(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 (lapply 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) (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)))))
(veval_inner (rec-lambda recurse (only_head de env_stack pectx params indent) (dlet (
(body (idx params 0))
(implicit_env (!= 2 (len params)))
(eval_env (if implicit_env de (idx params 1)))
((pectx err eval_env) (if implicit_env (array pectx nil de)
(partial_eval_helper (idx params 1) only_head de env_stack pectx (+ 1 indent) false)))
((pectx err ebody) (if (or (!= nil err) (not (marked_env? eval_env)))
(array pectx err body)
(partial_eval_helper body only_head eval_env env_stack pectx (+ 1 indent) false)))
) (cond
((!= nil err) (array pectx err nil))
; If our env was implicit, then our unval'd code can be inlined directly in our caller
(implicit_env (drop_redundent_veval partial_eval_helper ebody de env_stack pectx indent))
((combiner_return_ok ebody (.marked_env_idx eval_env)) (drop_redundent_veval partial_eval_helper ebody de env_stack pectx indent))
(true (drop_redundent_veval partial_eval_helper (marked_array false true nil (array
(marked_prim_comb recurse 'veval -1 true)
ebody
eval_env
))
de env_stack pectx indent))
))))
2022-03-13 15:11:30 -04:00
(root_marked_env (marked_env true nil nil nil nil (array
2022-03-10 01:06:44 -05:00
2022-03-13 15:11:30 -04:00
(array 'eval (marked_prim_comb (rec-lambda recurse (only_head de env_stack pectx evaled_params indent)
(if (not (total_value? (idx evaled_params 0))) (array pectx nil (marked_array false true nil (cons (marked_prim_comb recurse 'eval 0 true) evaled_params)))
(if (and (= 2 (len evaled_params)) (not (marked_env? (idx evaled_params 1)))) (array pectx nil (marked_array false true nil (cons (marked_prim_comb recurse 'eval 0 true) evaled_params)))
(dlet (
(body (idx evaled_params 0))
(implicit_env (!= 2 (len evaled_params)))
(eval_env (if implicit_env de (idx evaled_params 1)))
((ok unval_body) (try_unval body (lambda (_) nil)))
(_ (if (not ok) (error "actually impossible eval unval")))
) (veval_inner only_head de env_stack pectx (if implicit_env (array unval_body) (array unval_body eval_env)) indent))))
) 'eval 1 true))
2022-03-08 02:54:26 -05:00
2022-03-13 15:11:30 -04:00
(array 'vapply (marked_prim_comb (dlambda (only_head de env_stack pectx (f ps ide) indent)
(veval_inner only_head de env_stack pectx (array (marked_array false false nil (cons f (.marked_array_values ps))) ide) (+ 1 indent))
) 'vapply 1 true))
(array 'lapply (marked_prim_comb (dlambda (only_head de env_stack pectx (f ps) indent)
(veval_inner only_head de env_stack pectx (array (marked_array false false nil (cons (with_wrap_level f (- (.any_comb_wrap_level f) 1)) (.marked_array_values ps)))) (+ 1 indent))
) 'lapply 1 true))
2022-03-08 02:54:26 -05:00
2022-03-20 20:50:39 -04:00
(array 'vau (marked_prim_comb (lambda (only_head de env_stack pectx params indent) (dlet (
(mde? (mif (= 3 (len params)) (idx params 0) nil))
(vau_mde? (mif (= nil mde?) (array) (array mde?)))
(_ (print (indent_str indent) "mde? is " mde?))
(_ (print (indent_str indent) "\tmde? if " (mif mde? #t #f)))
(de? (mif mde? (.marked_symbol_value mde?) nil))
(_ (print (indent_str indent) "de? is " de?))
(vau_de? (mif (= nil de?) (array) (array de?)))
(raw_marked_params (mif (= nil de?) (idx params 0) (idx params 1)))
(raw_params (map (lambda (x) (mif (not (marked_symbol? x)) (error (str "not a marked symbol " x))
(.marked_symbol_value x))) (.marked_array_values raw_marked_params)))
((variadic vau_params) (foldl (dlambda ((v a) x) (mif (= x '&) (array true a) (array v (concat a (array x))))) (array false (array)) raw_params))
((ok body) (try_unval (mif (= nil de?) (idx params 1) (idx params 2)) (lambda (_) nil)))
(_ (if (not ok) (error "actually impossible vau unval")))
((env_counter memo) pectx)
(new_id env_counter)
(env_counter (+ 1 env_counter))
(pectx (array env_counter memo))
((pectx err pe_body) (if only_head (array pectx nil body)
(dlet (
(inner_env (make_tmp_inner_env vau_params de? de new_id))
(_ (print_strip (indent_str indent) "in vau, evaluating body with 'later params - " body))
((pectx err pe_body) (partial_eval_helper body false inner_env (array (idx env_stack 0)
(cons inner_env (idx env_stack 1))) pectx (+ 1 indent) false))
(_ (print_strip (indent_str indent) "in vau, result of evaluating body was " pe_body))
) (array pectx err pe_body))))
) (mif err (array pectx err nil) (array pectx nil (marked_comb 0 new_id de? de variadic vau_params pe_body)))
)) 'vau 0 true))
2022-03-08 02:54:26 -05:00
2022-03-13 15:11:30 -04:00
(array 'empty_env (marked_env true nil nil nil nil nil))
)))
2022-03-20 20:50:39 -04:00
; This causes ?infinate? recursion, doesn't happen if "if" is replaced with cond
2022-04-09 00:45:58 -04:00
;(test_func (vau (x) (if x (COMICAL 0) 0)))
2022-03-13 15:11:30 -04:00
;(and_fold (foldl and true '(true true false true)))
;(monad (array 'write 1 (str "Hello from compiled code! " and_fold " here's a hashed string " (hash_string "hia") "\n") (vau (written code) (array 'exit 0))))
;(monad (array 'write 1 (str "Hello from compiled code! " (mif nil 1 2) " " (mif 1 3 4) "\n") (vau (written code) (array 'exit 0))))
(monad (array 'write 1 (str "Hello from compiled code! " "\n") (vau (written code) (array 'exit (if (not written) 1)))))
2022-03-03 00:33:25 -05:00
) monad)
2022-02-07 00:31:51 -05:00
)
2022-01-05 01:05:16 -05:00
; end of all lets
2022-02-15 23:16:27 -05:00
))))))
2022-01-05 01:05:16 -05:00
; impl of let1
2022-02-05 12:14:13 -05:00
; this would be the macro style version (((
)) (vau de (s v b) (eval (array (array wrap (array vau (array s) b)) v) de)))
;)) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de)))
2022-01-05 01:05:16 -05:00
; impl of quote
2022-01-07 22:08:29 -05:00
)) (vau (x5) x5))
