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

Fix cond to not die on guarded errors, implement a new if in macro-style, port some more over to_compile.kp. Stopped just before 'vau, which seems to loop forever or somesuch

Browse Source
This commit is contained in:
Nathan Braswell
2022-03-13 15:11:30 -04:00
parent 947d854ebb
commit 1b220023bc
2 changed files with 58 additions and 18 deletions
Download Patch File Download Diff File Expand all files Collapse all files

29
partial_eval.scm
View File

@@ -7,7 +7,7 @@
; Chez ; Chez
(define print pretty-print) (define arithmetic-shift bitwise-arithmetic-shift) (define foldl fold-left) (define foldr fold-right) (define write_file (lambda (file bytes) (let* ( (port (open-file-output-port file)) (_ (foldl (lambda (_ o) (put-u8 port o)) (void) bytes)) (_ (close-port port))) '()))) (define args (cdr (command-line))) (define print pretty-print) (define arithmetic-shift bitwise-arithmetic-shift) (define foldl fold-left) (define foldr fold-right) (define write_file (lambda (file bytes) (let* ( (port (open-file-output-port file)) (_ (foldl (lambda (_ o) (put-u8 port o)) (void) bytes)) (_ (close-port port))) '()))) (define args (cdr (command-line)))
(compile-profile 'source) ;(compile-profile 'source)
; Gambit - Gambit also has a problem with the dlet definition (somehow recursing and making (cdr nil) for (cdr ls)?), even if using the unstable one that didn't break syntax-rules ; Gambit - Gambit also has a problem with the dlet definition (somehow recursing and making (cdr nil) for (cdr ls)?), even if using the unstable one that didn't break syntax-rules
;(define print pretty-print) ;(define print pretty-print)
@@ -788,7 +788,8 @@
((!= nil param_err) (array pectx param_err nil)) ((!= nil param_err) (array pectx param_err nil))
((not ok_and_non_later) (array pectx nil (l_later_call_array))) ((not ok_and_non_later) (array pectx nil (l_later_call_array)))
((prim_comb? comb) (dlet ( ((prim_comb? comb) (dlet (
(_ (println (indent_str indent) "Calling prim comb " (.prim_comb_sym comb))) ;(_ (println (indent_str indent) "Calling prim comb " (.prim_comb_sym comb)))
;(_ (if (= '!= (.prim_comb_sym comb)) (true_print (indent_str indent) "Calling prim comb " (.prim_comb_sym comb) " with params " evaled_params)))
((pectx err result) ((.prim_comb_handler comb) only_head env env_stack pectx evaled_params (+ 1 indent))) ((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)) ) (if (= 'LATER err) (array pectx nil (l_later_call_array))
(array pectx err result)))) (array pectx err result))))
@@ -952,21 +953,23 @@
(already_in (!= false (get-value-or-false memo hash))) (already_in (!= false (get-value-or-false memo hash)))
(_ (if already_in (print_strip "ALREADY IN " this) (_ (if already_in (print_strip "ALREADY IN " this)
(print_strip "NOT ALREADY IN, CONTINUING with " this))) (print_strip "NOT ALREADY IN, CONTINUING with " this)))
((pectx err evaled_params later_hash) (if already_in ; WE SHOULDN'T DIE ON ERROR, since these errors may be guarded by conditions we
; can't evaluate. We'll keep branches that error as un-valed only
((pectx _err evaled_params later_hash) (if already_in
(array pectx nil (map (lambda (x) (dlet (((ok ux) (try_unval x (lambda (_) nil))) (array pectx nil (map (lambda (x) (dlet (((ok ux) (try_unval x (lambda (_) nil)))
(_ (if (not ok) (error "BAD cond un")))) (_ (if (not ok) (error "BAD cond un"))))
ux)) ux))
sliced_params) hash) sliced_params) hash)
(foldl (dlambda ((pectx err as later_hash) x) (foldl (dlambda ((pectx _err as later_hash) x)
(dlet (((pectx er a) (eval_helper x pectx))) (dlet (((pectx er a) (eval_helper x pectx)))
(array pectx (mif err err er) (concat as (array a)) later_hash)) (mif er (dlet (((ok ux) (if already_stripped (array true x) (try_unval x (lambda (_) nil))))
) (array (array env_counter (put memo hash nil)) err (array) nil) sliced_params))) (_ (if (not ok) (error (str "BAD cond un" x)))))
(array pectx nil (concat as (array ux)) later_hash))
(array pectx nil (concat as (array a)) later_hash)))
) (array (array env_counter (put memo hash nil)) nil (array) nil) sliced_params)))
((env_counter omemo) pectx) ((env_counter omemo) pectx)
(pectx (array env_counter memo)) (pectx (array env_counter memo))
) (array pectx err (mif err nil (marked_array false true later_hash (concat (array (marked_prim_comb (recurse true) 'vcond -1 true) ) (array pectx nil (marked_array false true later_hash (concat (array (marked_prim_comb (recurse true) 'vcond -1 true) pred) evaled_params)))))
pred)
evaled_params
))))))
((and (< (+ 2 i) (len params)) (false? pred)) (recurse_inner (+ 2 i) so_far pectx)) ((and (< (+ 2 i) (len params)) (false? pred)) (recurse_inner (+ 2 i) so_far pectx))
( (false? pred) (array pectx "comb reached end with no true" nil)) ( (false? pred) (array pectx "comb reached end with no true" nil))
(true (eval_helper (idx params (+ i 1)) pectx)) (true (eval_helper (idx params (+ i 1)) pectx))
@@ -1017,7 +1020,9 @@
) 'len 1 true)) ) 'len 1 true))
(array 'idx (marked_prim_comb (dlambda (only_head de env_stack pectx (evaled_array evaled_idx) indent) (array 'idx (marked_prim_comb (dlambda (only_head de env_stack pectx (evaled_array evaled_idx) indent)
(cond (cond
((and (val? evaled_idx) (marked_array? evaled_array)) (array pectx nil (idx (.marked_array_values evaled_array) (.val evaled_idx)))) ((and (val? evaled_idx) (marked_array? evaled_array)) (if (< (.val evaled_idx) (len (.marked_array_values evaled_array)))
(array pectx nil (idx (.marked_array_values evaled_array) (.val evaled_idx)))
(array pectx (true_str "idx out of bounds " evaled_array " " evaled_idx) nil)))
((and (val? evaled_idx) (val? evaled_array) (string? (.val evaled_array))) (array pectx nil (marked_val (idx (.val evaled_array) (.val evaled_idx))))) ((and (val? evaled_idx) (val? evaled_array) (string? (.val evaled_array))) (array pectx nil (marked_val (idx (.val evaled_array) (.val evaled_idx)))))
(true (array pectx (str "bad type to idx " evaled_idx " " evaled_array) nil)) (true (array pectx (str "bad type to idx " evaled_idx " " evaled_array) nil))
) )
@@ -4678,7 +4683,7 @@
(true (run-compiler com)))) (true (run-compiler com))))
;(true_print "GLOBAL_MAX was " GLOBAL_MAX) ;(true_print "GLOBAL_MAX was " GLOBAL_MAX)
(profile-dump-html) ;(profile-dump-html)
) )
) )

