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

Added support for strings to array functions for evaluator (compiled is next)

Browse Source
This commit is contained in:
Nathan Braswell
2022-03-12 20:19:00 -05:00
parent d87f292c1c
commit d1b6e520f9
2 changed files with 44 additions and 33 deletions
Download Patch File Download Diff File Expand all files Collapse all files

70
partial_eval.scm
View File

@@ -75,7 +75,8 @@
(len (lambda (x) (cond ((list? x) (length x)) (len (lambda (x) (cond ((list? x) (length x))
((string? x) (string-length x)) ((string? x) (string-length x))
(#t (error "bad value to len"))))) (#t (error "bad value to len")))))
(idx (lambda (x i) (list-ref x (if (< i 0) (+ i (len x)) i)))) (idx (lambda (x i) (cond ((list? x) (list-ref x (if (< i 0) (+ i (len x)) i)))
((string? x) (char->integer (list-ref (string->list x) (if (< i 0) (+ i (len x)) i)))))))
(false #f) (false #f)
(true #t) (true #t)
(nil '()) (nil '())
@@ -118,7 +119,8 @@
(s (if (< s 0) (+ s l 1) s)) (s (if (< s 0) (+ s l 1) s))
(e (if (< e 0) (+ e l 1) e)) (e (if (< e 0) (+ e l 1) e))
(t (- e s)) ) (t (- e s)) )
(take (drop x s) t)))) (if (list? x) (take (drop x s) t)
(list->string (take (drop (string->list x) s) t))))))
(range (rec-lambda recurse (a b) (range (rec-lambda recurse (a b)
(cond ((= a b) nil) (cond ((= a b) nil)
((< a b) (cons a (recurse (+ a 1) b))) ((< a b) (cons a (recurse (+ a 1) b)))
@@ -405,7 +407,7 @@
) (array 'env (hash_env has_vals progress_idxs dbi full_arrs) has_vals (array progress_idxs nil extra) dbi full_arrs)))) ) (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_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_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))) (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)))
@@ -1007,29 +1009,35 @@
) 'array 1 false)) ) 'array 1 false))
(array 'len (marked_prim_comb (dlambda (only_head de env_stack pectx (evaled_param) indent) (array 'len (marked_prim_comb (dlambda (only_head de env_stack pectx (evaled_param) indent)
(cond (cond
((marked_array? evaled_param) (array pectx nil (marked_val (len (.marked_array_values evaled_param))))) ((marked_array? evaled_param) (array pectx nil (marked_val (len (.marked_array_values evaled_param)))))
(true (array pectx (str "bad type to len " evaled_param) nil)) ((and (val? evaled_param)
(string? (.val evaled_param))) (array pectx nil (marked_val (len (.val evaled_param)))))
(true (array pectx (str "bad type to len " evaled_param) nil))
) )
) '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)) (array pectx nil (idx (.marked_array_values evaled_array) (.val evaled_idx))))
(true (array pectx "bad type to 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)))))
(true (array pectx (str "bad type to idx " evaled_idx " " evaled_array) nil))
) )
) 'idx 1 true)) ) 'idx 1 true))
(array 'slice (marked_prim_comb (dlambda (only_head de env_stack pectx (evaled_array evaled_begin evaled_end) indent) (array 'slice (marked_prim_comb (dlambda (only_head de env_stack pectx (evaled_array evaled_begin evaled_end) indent)
(cond (cond
((and (val? evaled_begin) (val? evaled_end) (marked_array? evaled_array)) ((and (val? evaled_begin) (val? evaled_end) (marked_array? evaled_array))
(array pectx nil (marked_array true false nil (slice (.marked_array_values evaled_array) (.val evaled_begin) (.val evaled_end))))) (array pectx nil (marked_array true false nil (slice (.marked_array_values evaled_array) (.val evaled_begin) (.val evaled_end)))))
(true (array pectx "bad params to slice" nil)) ((and (val? evaled_begin) (val? evaled_end) (val? evaled_array) (string? (.val evaled_array)))
(array pectx nil (marked_val (slice (.val evaled_array) (.val evaled_begin) (.val evaled_end)))))
(true (array pectx (str "bad params to slice " evaled_begin " " evaled_end " " evaled_array) nil))
) )
) 'slice 1 true)) ) 'slice 1 true))
(array 'concat (marked_prim_comb (lambda (only_head de env_stack pectx evaled_params indent) (array 'concat (marked_prim_comb (lambda (only_head de env_stack pectx evaled_params indent)
(cond (cond
((foldl (lambda (a x) (and a (marked_array? x))) true evaled_params) (array pectx nil (marked_array true false nil (lapply concat (map (lambda (x) ((foldl (lambda (a x) (and a (marked_array? x))) true evaled_params)
(.marked_array_values x)) (array pectx nil (marked_array true false nil (lapply concat (map (lambda (x) (.marked_array_values x)) evaled_params)))))
evaled_params))))) ((foldl (lambda (a x) (and a (val? x) (string? (.val x)))) true evaled_params)
(true (array pectx "bad params to concat" nil)) (array pectx nil (marked_val (lapply concat (map (lambda (x) (.val x)) evaled_params)))))
(true (array pectx (str "bad params to concat " evaled_params) nil))
) )
) 'concat 1 true)) ) 'concat 1 true))
@@ -4144,8 +4152,8 @@
(run_partial_eval_test (lambda (s) (dlet ( (run_partial_eval_test (lambda (s) (dlet (
(_ (print "\n\ngoing to partial eval " s)) (_ (print "\n\ngoing to partial eval " s))
((pectx err result) (partial_eval (read-string s))) ((pectx err result) (partial_eval (read-string s)))
(_ (print "result of test \"" s "\" => " (str_strip result) " and err " err)) (_ (true_print "result of test \"" s "\" => " (true_str_strip result) " and err " err))
(_ (print "with a hash of " (.hash result))) ;(_ (mif result (true_print "with a hash of " (.hash result))))
) nil))) ) nil)))
@@ -4522,19 +4530,26 @@
; ))) (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)))"))))
(output3 (compile (partial_eval (read-string ;(output3 (compile (partial_eval (read-string
"((wrap (vau root_env (quote) ; "((wrap (vau root_env (quote)
((wrap (vau (let1) ; ((wrap (vau (let1)
; (let1 lambda (vau se (p b) (wrap (eval (array vau p b) se)))
; (let1 current-env (vau de () de)
; (let1 lapply (lambda (f p) (eval (concat (array (unwrap f)) p) (current-env)))
; (array (quote write) 1 \"test_self_out2\" (vau (written code) 1))
; )))
; )) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de)))
; )) (vau (x5) x5))"))))
;(_ (write_file "./csc_out.wasm" output3))
(print (run_partial_eval_test "(len \"asdf\")"))
(print (run_partial_eval_test "(idx \"asdf\" 1)"))
(print (run_partial_eval_test "(slice \"asdf\" 1 3)"))
(print (run_partial_eval_test "(concat \"asdf\" \";lkj\")"))
(let1 lambda (vau se (p b) (wrap (eval (array vau p b) se)))
(let1 current-env (vau de () de)
(let1 lapply (lambda (f p) (eval (concat (array (unwrap f)) p) (current-env)))
(array (quote write) 1 \"test_self_out2\" (vau (written code) 1))
)))
)) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de)))
)) (vau (x5) x5))"))))
(_ (write_file "./csc_out.wasm" output3))
) void))) ) void)))
(run-compiler (lambda (f) (run-compiler (lambda (f)
@@ -4559,8 +4574,9 @@
;(run-compiler "to_compile.kp") ;(run-compiler "to_compile.kp")
(true_print "args are " args) (true_print "args are " args)
(dlet ( (com (if (> (len args) 0) (idx args 0) "")) ) (dlet ( (com (if (> (len args) 0) (idx args 0) "")) )
(if (= "test" com) (test-most) (cond ((= "test" com) (test-most))
(run-compiler com))) ((= "single" com) (single-test))
(true (run-compiler com))))
;(true_print "GLOBAL_MAX was " GLOBAL_MAX) ;(true_print "GLOBAL_MAX was " GLOBAL_MAX)
;(profile-dump-html) ;(profile-dump-html)

7
to_compile.kp
View File

@@ -826,12 +826,7 @@
(implicit_env (drop_redundent_veval partial_eval_helper ebody de env_stack pectx indent)) (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)) ((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 (true (drop_redundent_veval partial_eval_helper (marked_array false true nil (array
; HMMMMM
; This fails because we haven't implemented for
; array like stuff for string, including len
(marked_prim_comb recurse 'veval -1 true) (marked_prim_comb recurse 'veval -1 true)
;
;(marked_array false true nil (array ))
ebody ebody
eval_env eval_env
)) ))
@@ -845,7 +840,7 @@
(and_fold (foldl and true '(true true false true))) (and_fold (foldl and true '(true true false true)))
(monad (array 'write 1 (str "Hello from compiled code! " and_fold "\n") (vau (written code) (array 'exit 0)))) (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) ) monad)
) )