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

Add hashing (interestingly, arbitrary long hashes with Scheme's infinite precision)

Browse Source
This commit is contained in:
Nathan Braswell
2021-11-25 23:57:23 -05:00
parent a036936e3b
commit 8ab15fff41
1 changed files with 134 additions and 90 deletions
Download Patch File Download Diff File Expand all files Collapse all files

224
partial_eval.csc
View File

@@ -124,25 +124,59 @@
(let* ( (let* (
(val? (lambda (x) (= 'val (idx x 0)))) (val? (lambda (x) (= 'val (idx x 0))))
(.val (lambda (x) (idx x 1)))
(marked_array? (lambda (x) (= 'marked_array (idx x 0)))) (marked_array? (lambda (x) (= 'marked_array (idx x 0))))
(.marked_array_is_val (lambda (x) (idx x 1)))
(.marked_array_values (lambda (x) (idx x 2)))
(marked_symbol? (lambda (x) (= 'marked_symbol (idx x 0)))) (marked_symbol? (lambda (x) (= 'marked_symbol (idx x 0))))
(.marked_symbol_is_val (lambda (x) (idx x 1)))
(.marked_symbol_value (lambda (x) (idx x 2)))
(comb? (lambda (x) (= 'comb (idx x 0)))) (comb? (lambda (x) (= 'comb (idx x 0))))
(.comb (lambda (x) (slice x 1 -1)))
(prim_comb? (lambda (x) (= 'prim_comb (idx x 0)))) (prim_comb? (lambda (x) (= 'prim_comb (idx x 0))))
(.prim_comb (lambda (x) (idx x 1)))
(marked_env? (lambda (x) (= 'env (idx x 0)))) (marked_env? (lambda (x) (= 'env (idx x 0))))
(marked_env_real? (lambda (x) (idx x 1)))
(.marked_env_idx (lambda (x) (idx x 2)))
(.env_marked (lambda (x) (idx x 3)))
(mark_symbol (lambda (is_val x) (array 'marked_symbol is_val x))) (marked_env_real? (lambda (x) (idx x 2)))
(mark_array (lambda (is_val x) (array 'marked_array is_val x))) (.val (lambda (x) (idx x 2)))
(mark_val (lambda (x) (array 'val x))) (.marked_array_is_val (lambda (x) (idx x 2)))
(.marked_array_values (lambda (x) (idx x 3)))
(.marked_symbol_is_val (lambda (x) (idx x 2)))
(.marked_symbol_value (lambda (x) (idx x 3)))
(.comb (lambda (x) (slice x 2 -1)))
(.prim_comb (lambda (x) (idx x 2)))
(.marked_env (lambda (x) (slice x 2 -1)))
(.marked_env_idx (lambda (x) (idx x 3)))
(.env_marked (lambda (x) (idx x 4)))
(.hash (lambda (x) (idx x 1)))
(combine_hash (lambda (a b) (+ (* 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_symbol (lambda (is_val s) (combine_hash (if is_val 11 13) (hash_string (symbol->string s)))))
(hash_array (lambda (is_val a) (foldl combine_hash (if is_val 17 19) (map .hash a))))
(hash_env (lambda (is_real dbi arrs) (combine_hash (mif dbi (hash_num dbi) 59) (let* (
(inner_hash (foldl (dlambda (c (s v)) (combine_hash c (combine_hash (hash_symbol false s) (.hash v))))
(if is_real 23 29)
(slice arrs 0 -2)))
(end (idx arrs -1))
(end_hash (mif end (.hash end) 31))
) (combine_hash inner_hash end_hash)))))
(hash_comb (lambda (wrap_level de? se variadic params body) (combine_hash 41
(combine_hash (mif de? (hash_symbol false de?) 43)
(combine_hash (.hash se)
(combine_hash (hash_bool variadic)
(combine_hash (foldl (lambda (c x) (combine_hash c (hash_symbol false x))) 47 params)
(.hash body))))))))
(hash_prim_comb (lambda (handler_fun real_or_name) (combine_hash 53 (hash_symbol false real_or_name))))
(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))))))
; 41 43 47 53 59 61 67 71
(marked_symbol (lambda (is_val x) (array 'marked_symbol (hash_symbol is_val x) is_val x)))
(marked_array (lambda (is_val x) (array 'marked_array (hash_array is_val x) is_val x)))
(marked_val (lambda (x) (array 'val (hash_val x) x)))
(marked_env (lambda (is_real dbi arrs) (array 'env (hash_env is_real dbi arrs) is_real dbi arrs)))
(marked_comb (lambda (wrap_level de? se variadic params body) (array 'comb (hash_comb wrap_level de? se variadic params body) wrap_level de? se variadic params body)))
(marked_prim_comb (lambda (handler_fun real_or_name) (array 'prim_comb (hash_prim_comb handler_fun real_or_name) handler_fun real_or_name)))
@@ -163,11 +197,11 @@
(mark (rec-lambda recurse (x) (cond ((env? x) (error "called mark with an env " x)) (mark (rec-lambda recurse (x) (cond ((env? x) (error "called mark with an env " x))
((combiner? x) (error "called mark with a combiner " x)) ((combiner? x) (error "called mark with a combiner " x))
((symbol? x) (cond ((= 'true x) (mark_val #t)) ((symbol? x) (cond ((= 'true x) (marked_val #t))
((= 'false x) (mark_val #f)) ((= 'false x) (marked_val #f))
(#t (mark_symbol false x)))) (#t (marked_symbol false x))))
((array? x) (mark_array false (map recurse x))) ((array? x) (marked_array false (map recurse x)))
(true (mark_val x))))) (true (marked_val x)))))
(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))))))
@@ -231,8 +265,8 @@
(array (and ok nok) (concat a (array p))))) (array (and ok nok) (concat a (array p)))))
(array true (array)) (array true (array))
(.marked_array_values x)))) (.marked_array_values x))))
(array sub_ok (array 'marked_array false subs))))) (array sub_ok (marked_array false subs)))))
((marked_symbol? x) (mif (.marked_symbol_is_val x) (array true (array 'marked_symbol false (.marked_symbol_value x))) ((marked_symbol? x) (mif (.marked_symbol_is_val x) (array true (marked_symbol false (.marked_symbol_value x)))
(array false (fail_f x)))) (array false (fail_f x))))
(true (array true x)) (true (array true x))
) )
@@ -243,8 +277,8 @@
x))) x)))
(ensure_val (rec-lambda recurse (x) (ensure_val (rec-lambda recurse (x)
(cond ((marked_array? x) (array 'marked_array true (map recurse (.marked_array_values x)))) (cond ((marked_array? x) (marked_array true (map recurse (.marked_array_values x))))
((marked_symbol? x) (array 'marked_symbol true (.marked_symbol_value x))) ((marked_symbol? x) (marked_symbol true (.marked_symbol_value x)))
(true x) (true x)
) )
)) ))
@@ -280,21 +314,21 @@
; * TODO: allowing envs to be shead mif they're not used. ; * TODO: allowing envs to be shead mif they're not used.
(shift_envs (rec-lambda recurse (cutoff d x) (cond (shift_envs (rec-lambda recurse (cutoff d x) (cond
((val? x) (array true x)) ((val? x) (array true x))
((marked_env? x) (dlet (((_env is_real dbi meat) x) ((marked_env? x) (dlet (((is_real dbi meat) (.marked_env x))
((nmeat_ok nmeat) (foldl (dlambda ((ok r) (k v)) (dlet (((tok tv) (recurse cutoff d v))) (array (and ok tok) (concat r (array (array k tv)))))) (array true (array)) (slice meat 0 -2))) ((nmeat_ok nmeat) (foldl (dlambda ((ok r) (k v)) (dlet (((tok tv) (recurse cutoff d v))) (array (and ok tok) (concat r (array (array k tv)))))) (array true (array)) (slice meat 0 -2)))
((nupper_ok nupper) (mif (idx meat -1) (recurse cutoff d (idx meat -1)) (array true nil))) ((nupper_ok nupper) (mif (idx meat -1) (recurse cutoff d (idx meat -1)) (array true nil)))
(ndbi (cond ((nil? dbi) nil) (ndbi (cond ((nil? dbi) nil)
((>= dbi cutoff) (+ dbi d)) ((>= dbi cutoff) (+ dbi d))
(true dbi))) (true dbi)))
) (array (and nmeat_ok nupper_ok (or is_real (and ndbi (>= ndbi 0)))) (array 'env is_real ndbi (concat nmeat (array nupper)))))) ) (array (and nmeat_ok nupper_ok (or is_real (and ndbi (>= ndbi 0)))) (marked_env is_real ndbi (concat nmeat (array nupper))))))
((comb? x) (dlet (((wrap_level de? se variadic params body) (.comb x)) ((comb? x) (dlet (((wrap_level de? se variadic params body) (.comb x))
((se_ok nse) (recurse cutoff d se)) ((se_ok nse) (recurse cutoff d se))
((body_ok nbody) (recurse (+ cutoff 1) d body)) ((body_ok nbody) (recurse (+ cutoff 1) d body))
) (array (and se_ok body_ok) (array 'comb wrap_level de? nse variadic params nbody)))) ) (array (and se_ok body_ok) (marked_comb wrap_level de? nse variadic params nbody))))
((prim_comb? x) (array true x)) ((prim_comb? x) (array true x))
((marked_symbol? x) (array true x)) ((marked_symbol? x) (array true x))
((marked_array? x) (dlet (((insides_ok insides) (foldl (dlambda ((ok r) tx) (dlet (((tok tr) (recurse cutoff d tx))) (array (and ok tok) (concat r (array tr))))) (array true (array)) (.marked_array_values x)))) ((marked_array? x) (dlet (((insides_ok insides) (foldl (dlambda ((ok r) tx) (dlet (((tok tr) (recurse cutoff d tx))) (array (and ok tok) (concat r (array tr))))) (array true (array)) (.marked_array_values x))))
(array insides_ok (array 'marked_array (.marked_array_is_val x) insides)))) (array insides_ok (marked_array (.marked_array_is_val x) insides))))
(true (error (str "impossible shift_envs value " x))) (true (error (str "impossible shift_envs value " x)))
))) )))
(increment_envs (lambda (x) (idx (shift_envs 0 1 x) 1))) (increment_envs (lambda (x) (idx (shift_envs 0 1 x) 1)))
@@ -304,7 +338,7 @@
; ['ref de_bruijn_index_of_env index_into_env] or somesuch. Could really simplify ; ['ref de_bruijn_index_of_env index_into_env] or somesuch. Could really simplify
; compiling, and I think make partial-eval more efficient. More accurate closes_over analysis too, I think ; compiling, and I think make partial-eval more efficient. More accurate closes_over analysis too, I think
(make_tmp_inner_env (lambda (params de? de) (make_tmp_inner_env (lambda (params de? de)
(array 'env false 0 (concat (map (lambda (p) (array p (array 'marked_symbol false p))) params) (mif (= nil de?) (array) (array (array de? (array 'marked_symbol false de?)) )) (array (increment_envs de)))))) (marked_env false 0 (concat (map (lambda (p) (array p (marked_symbol false p))) params) (mif (= nil de?) (array) (array (array de? (marked_symbol false de?)) )) (array (increment_envs de))))))
(partial_eval_helper (rec-lambda recurse (x env env_stack indent) (partial_eval_helper (rec-lambda recurse (x env env_stack indent)
@@ -322,7 +356,7 @@
(mif (or (and (not (marked_env_real? env)) (not (marked_env_real? se))) ; both aren't real, re-evaluation of creation site (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! (and (marked_env_real? env) (not (marked_env_real? se)))) ; new env real, but se isn't - creation!
(let ((inner_env (make_tmp_inner_env params de? env))) (let ((inner_env (make_tmp_inner_env params de? env)))
(array 'comb wrap_level de? env variadic params (recurse body inner_env (cons inner_env env_stack) (+ indent 1)))) (marked_comb wrap_level de? env variadic params (recurse body inner_env (cons inner_env env_stack) (+ indent 1))))
x))) x)))
((prim_comb? x) x) ((prim_comb? x) x)
((marked_symbol? x) (mif (.marked_symbol_is_val x) x ((marked_symbol? x) (mif (.marked_symbol_is_val x) x
@@ -353,15 +387,15 @@
(array true cparams)) (array true cparams))
) wrap_level ensure_val_params)) ) wrap_level ensure_val_params))
(ok_and_non_later (and ok (is_all_values appropriatly_evaled_params))) (ok_and_non_later (and ok (is_all_values appropriatly_evaled_params)))
) (mif (not ok_and_non_later) (array 'marked_array false (cons comb (mif (> wrap_level 0) (map rp_eval literal_params) ) (mif (not ok_and_non_later) (marked_array false (cons comb (mif (> wrap_level 0) (map rp_eval literal_params)
literal_params))) literal_params)))
(dlet ( (dlet (
(final_params (mif variadic (concat (slice appropriatly_evaled_params 0 (- (len params) 1)) (final_params (mif variadic (concat (slice appropriatly_evaled_params 0 (- (len params) 1))
(array (array 'marked_array true (slice appropriatly_evaled_params (- (len params) 1) -1)))) (array (marked_array true (slice appropriatly_evaled_params (- (len params) 1) -1))))
appropriatly_evaled_params)) appropriatly_evaled_params))
((de_real de_entry) (mif (!= nil de?) (array (marked_env_real? env) (array (array de? (increment_envs env) ) ) ) ((de_real de_entry) (mif (!= nil de?) (array (marked_env_real? env) (array (array de? (increment_envs env) ) ) )
(array true (array)))) (array true (array))))
(inner_env (array 'env (and de_real (marked_env_real? se)) 0 (concat (zip params (map (lambda (x) (increment_envs x)) final_params)) de_entry (array (increment_envs se))))) (inner_env (marked_env (and de_real (marked_env_real? se)) 0 (concat (zip params (map (lambda (x) (increment_envs x)) final_params)) de_entry (array (increment_envs se)))))
(_ (print_strip (indent_str indent) " with inner_env is " inner_env)) (_ (print_strip (indent_str indent) " with inner_env is " inner_env))
(_ (print_strip (indent_str indent) "going to eval " body)) (_ (print_strip (indent_str indent) "going to eval " body))
@@ -377,11 +411,11 @@
; just by re-wrapping it in a comb instead mif we wanted. ; just by re-wrapping it in a comb instead mif we wanted.
; Something to think about! ; Something to think about!
(result (mif (or (not able_to_sub_env) (and result_is_later result_closes_over)) (result (mif (or (not able_to_sub_env) (and result_is_later result_closes_over))
(array 'marked_array false (cons comb (mif (> wrap_level 0) (map rp_eval literal_params) (marked_array false (cons comb (mif (> wrap_level 0) (map rp_eval literal_params)
literal_params))) literal_params)))
func_result)) func_result))
) result)))) ) result))))
((later? comb) (array 'marked_array false (cons comb literal_params))) ((later? comb) (marked_array false (cons comb literal_params)))
(true (error (str "impossible comb value " x)))))))) (true (error (str "impossible comb value " x))))))))
(true (error (str "impossible partial_eval value " x))) (true (error (str "impossible partial_eval value " x)))
) )
@@ -404,26 +438,21 @@
(evaled_params (map (lambda (p) (partial_eval_helper p de env_stack (+ 1 indent))) params)) (evaled_params (map (lambda (p) (partial_eval_helper p de env_stack (+ 1 indent))) params))
) )
(mif (is_all_values evaled_params) (mark (apply actual_function (map strip evaled_params))) (mif (is_all_values evaled_params) (mark (apply actual_function (map strip evaled_params)))
(array 'marked_array false (cons (array 'prim_comb recurse actual_function) evaled_params)))))) (marked_array false (cons (marked_prim_comb recurse f_sym) evaled_params))))))
) (array f_sym (array 'prim_comb handler actual_function))))) ) (array f_sym (marked_prim_comb handler f_sym)))))
(give_up_eval_params_inner (lambda (f_sym actual_function) (let* ( (give_up_eval_params_inner (lambda (f_sym actual_function) (let* (
(handler (rec-lambda recurse (de env_stack params indent) (let ( (handler (rec-lambda recurse (de env_stack params indent) (let (
;_ (println "partial_evaling params in give_up_eval_params for " f_sym " is " params) ;_ (println "partial_evaling params in give_up_eval_params for " f_sym " is " params)
(evaled_params (map (lambda (p) (partial_eval_helper p de env_stack (+ 1 indent))) params)) (evaled_params (map (lambda (p) (partial_eval_helper p de env_stack (+ 1 indent))) params))
) )
(array 'marked_array false (cons (array 'prim_comb recurse actual_function) evaled_params))))) (marked_array false (cons (marked_prim_comb recurse f_sym) evaled_params)))))
) (array f_sym (array 'prim_comb handler actual_function))))) ) (array f_sym (marked_prim_comb handler f_sym)))))
(root_marked_env (array 'env true nil (array (root_marked_env (marked_env true nil (array
; Ok, so for combinators, it should partial eval the body. (array 'vau (marked_prim_comb (rec-lambda recurse (de env_stack params indent) (dlet (
; It should then check to see mif the partial-evaled body has closed over
; any 'later values from above the combinator. If so, the combinator should
; evaluate to a ['later [vau de? params (strip partially_evaled_body)]], otherwise it can evaluate to a 'comb.
; Note that this 'later may be re-evaluated later mif the parent function is called.
(array 'vau (array 'prim_comb (rec-lambda recurse (de env_stack params indent) (dlet (
(mde? (mif (= 3 (len params)) (idx params 0) nil)) (mde? (mif (= 3 (len params)) (idx params 0) nil))
(vau_mde? (mif (= nil mde?) (array) (array mde?))) (vau_mde? (mif (= nil mde?) (array) (array mde?)))
(_ (print "mde? is " mde?)) (_ (print "mde? is " mde?))
@@ -441,36 +470,36 @@
(_ (print_strip (indent_str indent) "in vau, evaluating body with 'later params - " body)) (_ (print_strip (indent_str indent) "in vau, evaluating body with 'later params - " body))
(pe_body (partial_eval_helper body inner_env (cons inner_env env_stack) (+ 1 indent))) (pe_body (partial_eval_helper body inner_env (cons inner_env env_stack) (+ 1 indent)))
(_ (print_strip (indent_str indent) "in vau, result of evaluating body was " pe_body)) (_ (print_strip (indent_str indent) "in vau, result of evaluating body was " pe_body))
) (array 'comb 0 de? de variadic vau_params pe_body) ) (marked_comb 0 de? de variadic vau_params pe_body)
)) 'vau_fake_real)) )) 'vau_fake_real))
(array 'wrap (array 'prim_comb (parameters_evaled_proxy 0 (dlambda (recurse de env_stack (evaled) indent) (array 'wrap (marked_prim_comb (parameters_evaled_proxy 0 (dlambda (recurse de env_stack (evaled) indent)
(mif (comb? evaled) (dlet (((wrap_level de? se variadic params body) (.comb evaled)) (mif (comb? evaled) (dlet (((wrap_level de? se variadic params body) (.comb evaled))
(wrapped_marked_fun (array 'comb (+ 1 wrap_level) de? se variadic params body)) (wrapped_marked_fun (marked_comb (+ 1 wrap_level) de? se variadic params body))
) wrapped_marked_fun) ) wrapped_marked_fun)
(array 'marked_array false (array (array 'prim_comb recurse 'wrap_fake_real) evaled)))) (marked_array false (array (marked_prim_comb recurse 'wrap_fake_real) evaled))))
) 'wrap_fake_real)) ) 'wrap_fake_real))
(array 'unwrap (array 'prim_comb (parameters_evaled_proxy 0 (dlambda (recurse de env_stack (evaled) indent) (array 'unwrap (marked_prim_comb (parameters_evaled_proxy 0 (dlambda (recurse de env_stack (evaled) indent)
(mif (comb? evaled) (dlet (((wrap_level de? se variadic params body) (.comb evaled)) (mif (comb? evaled) (dlet (((wrap_level de? se variadic params body) (.comb evaled))
(unwrapped_marked_fun (array 'comb (- wrap_level 1) de? se variadic params body)) (unwrapped_marked_fun (marked_comb (- wrap_level 1) de? se variadic params body))
) unwrapped_marked_fun) ) unwrapped_marked_fun)
(array 'marked_array false (array (array 'prim_comb recurse 'unwrap_fake_real) evaled)))) (marked_array false (array (marked_prim_comb recurse 'unwrap_fake_real) evaled))))
) 'unwrap_fake_real)) ) 'unwrap_fake_real))
(array 'eval (array 'prim_comb (rec-lambda recurse (de env_stack params indent) (dlet ( (array 'eval (marked_prim_comb (rec-lambda recurse (de env_stack params indent) (dlet (
(self (array 'prim_comb recurse 'eval_fake_real)) (self (marked_prim_comb recurse 'eval_fake_real))
(eval_env (mif (= 2 (len params)) (partial_eval_helper (idx params 1) de env_stack (+ 1 indent)) (eval_env (mif (= 2 (len params)) (partial_eval_helper (idx params 1) de env_stack (+ 1 indent))
de)) de))
(eval_env_v (mif (= 2 (len params)) (array eval_env) (array))) (eval_env_v (mif (= 2 (len params)) (array eval_env) (array)))
) (mif (not (marked_env? eval_env)) (array 'marked_array false (cons self params)) ) (mif (not (marked_env? eval_env)) (marked_array false (cons self params))
(dlet ( (dlet (
(_ (print_strip (indent_str indent) " partial_evaling_body the first time " (idx params 0))) (_ (print_strip (indent_str indent) " partial_evaling_body the first time " (idx params 0)))
(body1 (partial_eval_helper (idx params 0) de env_stack (+ 1 indent))) (body1 (partial_eval_helper (idx params 0) de env_stack (+ 1 indent)))
(_ (print_strip (indent_str indent) "after first eval of param " body1)) (_ (print_strip (indent_str indent) "after first eval of param " body1))
; With this, we don't actually fail as this is always a legitimate uneval ; With this, we don't actually fail as this is always a legitimate uneval
(fail_handler (lambda (failed) (array 'marked_array false (concat (array self failed) eval_env_v)))) (fail_handler (lambda (failed) (marked_array false (concat (array self failed) eval_env_v))))
((ok unval_body) (try_unval body1 fail_handler)) ((ok unval_body) (try_unval body1 fail_handler))
(self_fallback (fail_handler body1)) (self_fallback (fail_handler body1))
(_ (print_strip (indent_str indent) "partial_evaling body for the second time in eval " unval_body)) (_ (print_strip (indent_str indent) "partial_evaling body for the second time in eval " unval_body))
@@ -482,10 +511,10 @@
;TODO: This could go a lot farther, not stopping after the first 'later, etc ;TODO: This could go a lot farther, not stopping after the first 'later, etc
; Also, GAH on odd params - but only one by one - a later odd param can't be imm_eval cuz it will ; Also, GAH on odd params - but only one by one - a later odd param can't be imm_eval cuz it will
; be frozen mif an earlier cond is 'later.... ; be frozen mif an earlier cond is 'later....
(array 'cond (array 'prim_comb (parameters_evaled_proxy nil (lambda (recurse de env_stack evaled_params indent) (array 'cond (marked_prim_comb (parameters_evaled_proxy nil (lambda (recurse de env_stack evaled_params indent)
(mif (!= 0 (% (len evaled_params) 2)) (error (str "partial eval cond with odd evaled_params " evaled_params)) (mif (!= 0 (% (len evaled_params) 2)) (error (str "partial eval cond with odd evaled_params " evaled_params))
((rec-lambda recurse_inner (i) ((rec-lambda recurse_inner (i)
(cond ((later? (idx evaled_params i)) (array 'marked_array false (cons (array 'prim_comb recurse 'cond_fake_real) (slice evaled_params i -1)))) (cond ((later? (idx evaled_params i)) (marked_array false (cons (marked_prim_comb recurse 'cond_fake_real) (slice evaled_params i -1))))
((false? (idx evaled_params i)) (recurse_inner (+ 2 i))) ((false? (idx evaled_params i)) (recurse_inner (+ 2 i)))
(true (idx evaled_params (+ 1 i)))) ; we could partially_eval again passing in immediate (true (idx evaled_params (+ 1 i)))) ; we could partially_eval again passing in immediate
; eval mif it was true, to partially counteract the above GAH ; eval mif it was true, to partially counteract the above GAH
@@ -497,17 +526,17 @@
(needs_params_val_lambda int?) (needs_params_val_lambda int?)
(needs_params_val_lambda string?) (needs_params_val_lambda string?)
(array 'combiner? (array 'prim_comb (parameters_evaled_proxy nil (dlambda (recurse de env_stack (evaled_param) indent) (array 'combiner? (marked_prim_comb (parameters_evaled_proxy nil (dlambda (recurse de env_stack (evaled_param) indent)
(cond ((comb? evaled_param) (array 'val true)) (cond ((comb? evaled_param) (marked_val true))
((prim_comb? evaled_param) (array 'val true)) ((prim_comb? evaled_param) (marked_val true))
((later? evaled_param) (array 'marked_array false (array (array 'prim_comb recurse 'combinerp_fake_Real) evaled_param))) ((later? evaled_param) (marked_array false (array (marked_prim_comb recurse 'combinerp_fake_real) evaled_param)))
(true (array 'val false)) (true (marked_val false))
) )
)) 'combinerp_fake_real)) )) 'combinerp_fake_real))
(array 'env? (array 'prim_comb (parameters_evaled_proxy nil (dlambda (recurse de env_stack (evaled_param) indent) (array 'env? (marked_prim_comb (parameters_evaled_proxy nil (dlambda (recurse de env_stack (evaled_param) indent)
(cond ((marked_env? evaled_param) (array 'val true)) (cond ((marked_env? evaled_param) (marked_val true))
((later? evaled_param) (array 'marked_array false (array (array 'prim_comb recurse 'envp_fake_real) evaled_param))) ((later? evaled_param) (marked_array false (array (marked_prim_comb recurse 'envp_fake_real) evaled_param)))
(true (array 'val false)) (true (marked_val false))
) )
)) 'envp_fake_real)) )) 'envp_fake_real))
(needs_params_val_lambda nil?) (needs_params_val_lambda nil?)
@@ -515,43 +544,43 @@
(needs_params_val_lambda str-to-symbol) (needs_params_val_lambda str-to-symbol)
(needs_params_val_lambda get-text) (needs_params_val_lambda get-text)
(array 'array? (array 'prim_comb (parameters_evaled_proxy nil (dlambda (recurse de env_stack (evaled_param) indent) (array 'array? (marked_prim_comb (parameters_evaled_proxy nil (dlambda (recurse de env_stack (evaled_param) indent)
(cond (cond
((later? evaled_param) (array 'marked_array false (array (array 'prim_comb recurse 'arrayp_fake_real) evaled_param))) ((later? evaled_param) (marked_array false (array (marked_prim_comb recurse 'arrayp_fake_real) evaled_param)))
((marked_array? evaled_param) (array 'val true)) ((marked_array? evaled_param) (marked_val true))
(true (array 'val false)) (true (marked_val false))
) )
)) 'arrayp_fake_real)) )) 'arrayp_fake_real))
; This one's sad, might need to come back to it. ; This one's sad, might need to come back to it.
; We need to be able to differentiate between half-and-half arrays ; We need to be able to differentiate between half-and-half arrays
; for when we ensure_params_values or whatever, because that's super wrong ; for when we ensure_params_values or whatever, because that's super wrong
(array 'array (array 'prim_comb (parameters_evaled_proxy nil (lambda (recurse de env_stack evaled_params indent) (array 'array (marked_prim_comb (parameters_evaled_proxy nil (lambda (recurse de env_stack evaled_params indent)
(mif (is_all_values evaled_params) (array 'marked_array true evaled_params) (mif (is_all_values evaled_params) (marked_array true evaled_params)
(array 'marked_array false (cons (array 'prim_comb recurse 'array_fake_real) evaled_params))) (marked_array false (cons (marked_prim_comb recurse 'array_fake_real) evaled_params)))
)) 'array_fake_real)) )) 'array_fake_real))
(array 'len (array 'prim_comb (parameters_evaled_proxy nil (dlambda (recurse de env_stack (evaled_param) indent) (array 'len (marked_prim_comb (parameters_evaled_proxy nil (dlambda (recurse de env_stack (evaled_param) indent)
(cond ((later? evaled_param) (array 'marked_array false (array (array 'prim_comb recurse 'len_fake_real) evaled_param))) (cond ((later? evaled_param) (marked_array false (array (marked_prim_comb recurse 'len_fake_real) evaled_param)))
((marked_array? evaled_param) (array 'val (len (.marked_array_values evaled_param)))) ((marked_array? evaled_param) (marked_val (len (.marked_array_values evaled_param))))
(true (error (str "bad type to len " evaled_param))) (true (error (str "bad type to len " evaled_param)))
) )
)) 'len_fake_real)) )) 'len_fake_real))
(array 'idx (array 'prim_comb (parameters_evaled_proxy nil (dlambda (recurse de env_stack (evaled_array evaled_idx) indent) (array 'idx (marked_prim_comb (parameters_evaled_proxy nil (dlambda (recurse de env_stack (evaled_array evaled_idx) indent)
(cond ((and (val? evaled_idx) (marked_array? evaled_array) (.marked_array_is_val evaled_array)) (idx (.marked_array_values evaled_array) (.val evaled_idx))) (cond ((and (val? evaled_idx) (marked_array? evaled_array) (.marked_array_is_val evaled_array)) (idx (.marked_array_values evaled_array) (.val evaled_idx)))
(true (array 'marked_array false (array (array 'prim_comb recurse 'idx_fake_real) evaled_array evaled_idx))) (true (marked_array false (array (marked_prim_comb recurse 'idx_fake_real) evaled_array evaled_idx)))
) )
)) 'idx_fake_real)) )) 'idx_fake_real))
(array 'slice (array 'prim_comb (parameters_evaled_proxy nil (dlambda (recurse de env_stack (evaled_array evaled_begin evaled_end) indent) (array 'slice (marked_prim_comb (parameters_evaled_proxy nil (dlambda (recurse de env_stack (evaled_array evaled_begin evaled_end) indent)
(cond ((and (val? evaled_begin) (val? evaled_end) (marked_array? evaled_array) (.marked_array_is_val evaled_array)) (cond ((and (val? evaled_begin) (val? evaled_end) (marked_array? evaled_array) (.marked_array_is_val evaled_array))
(array 'marked_array true (slice (.marked_array_values evaled_array) (.val evaled_begin) (.val evaled_end)))) (marked_array true (slice (.marked_array_values evaled_array) (.val evaled_begin) (.val evaled_end))))
(true (array 'marked_array false (array (array 'prim_comb recurse 'slice_fake_real) evaled_array evaled_idx evaled_begin evaled_end))) (true (marked_array false (array (marked_prim_comb recurse 'slice_fake_real) evaled_array evaled_idx evaled_begin evaled_end)))
) )
)) 'slice_fake_real)) )) 'slice_fake_real))
(array 'concat (array 'prim_comb (parameters_evaled_proxy nil (lambda (recurse de env_stack evaled_params indent) (array 'concat (marked_prim_comb (parameters_evaled_proxy nil (lambda (recurse de env_stack evaled_params indent)
(cond ((foldl (lambda (a x) (and a (and (marked_array? x) (.marked_array_is_val x)))) true evaled_params) (array 'marked_array true (lapply concat (map (lambda (x) (cond ((foldl (lambda (a x) (and a (and (marked_array? x) (.marked_array_is_val x)))) true evaled_params) (marked_array true (lapply concat (map (lambda (x)
(.marked_array_values x)) (.marked_array_values x))
evaled_params)))) evaled_params))))
(true (array 'marked_array false (cons (array 'prim_comb recurse 'concat_fake_real) evaled_params))) (true (marked_array false (cons (marked_prim_comb recurse 'concat_fake_real) evaled_params)))
) )
)) 'concat_fake_real)) )) 'concat_fake_real))
@@ -572,19 +601,19 @@
(needs_params_val_lambda >=) (needs_params_val_lambda >=)
; these could both be extended to eliminate other known true values except for the end and vice-versa ; these could both be extended to eliminate other known true values except for the end and vice-versa
(array 'and (array 'prim_comb (parameters_evaled_proxy nil (lambda (recurse de env_stack evaled_params indent) (array 'and (marked_prim_comb (parameters_evaled_proxy nil (lambda (recurse de env_stack evaled_params indent)
((rec-lambda inner_recurse (i) ((rec-lambda inner_recurse (i)
(cond ((= i (- (len evaled_params) 1)) (idx evaled_params i)) (cond ((= i (- (len evaled_params) 1)) (idx evaled_params i))
((later? (idx evaled_params i)) (array 'marked_array false (cons (array 'prim_comb recurse 'and_fake_real) (slice evaled_params i -1)))) ((later? (idx evaled_params i)) (marked_array false (cons (marked_prim_comb recurse 'and_fake_real) (slice evaled_params i -1))))
((false? (idx evaled_params i)) (idx evaled_params i)) ((false? (idx evaled_params i)) (idx evaled_params i))
(true (inner_recurse (+ 1 i)))) (true (inner_recurse (+ 1 i))))
) 0) ) 0)
)) 'and_fake_real)) )) 'and_fake_real))
; see above for improvement ; see above for improvement
(array 'or (array 'prim_comb (parameters_evaled_proxy nil (lambda (recurse de env_stack evaled_params indent) (array 'or (marked_prim_comb (parameters_evaled_proxy nil (lambda (recurse de env_stack evaled_params indent)
((rec-lambda inner_recurse (i) ((rec-lambda inner_recurse (i)
(cond ((= i (- (len evaled_params) 1)) (idx evaled_params i)) (cond ((= i (- (len evaled_params) 1)) (idx evaled_params i))
((later? (idx evaled_params i)) (array 'marked_array false (cons (array 'prim_comb recurse 'or_fake_real) (slice evaled_params i -1)))) ((later? (idx evaled_params i)) (marked_array false (cons (marked_prim_comb recurse 'or_fake_real) (slice evaled_params i -1))))
((false? (idx evaled_params i)) (recurse (+ 1 i))) ((false? (idx evaled_params i)) (recurse (+ 1 i)))
(true (idx evaled_params i))) (true (idx evaled_params i)))
) 0) ) 0)
@@ -606,7 +635,7 @@
;(give_up_eval_params slurp) ;(give_up_eval_params slurp)
;(give_up_eval_params get_line) ;(give_up_eval_params get_line)
;(give_up_eval_params write_file) ;(give_up_eval_params write_file)
(array 'empty_env (array 'env true nil (array nil))) (array 'empty_env (marked_env true nil (array nil)))
nil nil
))) )))
@@ -616,7 +645,12 @@
(test-all (lambda () (let* ( (test-all (lambda () (let* (
(run_test (lambda (s) (begin (print "\n\ngoing to partial eval " s) (print "result of test \"" s "\" => " (str_strip (partial_eval (read-string s))))))) (run_test (lambda (s) (let* (
(_ (print "\n\ngoing to partial eval " s))
(result (partial_eval (read-string s)))
(_ (print "result of test \"" s "\" => " (str_strip result)))
(_ (print "with a hash of " (.hash result)))
) nil)))
) (begin ) (begin
(print (val? '(val))) (print (val? '(val)))
(print "take 3" (take '(1 2 3 4 5 6 7 8 9 10) 3)) (print "take 3" (take '(1 2 3 4 5 6 7 8 9 10) 3))
@@ -700,15 +734,18 @@
(let1 a 12 (wrap (vau (x) (let1 y (+ x a 1) (+ y x a)))) (let1 a 12 (wrap (vau (x) (let1 y (+ x a 1) (+ y x a))))
))) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de)))")) ))) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de)))"))
(print "\n\nlambda 1\n\n")
(print (run_test "((wrap (vau (let1) (print (run_test "((wrap (vau (let1)
(let1 lambda (vau se (p b) (wrap (eval (array vau p b) se))) (let1 lambda (vau se (p b) (wrap (eval (array vau p b) se)))
(lambda (x) x) (lambda (x) x)
))) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de)))")) ))) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de)))"))
(print "\n\nlambda 2\n\n")
(print (run_test "((wrap (vau (let1) (print (run_test "((wrap (vau (let1)
(let1 lambda (vau se (p b) (wrap (eval (array vau p b) se))) (let1 lambda (vau se (p b) (wrap (eval (array vau p b) se)))
(let1 a 12 (let1 a 12
(lambda (x) (+ a x))) (lambda (x) (+ a x)))
))) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de)))")) ))) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de)))"))
(print "\n\nlambda 3\n\n")
(print (run_test "((wrap (vau (let1) (print (run_test "((wrap (vau (let1)
(let1 lambda (vau se (p b) (wrap (eval (array vau p b) se))) (let1 lambda (vau se (p b) (wrap (eval (array vau p b) se)))
(let1 a 12 (let1 a 12
@@ -719,6 +756,13 @@
(print (run_test "(array 1 2 3 4 5)")) (print (run_test "(array 1 2 3 4 5)"))
(print (run_test "((wrap (vau (a & rest) rest)) 1 2 3 4 5)")) (print (run_test "((wrap (vau (a & rest) rest)) 1 2 3 4 5)"))
;(print "\n\nrecursion test\n\n")
;(print (run_test "((wrap (vau (let1)
; (let1 lambda (vau se (p b) (wrap (eval (array vau p b) se)))
; ((lambda (x n) (x x n)) (lambda (recurse n) (cond n (* n (recurse recurse (- n 1)))
; true 1 )) 5)
; ))) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de)))"))
)))) ))))
) (test-all)) ) (test-all))