47
to_compile.kp
View File

@@ -14,9 +14,12 @@
(let ( (let (
lcompose (lambda (g f) (lambda (& args) (lapply g (array (lapply f args))))) lcompose (lambda (g f) (lambda (& args) (lapply g (array (lapply f args)))))
rec-lambda (vau se (n p b) (eval (array Y (array lambda (array n) (array lambda p b))) se)) rec-lambda (vau se (n p b) (eval (array Y (array lambda (array n) (array lambda p b))) se))
if (vau de (con than & else) (cond (eval con de) (eval than de) ;if (vau de (con than & else) (cond (eval con de) (eval than de)
(> (len else) 0) (eval (idx else 0) de) ; (> (len else) 0) (eval (idx else 0) de)
true false)) ; true false))
if (vau de (con than & else) (eval (array cond con than
true (cond (> (len else) 0) (idx else 0)
true false)) de))
map (lambda (f5 l5) map (lambda (f5 l5)
; now maybe errors on can't find helper? ; now maybe errors on can't find helper?
@@ -153,7 +156,7 @@
print log print log
println log println log
dlambda lambda dlambda lambda
mif (vau de (c & bs) (vapply if (cons (array let (array 'tmp c) (array and (array != 'tmp) 'tmp)) bs) de)) mif (vau de (c & bs) (vapply if (cons (array let (array 'tmp c) (array and (array != 'tmp (array quote (array))) 'tmp)) bs) de))
;mif (vau de (c & bs) (eval (concat (array if (array let (array 'tmp c) (array and (array != 'tmp) 'tmp))) bs) de)) ;mif (vau de (c & bs) (eval (concat (array if (array let (array 'tmp c) (array and (array != 'tmp) 'tmp))) bs) de))
@@ -834,13 +837,45 @@
)))) ))))
(root_marked_env (marked_env true nil nil nil nil (array
(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))
(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))
(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)))) (array 'empty_env (marked_env true nil nil nil nil nil))
)))
;(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)))))
) monad) ) monad)
) )