From 3f26a3ad7d229db991b68dc17cb0845fe7108358 Mon Sep 17 00:00:00 2001 From: Nathan Braswell Date: Mon, 28 Feb 2022 00:26:30 -0500 Subject: [PATCH] Finish porting mif and fixing up other inconsistancies. Fix bug for emitting signed numbers as hex in compile. Runs correctly in both Chez and Chicken interpreter now, which Chez being about 3x faster --- partial_eval.csc | 4406 ---------------------------------------------- partial_eval.scm | 4340 ++++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 4289 insertions(+), 4457 deletions(-) delete mode 100644 partial_eval.csc diff --git a/partial_eval.csc b/partial_eval.csc deleted file mode 100644 index 2630373..0000000 --- a/partial_eval.csc +++ /dev/null @@ -1,4406 +0,0 @@ -(import (chicken process-context)) -(import (chicken port)) -(import (chicken io)) -(import (chicken bitwise)) -(import (chicken string)) -(import (r5rs)) -(define-syntax rec-lambda - (er-macro-transformer - (lambda (x r c) - (let ( - (name (car (cdr x))) - (params (car (cdr (cdr x)))) - (body (car (cdr (cdr (cdr x))))) - ) - `(rec ,name (lambda ,params ,body)))))) - -(define-syntax dlet - (er-macro-transformer - (lambda (x r c) - (let* ( - (items (list-ref x 1)) - (body (list-ref x 2)) - (flat_map_i (lambda (f l) ((rec recurse (lambda (f l i) (cond - ((equal? '() l) '()) - (#t (append (f i (car l)) (recurse f (cdr l) (+ i 1))))) - )) f l 0))) - (flatten-helper (rec recurse (lambda (items) - (cond - ((equal? '() items) '()) - (#t (let* ( - (clause (car items)) - (result (cond - ((list? (car clause)) (let ((s (gensym 'dlet_s))) - (cons `(,s ,(car (cdr clause))) - (flat_map_i (lambda (i x) - (recurse `((,x (list-ref ,s ,i)))) - ) - (car clause))))) - (#t (list clause)))) - ) (append result (recurse (cdr items))))) - )))) - - (flat_items (flatten-helper items)) - ) `(let* ,flat_items ,body) - )))) -(define-syntax dlambda - (er-macro-transformer - (lambda (x r c) - (let ( - (params (list-ref x 1)) - (param_sym (gensym 'dlambda_s)) - (body (list-ref x 2)) - ) - `(lambda ,param_sym (dlet ( (,params ,param_sym) ) ,body)))))) - -(define-syntax needs_params_val_lambda - (er-macro-transformer - (lambda (x r c) - (let ((f_sym (list-ref x 1))) - `(needs_params_val_lambda_inner ',f_sym ,f_sym))))) - - -(define-syntax give_up_eval_params - (er-macro-transformer - (lambda (x r c) - (let ((f_sym (list-ref x 1))) - `(give_up_eval_params_inner ',f_sym ,f_sym))))) - - -(define-syntax mif - (er-macro-transformer - (lambda (x r c) - (let ( - (cond (list-ref x 1)) - (v (gensym 'mif_s)) - (then (list-ref x 2)) - (else (if (equal? 4 (length x)) (list-ref x 3) ''())) - ) - `(let ((,v ,cond)) (if (and (not (equal? (array) ,v)) ,v) ,then ,else)))))) - -; Adapted from https://stackoverflow.com/questions/16335454/reading-from-file-using-scheme WTH -(define (slurp path) - (list->string (call-with-input-file path - (lambda (input-port) - (let loop ((x (read-char input-port))) - (cond - ((eof-object? x) '()) - (#t (begin (cons x (loop (read-char input-port))))))))))) - -(let* ( - (lapply apply) - (= equal?) - (!= (lambda (a b) (not (= a b)))) - (array list) - (array? list?) - (concat (lambda args (cond ((equal? (length args) 0) (list)) - ((list? (list-ref args 0)) (apply append args)) - ((string? (list-ref args 0)) (apply conc args)) - (#t (begin (print "the bad concat is " args) (error "bad value to concat")))))) - (len (lambda (x) (cond ((list? x) (length x)) - ((string? x) (string-length x)) - (#t (begin (print "the bad len is " x) (error "bad value to len")))))) - (idx (lambda (x i) (list-ref x (mif (< i 0) (+ i (len x)) i)))) - (false #f) - (true #t) - (nil '()) - (str-to-symbol string->symbol) - (get-text symbol->string) - - (bor bitwise-ior) - (band bitwise-and) - (bxor bitwise-xor) - (bnot bitwise-not) - (<< arithmetic-shift) - (>> (lambda (a b) (arithmetic-shift a (- b)))) - - - (nil? (lambda (x) (= nil x))) - (bool? (lambda (x) (or (= #t x) (= #f x)))) - (true_print print) - (print (lambda x 0)) - ;(true_print print) - (println print) - - (read-string (lambda (s) (read (open-input-string s)))) - - (zip (lambda args (apply map list args))) - - (empty_dict (array)) - (put (lambda (m k v) (cons (array k v) m))) - (get-value (lambda (d k) (let ((result (alist-ref k d))) - (if (array? result) (idx result 0) - (error (print "could not find " k " in " d)))))) - (get-value-or-false (lambda (d k) (let ((result (alist-ref k d))) - (if (array? result) (idx result 0) - false)))) - - (% modulo) - (int? integer?) - (str? string?) - (env? (lambda (x) false)) - (combiner? (lambda (x) false)) - (drop (rec-lambda recurse (x i) (mif (= 0 i) x (recurse (cdr x) (- i 1))))) - (take (rec-lambda recurse (x i) (mif (= 0 i) (array) (cons (car x) (recurse (cdr x) (- i 1)))))) - (slice (lambda (x s e) (let* ( (l (len x)) - (s (mif (< s 0) (+ s l 1) s)) - (e (mif (< e 0) (+ e l 1) e)) - (t (- e s)) ) - (take (drop x s) t)))) - (range (rec-lambda recurse (a b) - (cond ((= a b) nil) - ((< a b) (cons a (recurse (+ a 1) b))) - (true (cons a (recurse (- a 1) b))) - ))) - (filter (rec-lambda recurse (f l) (cond ((nil? l) nil) - ((f (car l)) (cons (car l) (recurse f (cdr l)))) - (true (recurse f (cdr l)))))) - - (flat_map (lambda (f l) ((rec recurse (lambda (f l) (cond - ((equal? '() l) '()) - (#t (append (f (car l)) (recurse f (cdr l))))) - )) f l))) - (str (lambda args (begin - (define mp (open-output-string)) - ((rec-lambda recurse (x) (mif x (begin (display (car x) mp) (recurse (cdr x))) nil)) args) - (get-output-string mp)))) - - (write_file (lambda (file bytes) (call-with-output-file file (lambda (out) (foldl (lambda (_ o) (write-byte o out)) (void) bytes))))) - ) -(let* ( - - (in_array (let ((helper (rec-lambda recurse (x a i) (cond ((= i (len a)) false) - ((= x (idx a i)) true) - (true (recurse x a (+ i 1))))))) - (lambda (x a) (helper x a 0)))) - - - (val? (lambda (x) (= 'val (idx x 0)))) - (marked_array? (lambda (x) (= 'marked_array (idx x 0)))) - (marked_symbol? (lambda (x) (= 'marked_symbol (idx x 0)))) - (comb? (lambda (x) (= 'comb (idx x 0)))) - (prim_comb? (lambda (x) (= 'prim_comb (idx x 0)))) - (marked_env? (lambda (x) (= 'env (idx x 0)))) - - (.hash (lambda (x) (idx x 1))) - - (.val (lambda (x) (idx x 2))) - - (.marked_array_is_val (lambda (x) (idx x 2))) - (.marked_array_is_attempted (lambda (x) (idx x 3))) - (.marked_array_needed_for_progress (lambda (x) (idx x 4))) - (.marked_array_values (lambda (x) (idx x 5))) - - (.marked_symbol_needed_for_progress (lambda (x) (idx x 2))) - (.marked_symbol_is_val (lambda (x) (= nil (.marked_symbol_needed_for_progress x)))) - (.marked_symbol_value (lambda (x) (idx x 3))) - (.comb (lambda (x) (slice x 2 -1))) - (.comb_id (lambda (x) (idx x 3))) - (.comb_des (lambda (x) (idx x 4))) - (.comb_env (lambda (x) (idx x 5))) - (.comb_body (lambda (x) (idx x 8))) - (.comb_wrap_level (lambda (x) (idx x 2))) - (.prim_comb_sym (lambda (x) (idx x 3))) - (.prim_comb_handler (lambda (x) (idx x 2))) - (.prim_comb_wrap_level (lambda (x) (idx x 4))) - (.prim_comb_val_head_ok (lambda (x) (idx x 5))) - (.prim_comb (lambda (x) (slice x 2 -1))) - - (.marked_env (lambda (x) (slice x 2 -1))) - (.marked_env_has_vals (lambda (x) (idx x 2))) - (.marked_env_needed_for_progress (lambda (x) (idx x 3))) - (.marked_env_idx (lambda (x) (idx x 4))) - (.marked_env_upper (lambda (x) (idx (idx x 5) -1))) - (.env_marked (lambda (x) (idx x 5))) - (marked_env_real? (lambda (x) (= nil (.marked_env_needed_for_progress x)))) - (.any_comb_wrap_level (lambda (x) (cond ((prim_comb? x) (.prim_comb_wrap_level x)) - ((comb? x) (.comb_wrap_level x)) - (true (error "bad .any_comb_level"))))) - ; The actual needed_for_progress values are either - ; #t - any eval will do something - ; nil - is a value, no eval will do anything - ; (3 4 1...) - list of env ids that would allow forward progress - ; But these are paired with another list of hashes that if you're not inside - ; of an evaluation of, then it could progress futher. These are all caused by - ; the infinite recursion stopper. - (needed_for_progress (rec-lambda needed_for_progress (x) (cond ((marked_array? x) (.marked_array_needed_for_progress x)) - ((marked_symbol? x) (array (.marked_symbol_needed_for_progress x) nil)) - ((marked_env? x) (array (.marked_env_needed_for_progress x) nil)) - ((comb? x) (dlet ((id (.comb_id x)) - (body_needed (idx (needed_for_progress (.comb_body x)) 0)) - (se_needed (idx (needed_for_progress (.comb_env x)) 0))) - (if (or (= true body_needed) (= true se_needed)) (array true nil) - (array (foldl (lambda (a xi) (if (or (= id xi) (in_array xi a)) a (cons xi a))) - (array) (concat body_needed se_needed)) nil) - ))) - ((prim_comb? x) (array nil nil)) - ((val? x) (array nil nil)) - (true (error (str "what is this? in need for progress" x)))))) - (needed_for_progress_slim (lambda (x) (idx (needed_for_progress x) 0))) - - (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 (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 (symbol->string 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 (progress_idxs dbi arrs) (combine_hash (mif dbi (hash_num dbi) 59) (let* ( - (_ (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 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)))))) - ; 107 109 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 ( - (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))) - ; If not is_val, then if the first entry (combiner) is not done or is a combiner and not function - ; shouldn't add the rest of them, since they'll have to be passed without eval - ; We do this by ignoring trues for non-first - ((_ sub_progress_idxs hashes) (foldl (dlambda ((f a ahs) (x xhs)) - (array false - (cond ((or (= true a) (and f (= true x))) true) - ((= true x) a) - (true (array_union a x))) - (array_union ahs xhs)) - ) (array true (array) resume_hashes) (map needed_for_progress x))) - ;(_ (print "got " sub_progress_idxs " out of " x)) - ;(_ (print "\twhich evalated to " (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) x)))) - (marked_env (lambda (has_vals progress_idxs dbi arrs) (array 'env (begin (true_print "marked_env ( " arrs ")") (hash_env progress_idxs dbi arrs)) has_vals progress_idxs dbi 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"))))) - - - (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)))))) - - (str_strip (lambda args (apply str (concat (slice args 0 -2) (array (idx ((rec-lambda recurse (x done_envs) - (cond ((= nil x) (array "" done_envs)) - ((string? x) (array (str "") done_envs)) - ((val? x) (array (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 (str "[" stripped_values "]") done_envs) - (array (str "" stripped_values) done_envs)))) - ((marked_symbol? x) (mif (.marked_symbol_is_val x) (array (str "'" (.marked_symbol_value x)) done_envs) - (array (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 (str "") done_envs))) - ((prim_comb? x) (array (str "") 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 (str "{" (mif (marked_env_real? x) "real" "fake") (mif (.marked_env_has_vals x) " real vals" " fake vals") " ENV idx: " (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 (str opening "omitted}") - (if (> (len e) 30) (str "{" (len e) "env}") - (str opening middle " upper: " upper "}"))) done_envs) - )) - (true (error (str "some other str_strip? |" x "|"))) - ) - ) (idx args -1) (array)) 0)))))) - (true_str_strip str_strip) - (str_strip (lambda args 0)) - ;(true_str_strip str_strip) - (print_strip (lambda args (println (apply 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 (print_strip key " not found in env " env))) (lambda (x) x)))) - - (strip (let ((helper (rec-lambda recurse (x need_value) - (cond ((val? x) (.val x)) - ((marked_array? x) (let ((stripped_values (map (lambda (x) (recurse x need_value)) (.marked_array_values x)))) - (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) (let* ( - ;(_ (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 ( - (hash (.hash x)) - ;(result (if (or (comb? x) (marked_env? x)) (alist-ref hash memo) false)) - ;(result (if (or (marked_array? x) (marked_env? x)) (alist-ref hash memo) false)) - (result (if (marked_env? x) (alist-ref hash memo) false)) - ) (if (array? result) (array memo (idx result 0)) (cond - ((val? x) (array memo false)) - ((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)) - ;(memo (put memo hash result)) - ) (array memo result))) - ((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))) - ;(memo (put memo hash total)) - ) (array memo total))) - - ((prim_comb? x) (array memo false)) - ((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))) - )))) (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 ( 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 - ; ( 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 ( 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))) - (new_array (marked_array false (.marked_array_is_attempted x) nil ress)) - ((pectx err new_array) (if (or (!= nil err) (not changed)) - (array pectx err new_array) - (partial_eval_helper new_array false de env_stack pectx (+ indent 1) true))) - ) (array pectx err new_array)) - (array pectx nil x)) - ) (array pectx nil x)))) - - r))) - - ; TODO: instead of returning the later symbols, we could create a new value of a new type - ; ['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 - (make_tmp_inner_env (lambda (params de? de env_id) - (dlet ((param_entries (map (lambda (p) (array p (marked_symbol (array env_id) p))) params)) - (possible_de_entry (mif (= nil de?) (array) (array (array de? (marked_symbol (array env_id) de?))))) - (progress_idxs (cons env_id (needed_for_progress_slim de))) - ) (begin (true_print "in make_tmp_inner_env based on concat " param_entries " " possible_de_entry " " (array de)) (marked_env false progress_idxs env_id (concat param_entries possible_de_entry (array de))))))) - - - (partial_eval_helper (rec-lambda partial_eval_helper (x only_head env env_stack pectx indent force) - (dlet (((for_progress for_progress_hashes) (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)) - (progress_now (or (= for_progress true) ((rec-lambda rr (i) (if (= i (len for_progress)) false - (dlet ( - ; possible if called from a value context in the compiler - ; TODO: I think this should be removed and instead the value/code compilers should - ; keep track of actual env stacks - (this_now ((rec-lambda ir (j) (cond ((= j (len env_stack)) false) - ((and (= (idx for_progress i) (.marked_env_idx (idx env_stack j))) - (.marked_env_has_vals (idx env_stack j))) (idx for_progress i)) - (true (ir (+ j 1)))) - ) 0)) - ) (if this_now this_now (rr (+ i 1)))) - )) 0))) - ) - (if (or force hashes_now progress_now) - (cond ((val? x) (array pectx nil x)) - ((marked_env? x) (let ((dbi (.marked_env_idx x))) - ; compiler calls with empty env stack - (mif dbi (let* ( (new_env ((rec-lambda rec (i) (cond ((= i (len env_stack)) nil) - ((= dbi (.marked_env_idx (idx env_stack i))) (idx env_stack i)) - (true (rec (+ i 1))))) - 0)) - (_ (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 (cons inner_env env_stack) 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")) - - (later_call_array (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 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 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_progress_idxs de_entry) (mif (!= nil de?) - (array (needed_for_progress_slim env) (array (array de? env))) - (array nil (array)))) - ; Don't need to check params, they're all values! - (inner_env_progress_idxs (concat de_progress_idxs (needed_for_progress_slim se))) - (inner_env (begin (true_print "Environment pre marked_env, gonna concat (zip of " params " " final_params ") " (zip params final_params) " " de_entry " " (array se)) (marked_env true inner_env_progress_idxs env_id (concat (zip params final_params) de_entry (array se))))) - (_ (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 - (cons inner_env env_stack) - 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 (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 - (begin (print_strip (indent_str indent) "Not evaluating " x) - ;(print (indent_str indent) "comparing to env stack " env_stack) - (drop_redundent_veval partial_eval_helper x env env_stack pectx indent)))) - )) - - (needs_params_val_lambda_inner (lambda (f_sym actual_function) (let* ( - (handler (rec-lambda recurse (only_head de env_stack pectx params indent) - (array pectx nil (mark false (apply actual_function (map strip params)))))) - ) (array f_sym (marked_prim_comb handler f_sym 1 false))))) - - (give_up_eval_params_inner (lambda (f_sym actual_function) (let* ( - (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) (begin (print (indent_str indent) "got err " 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)) - )))) - - (root_marked_env (marked_env true 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)) - - (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 (begin (print "skipping inner eval cuz 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 (cons inner_env env_stack) 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)) - - (array 'wrap (marked_prim_comb (dlambda (only_head de env_stack pectx (evaled) indent) - (if (comb? evaled) (array pectx nil (with_wrap_level evaled (+ (.any_comb_wrap_level evaled) 1))) - (array pectx "bad passed to wrap" nil)) - ) 'wrap 1 true)) - - (array 'unwrap (marked_prim_comb (dlambda (only_head de env_stack pectx (evaled) indent) - (if (comb? evaled) (array pectx nil (with_wrap_level evaled (- (.any_comb_wrap_level evaled) 1))) - (array pectx "bad passed to unwrap" nil)) - ) 'unwrap 1 true)) - - (array 'cond (marked_prim_comb ((rec-lambda recurse (already_stripped) (lambda (only_head de env_stack pectx params indent) - (mif (!= 0 (% (len params) 2)) (array pectx (str "partial eval cond with odd params " params) nil) - (dlet ( - ;(_ (error "This will have to evaluate the other sides? Also, if we figure out veval re-val, maybe this can collapse back into cond")) - (eval_helper (lambda (to_eval pectx) - (dlet (((ok unvald) (if already_stripped (array true to_eval) - (try_unval to_eval (lambda (_) nil))))) - (mif (not ok) - (array pectx "bad unval in cond" nil) - (partial_eval_helper unvald false de env_stack pectx (+ 1 indent) false))))) - ) - ((rec-lambda recurse_inner (i so_far pectx) - (dlet (((pectx err pred) (eval_helper (idx params i) pectx))) - (cond ((!= nil err) (array pectx err nil)) - ((later_head? pred) (dlet ( - (sliced_params (slice params (+ i 1) -1)) - (this (marked_array false true nil (concat (array (marked_prim_comb (recurse false) 'cond 0 true) - pred) - sliced_params))) - (hash (combine_hash (combine_hash 101 (.hash this)) (+ 103 (.marked_env_idx de)))) - ((env_counter memo) pectx) - (already_in (!= false (get-value-or-false memo hash))) - (_ (if already_in (print_strip "ALREADY IN " this) - (print_strip "NOT ALREADY IN, CONTINUING with " this))) - ((pectx err evaled_params later_hash) (if already_in - (array pectx nil (map (lambda (x) (dlet (((ok ux) (try_unval x (lambda (_) nil))) - (_ (if (not ok) (error "BAD cond un")))) - ux)) - sliced_params) hash) - (foldl (dlambda ((pectx err as later_hash) x) - (dlet (((pectx er a) (eval_helper x pectx))) - (array pectx (mif err err er) (concat as (array a)) later_hash)) - ) (array (array env_counter (put memo hash nil)) err (array) nil) sliced_params))) - ((env_counter omemo) pectx) - (pectx (array env_counter memo)) - ) (array pectx err (marked_array false true later_hash (concat (array (marked_prim_comb (recurse true) 'vcond -1 true) - pred) - evaled_params - ))))) - ((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)) - (true (eval_helper (idx params (+ i 1)) pectx)) - ))) 0 (array) pectx)) - ) - )) false) 'cond 0 true)) - - (needs_params_val_lambda symbol?) - (needs_params_val_lambda int?) - (needs_params_val_lambda string?) - - (array 'combiner? (marked_prim_comb (dlambda (only_head de env_stack pectx (evaled_param) indent) - (array pectx nil (cond - ((comb? evaled_param) (marked_val true)) - ((prim_comb? evaled_param) (marked_val true)) - (true (marked_val false)) - )) - ) 'combiner? 1 true)) - (array 'env? (marked_prim_comb (dlambda (only_head de env_stack pectx (evaled_param) indent) - (array pectx nil (cond - ((marked_env? evaled_param) (marked_val true)) - (true (marked_val false)) - )) - ) 'env? 1 true)) - (needs_params_val_lambda nil?) - (needs_params_val_lambda bool?) - (needs_params_val_lambda str-to-symbol) - (needs_params_val_lambda get-text) - - (array 'array? (marked_prim_comb (dlambda (only_head de env_stack pectx (evaled_param) indent) - (array pectx nil (cond - ((marked_array? evaled_param) (marked_val true)) - (true (marked_val false)) - )) - ) 'array? 1 true)) - - ; Look into eventually allowing some non values, perhaps, when we look at combiner non all value params - (array 'array (marked_prim_comb (lambda (only_head de env_stack pectx evaled_params indent) - (array pectx nil (marked_array true false nil evaled_params)) - ) 'array 1 false)) - (array 'len (marked_prim_comb (dlambda (only_head de env_stack pectx (evaled_param) indent) - (cond - ((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)) - ) - ) 'len 1 true)) - (array 'idx (marked_prim_comb (dlambda (only_head de env_stack pectx (evaled_array evaled_idx) indent) - (cond - ((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)) - ) - ) 'idx 1 true)) - (array 'slice (marked_prim_comb (dlambda (only_head de env_stack pectx (evaled_array evaled_begin evaled_end) indent) - (cond - ((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))))) - (true (array pectx "bad params to slice" nil)) - ) - ) 'slice 1 true)) - (array 'concat (marked_prim_comb (lambda (only_head de env_stack pectx evaled_params indent) - (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) - (.marked_array_values x)) - evaled_params))))) - (true (array pectx "bad params to concat" nil)) - ) - ) 'concat 1 true)) - - (needs_params_val_lambda +) - (needs_params_val_lambda -) - (needs_params_val_lambda *) - (needs_params_val_lambda /) - (needs_params_val_lambda %) - (needs_params_val_lambda band) - (needs_params_val_lambda bor) - (needs_params_val_lambda bnot) - (needs_params_val_lambda bxor) - (needs_params_val_lambda <<) - (needs_params_val_lambda >>) - (needs_params_val_lambda =) - (needs_params_val_lambda !=) - (needs_params_val_lambda <) - (needs_params_val_lambda <=) - (needs_params_val_lambda >) - (needs_params_val_lambda >=) - (needs_params_val_lambda str) - ;(needs_params_val_lambda pr-str) - ;(needs_params_val_lambda prn) - (give_up_eval_params log) - ; really do need to figure out mif we want to keep meta, and add it mif so - ;(give_up_eval_params meta) - ;(give_up_eval_params with-meta) - ; mif we want to get fancy, we could do error/recover too - (give_up_eval_params error) - ;(give_up_eval_params recover) - (needs_params_val_lambda read-string) - (array 'empty_env (marked_env true nil nil (array nil))) - - nil - ))) - - - (partial_eval (lambda (x) (partial_eval_helper (mark true x) false root_marked_env (array) (array 0 (array)) 0 false))) - ;; WASM - - ; Vectors and Values - ; Bytes encode themselves - - ; Note that the shift must be arithmatic - (encode_LEB128 (rec-lambda recurse (x) - (let ((b (band #x7F x)) - (v (>> x 7))) - - (cond ((or (and (= v 0) (= (band b #x40) 0)) (and (= v -1) (!= (band b #x40) 0))) (array b)) - (true (cons (bor b #x80) (recurse v))))) - )) - (encode_vector (lambda (enc v) - (concat (encode_LEB128 (len v)) (flat_map enc v) ) - )) - (encode_floating_point (lambda (x) (error "unimplemented"))) - (encode_name (lambda (name) - (encode_vector (lambda (x) (array x)) (map char->integer (string->list name))) - )) - (hex_digit (lambda (digit) (let ((d (char->integer digit))) - (cond ((< d #x3A) (- d #x30)) - ((< d #x47) (- d #x37)) - (true (- d #x57)))))) - (encode_bytes (lambda (str) - (encode_vector (lambda (x) (array x)) ((rec-lambda recurse (s) (cond - ((= nil s) nil) - ((= #\\ (car s)) (cons (+ (* 16 (hex_digit (car (cdr s)))) - (hex_digit (car (cdr (cdr s))))) (recurse (cdr (cdr (cdr s)))))) - (true (cons (char->integer (car s)) (recurse (cdr s)))) - )) (string->list str))) - )) - - (encode_limits (lambda (x) - (cond ((= 1 (len x)) (concat (array #x00) (encode_LEB128 (idx x 0)))) - ((= 2 (len x)) (concat (array #x01) (encode_LEB128 (idx x 0)) (encode_LEB128 (idx x 1)))) - (true (error "trying to encode bad limits"))) - )) - (encode_number_type (lambda (x) - (cond ((= x 'i32) (array #x7F)) - ((= x 'i64) (array #x7E)) - ((= x 'f32) (array #x7D)) - ((= x 'f64) (array #x7C)) - (true (error (str "bad number type " x)))) - )) - (encode_valtype (lambda (x) - ; we don't handle reference types yet - (encode_number_type x) - )) - (encode_result_type (lambda (x) - (encode_vector encode_valtype x) - )) - (encode_function_type (lambda (x) - (concat (array #x60) (encode_result_type (idx x 0)) - (encode_result_type (idx x 1))) - )) - (encode_ref_type (lambda (t) (cond ((= t 'funcref) (array #x70)) - ((= t 'externref) (array #x6F)) - (true (error (str "Bad ref type " t)))))) - (encode_type_section (lambda (x) - (let ( - (encoded (encode_vector encode_function_type x)) - ) (concat (array #x01) (encode_LEB128 (len encoded)) encoded )) - )) - (encode_import (lambda (import) - (dlet ( - ((mod_name name type idx) import) - ) (concat (encode_name mod_name) - (encode_name name) - (cond ((= type 'func) (concat (array #x00) (encode_LEB128 idx))) - ((= type 'table) (concat (array #x01) (error "can't encode table type"))) - ((= type 'memory) (concat (array #x02) (error "can't encode memory type"))) - ((= type 'global) (concat (array #x03) (error "can't encode global type"))) - (true (error (str "bad import type" type))))) - ) - )) - (encode_import_section (lambda (x) - (let ( - (encoded (encode_vector encode_import x)) - ) (concat (array #x02) (encode_LEB128 (len encoded)) encoded )) - )) - - (encode_table_type (lambda (t) (concat (encode_ref_type (idx t 0)) (encode_limits (idx t 1))))) - - (encode_table_section (lambda (x) - (let ( - (encoded (encode_vector encode_table_type x)) - ) (concat (array #x04) (encode_LEB128 (len encoded)) encoded )) - )) - (encode_memory_section (lambda (x) - (let ( - (encoded (encode_vector encode_limits x)) - ) (concat (array #x05) (encode_LEB128 (len encoded)) encoded )) - )) - (encode_export (lambda (export) - (dlet ( - ((name type idx) export) - ) (concat (encode_name name) - (cond ((= type 'func) (array #x00)) - ((= type 'table) (array #x01)) - ((= type 'memory) (array #x02)) - ((= type 'global) (array #x03)) - (true (error "bad export type"))) - (encode_LEB128 idx) - )) - )) - (encode_export_section (lambda (x) - (let ( - ;(_ (print "encoding element " x)) - (encoded (encode_vector encode_export x)) - ;(_ (print "donex")) - ) (concat (array #x07) (encode_LEB128 (len encoded)) encoded )) - )) - - (encode_start_section (lambda (x) - (cond ((= 0 (len x)) (array)) - ((= 1 (len x)) (let ((encoded (encode_LEB128 (idx x 0)))) (concat (array #x08) (encode_LEB128 (len encoded)) encoded ))) - (true (error (str "bad lenbgth for start section " (len x) " was " x)))) - )) - - (encode_function_section (lambda (x) - (let* ( ; nil functions are placeholders for improted functions - ;(_ (println "encoding function section " x)) - (filtered (filter (lambda (i) (!= nil i)) x)) - ;(_ (println "post filtered " filtered)) - (encoded (encode_vector encode_LEB128 filtered)) - ) (concat (array #x03) (encode_LEB128 (len encoded)) encoded )) - )) - (encode_blocktype (lambda (type) (cond ((symbol? type) (encode_valtype type)) - ((= (array) type) (array #x40)) ; empty type - (true (encode_LEB128 type)) - ))) - - (encode_ins (rec-lambda recurse (ins) - (let ( - (op (idx ins 0)) - ) (cond ((= op 'unreachable) (array #x00)) - ((= op 'nop) (array #x01)) - ((= op 'block) (concat (array #x02) (encode_blocktype (idx ins 1)) (flat_map recurse (idx ins 2)) (array #x0B))) - ((= op 'loop) (concat (array #x03) (encode_blocktype (idx ins 1)) (flat_map recurse (idx ins 2)) (array #x0B))) - ((= op 'if) (concat (array #x04) (encode_blocktype (idx ins 1)) (flat_map recurse (idx ins 2)) (if (!= 3 (len ins)) (concat (array #x05) (flat_map recurse (idx ins 3))) - (array )) (array #x0B))) - ((= op 'br) (concat (array #x0C) (encode_LEB128 (idx ins 1)))) - ((= op 'br_if) (concat (array #x0D) (encode_LEB128 (idx ins 1)))) - ;... - ((= op 'return) (array #x0F)) - ((= op 'call) (concat (array #x10) (encode_LEB128 (idx ins 1)))) - ((= op 'call_indirect) (concat (array #x11) (encode_LEB128 (idx ins 1)) (encode_LEB128 (idx ins 2)))) - ; skipping a bunch - ; Parametric Instructions - ((= op 'drop) (array #x1A)) - ; skip - ; Variable Instructions - ((= op 'local.get) (concat (array #x20) (encode_LEB128 (idx ins 1)))) - ((= op 'local.set) (concat (array #x21) (encode_LEB128 (idx ins 1)))) - ((= op 'local.tee) (concat (array #x22) (encode_LEB128 (idx ins 1)))) - ((= op 'global.get) (concat (array #x23) (encode_LEB128 (idx ins 1)))) - ((= op 'global.set) (concat (array #x24) (encode_LEB128 (idx ins 1)))) - ; table - ; memory - ((= op 'i32.load) (concat (array #x28) (encode_LEB128 (idx ins 1)) (encode_LEB128 (idx ins 2)))) - ((= op 'i64.load) (concat (array #x29) (encode_LEB128 (idx ins 1)) (encode_LEB128 (idx ins 2)))) - ((= op 'i32.load8_s) (concat (array #x2C) (encode_LEB128 (idx ins 1)) (encode_LEB128 (idx ins 2)))) - ((= op 'i32.load8_u) (concat (array #x2D) (encode_LEB128 (idx ins 1)) (encode_LEB128 (idx ins 2)))) - ((= op 'i32.load16_s) (concat (array #x2E) (encode_LEB128 (idx ins 1)) (encode_LEB128 (idx ins 2)))) - ((= op 'i32.load16_u) (concat (array #x2F) (encode_LEB128 (idx ins 1)) (encode_LEB128 (idx ins 2)))) - ((= op 'i64.load8_s) (concat (array #x30) (encode_LEB128 (idx ins 1)) (encode_LEB128 (idx ins 2)))) - ((= op 'i64.load8_u) (concat (array #x31) (encode_LEB128 (idx ins 1)) (encode_LEB128 (idx ins 2)))) - ((= op 'i64.load16_s) (concat (array #x32) (encode_LEB128 (idx ins 1)) (encode_LEB128 (idx ins 2)))) - ((= op 'i64.load16_u) (concat (array #x33) (encode_LEB128 (idx ins 1)) (encode_LEB128 (idx ins 2)))) - ((= op 'i64.load32_s) (concat (array #x34) (encode_LEB128 (idx ins 1)) (encode_LEB128 (idx ins 2)))) - ((= op 'i64.load32_u) (concat (array #x35) (encode_LEB128 (idx ins 1)) (encode_LEB128 (idx ins 2)))) - ((= op 'i32.store) (concat (array #x36) (encode_LEB128 (idx ins 1)) (encode_LEB128 (idx ins 2)))) - ((= op 'i64.store) (concat (array #x37) (encode_LEB128 (idx ins 1)) (encode_LEB128 (idx ins 2)))) - ((= op 'i32.store8) (concat (array #x3A) (encode_LEB128 (idx ins 1)) (encode_LEB128 (idx ins 2)))) - ((= op 'i32.store16) (concat (array #x3B) (encode_LEB128 (idx ins 1)) (encode_LEB128 (idx ins 2)))) - ((= op 'i64.store8) (concat (array #x3C) (encode_LEB128 (idx ins 1)) (encode_LEB128 (idx ins 2)))) - ((= op 'i64.store16) (concat (array #x3D) (encode_LEB128 (idx ins 1)) (encode_LEB128 (idx ins 2)))) - ((= op 'memory.grow) (array #x40 #x00)) - ; Numeric Instructions - ((= op 'i32.const) (concat (array #x41) (encode_LEB128 (idx ins 1)))) - ((= op 'i64.const) (concat (array #x42) (encode_LEB128 (idx ins 1)))) - ((= op 'i32.eqz) (array #x45)) - ((= op 'i32.eq) (array #x46)) - ((= op 'i32.ne) (array #x47)) - ((= op 'i32.lt_s) (array #x48)) - ((= op 'i32.lt_u) (array #x49)) - ((= op 'i32.gt_s) (array #x4A)) - ((= op 'i32.gt_u) (array #x4B)) - ((= op 'i32.le_s) (array #x4C)) - ((= op 'i32.le_u) (array #x4D)) - ((= op 'i32.ge_s) (array #x4E)) - ((= op 'i32.ge_u) (array #x4F)) - - ((= op 'i64.eqz) (array #x50)) - ((= op 'i64.eq) (array #x51)) - ((= op 'i64.ne) (array #x52)) - ((= op 'i64.lt_s) (array #x53)) - ((= op 'i64.lt_u) (array #x54)) - ((= op 'i64.gt_s) (array #x55)) - ((= op 'i64.gt_u) (array #x56)) - ((= op 'i64.le_s) (array #x57)) - ((= op 'i64.le_u) (array #x58)) - ((= op 'i64.ge_s) (array #x59)) - ((= op 'i64.ge_u) (array #x5A)) - - ((= op 'i32.add) (array #x6A)) - ((= op 'i32.sub) (array #x6B)) - ((= op 'i32.mul) (array #x6C)) - ((= op 'i32.div_s) (array #x6D)) - ((= op 'i32.div_u) (array #x6E)) - ((= op 'i32.rem_s) (array #x6F)) - ((= op 'i32.rem_u) (array #x70)) - ((= op 'i32.and) (array #x71)) - ((= op 'i32.or) (array #x72)) - ((= op 'i32.shl) (array #x74)) - ((= op 'i32.shr_s) (array #x75)) - ((= op 'i32.shr_u) (array #x76)) - ((= op 'i64.add) (array #x7C)) - ((= op 'i64.sub) (array #x7D)) - ((= op 'i64.mul) (array #x7E)) - ((= op 'i64.div_s) (array #x7F)) - ((= op 'i64.div_u) (array #x80)) - ((= op 'i64.rem_s) (array #x81)) - ((= op 'i64.rem_u) (array #x82)) - ((= op 'i64.and) (array #x83)) - ((= op 'i64.or) (array #x84)) - ((= op 'i64.xor) (array #x85)) - ((= op 'i64.shl) (array #x86)) - ((= op 'i64.shr_s) (array #x87)) - ((= op 'i64.shr_u) (array #x88)) - - ((= op 'i32.wrap_i64) (array #xA7)) - ((= op 'i64.extend_i32_s) (array #xAC)) - ((= op 'i64.extend_i32_u) (array #xAD)) - - ((= op 'memory.copy) (array #xFC #x0A #x00 #x00)) - )) - )) - - (encode_expr (lambda (expr) (concat (flat_map encode_ins expr) (array #x0B)))) - (encode_code (lambda (x) - (dlet ( - ((locals body) x) - (enc_locals (encode_vector (lambda (loc) - (concat (encode_LEB128 (idx loc 0)) (encode_valtype (idx loc 1)))) locals)) - (enc_expr (encode_expr body)) - (code_bytes (concat enc_locals enc_expr)) - ) (concat (encode_LEB128 (len code_bytes)) code_bytes)) - )) - (encode_code_section (lambda (x) - (let ( - (encoded (encode_vector encode_code x)) - ) (concat (array #x0A) (encode_LEB128 (len encoded)) encoded )) - )) - - (encode_global_type (lambda (t) (concat (encode_valtype (idx t 0)) (cond ((= (idx t 1) 'const) (array #x00)) - ((= (idx t 1) 'mut) (array #x01)) - (true (error (str "bad mutablity " (idx t 1)))))))) - (encode_global_section (lambda (global_section) - (let ( - ;(_ (print "encoding exprs " global_section)) - (encoded (encode_vector (lambda (x) (concat (encode_global_type (idx x 0)) (encode_expr (idx x 1)))) global_section)) - ) (concat (array #x06) (encode_LEB128 (len encoded)) encoded )) - )) - - ; only supporting one type of element section for now, active funcrefs with offset - (encode_element (lambda (x) (concat (array #x00) (encode_expr (idx x 0)) (encode_vector encode_LEB128 (idx x 1))))) - (encode_element_section (lambda (x) - (let ( - ;(_ (print "encoding element " x)) - (encoded (encode_vector encode_element x)) - ;(_ (print "donex")) - ) (concat (array #x09) (encode_LEB128 (len encoded)) encoded )) - )) - - (encode_data (lambda (data) (cond ((= 2 (len data)) (concat (array #x00) (encode_expr (idx data 0)) (encode_bytes (idx data 1)))) - ((= 1 (len data)) (concat (array #x01) (encode_bytes (idx data 0)))) - ((= 3 (len data)) (concat (array #x02) (encode_LEB128 (idx data 0)) (encode_expr (idx data 1)) (encode_bytes (idx data 2)))) - (true (error (str "bad data" data)))))) - (encode_data_section (lambda (x) - (let ( - (encoded (encode_vector encode_data x)) - ) (concat (array #x0B) (encode_LEB128 (len encoded)) encoded )) - )) - - (wasm_to_binary (lambda (wasm_code) - (dlet ( - ((type_section import_section function_section table_section memory_section global_section export_section start_section element_section code_section data_section) wasm_code) - ;(_ (println "type_section" type_section "import_section" import_section "function_section" function_section "memory_section" memory_section "global_section" global_section "export_section" export_section "start_section" start_section "element_section" element_section "code_section" code_section "data_section" data_section)) - (magic (array #x00 #x61 #x73 #x6D )) - (version (array #x01 #x00 #x00 #x00 )) - (type (encode_type_section type_section)) - (import (encode_import_section import_section)) - (function (encode_function_section function_section)) - (table (encode_table_section table_section)) - (memory (encode_memory_section memory_section)) - (global (encode_global_section global_section)) - (export (encode_export_section export_section)) - (start (encode_start_section start_section)) - (elem (encode_element_section element_section)) - (code (encode_code_section code_section)) - (data (encode_data_section data_section)) - ;data_count (let (body (encode_LEB128 (len data_section))) (concat (array #x0C) (encode_LEB128 (len body)) body)) - (data_count (array)) - ) (concat magic version type import function table memory global export data_count start elem code data)) - )) - - (module (lambda args (let ( - (helper (rec-lambda recurse (entries i name_dict type import function table memory global export start elem code data) - (if (= i (len entries)) (array type import function table memory global export start elem code data) - (dlet ( - ((n_d t im f ta m g e s elm c d) ((idx entries i) name_dict type import function table memory global export start elem code data)) - ) (recurse entries (+ i 1) n_d t im f ta m g e s elm c d))))) - ) (helper (apply concat args) 0 empty_dict (array ) (array ) (array ) (array ) (array ) (array ) (array ) (array ) (array ) (array ) (array ))))) - - (table (lambda (idx_name . limits_type) (array (lambda (name_dict type import function table memory global export start elem code data) - (array (put name_dict idx_name (len table)) type import function (concat table (array (array (idx limits_type -1) (slice limits_type 0 -2) ))) memory global export start elem code data ))))) - - (memory (lambda (idx_name . limits) (array (lambda (name_dict type import function table memory global export start elem code data) - (array (put name_dict idx_name (len memory)) type import function table (concat memory (array limits)) global export start elem code data ))))) - - (func (lambda (name . inside) (array (lambda (name_dict type import function table memory global export start elem code data) - (dlet ( - ;(_ (print "ok, doing a func: " name " with inside " inside)) - ((params result locals body) ((rec-lambda recurse (i pe re) - (cond ((and (= false pe) (< i (len inside)) (array? (idx inside i)) (< 0 (len (idx inside i))) (= 'param (idx (idx inside i) 0))) - (recurse (+ i 1) pe re)) - ((and (= false pe) (= false re) (< i (len inside)) (array? (idx inside i)) (< 0 (len (idx inside i))) (= 'result (idx (idx inside i) 0))) - ; only one result possible - (recurse (+ i 1) i (+ i 1))) - ((and (= false re) (< i (len inside)) (array? (idx inside i)) (< 0 (len (idx inside i))) (= 'result (idx (idx inside i) 0))) - ; only one result possible - (recurse (+ i 1) pe (+ i 1))) - ((and (< i (len inside)) (array? (idx inside i)) (< 0 (len (idx inside i))) (= 'local (idx (idx inside i) 0))) - (recurse (+ i 1) (or pe i) (or re i))) - (true (array (slice inside 0 (or pe i)) (slice inside (or pe i) (or re pe i)) (slice inside (or re pe i) i) (slice inside i -1))) - ) - ) 0 false false)) - (result (if (!= 0 (len result)) (array (idx (idx result 0) 1)) - result)) - ;(_ (println "params " params " result " result " locals " locals " body " body)) - (outer_name_dict (put name_dict name (len function))) - ((num_params inner_name_dict) (foldl (lambda (a x) (array (+ (idx a 0) 1) (put (idx a 1) (idx x 1) (idx a 0)))) (array 0 outer_name_dict ) params)) - ((num_locals inner_name_dict) (foldl (lambda (a x) (array (+ (idx a 0) 1) (put (idx a 1) (idx x 1) (idx a 0)))) (array num_params inner_name_dict ) locals)) - ;(_ (println "inner name dict" inner_name_dict)) - (compressed_locals ((rec-lambda recurse (cur_list cur_typ cur_num i) - (cond ((and (= i (len locals)) (= 0 cur_num)) cur_list) - ((= i (len locals)) (concat cur_list (array (array cur_num cur_typ) ))) - ((= cur_typ (idx (idx locals i) 2)) (recurse cur_list cur_typ (+ 1 cur_num) (+ 1 i))) - ((= nil cur_typ) (recurse cur_list (idx (idx locals i) 2) 1 (+ 1 i))) - (true (recurse (concat cur_list (array (array cur_num cur_typ))) (idx (idx locals i) 2) 1 (+ 1 i)))) - ) (array) nil 0 0)) - ;(_ (println "params: " params " result: " result)) - (our_type (array (map (lambda (x) (idx x 2)) params) result)) - ;(inner_env (add-dict-to-env de (put inner_name_dict 'depth 0))) - (inner_name_dict_with_depth (put inner_name_dict 'depth 0)) - ;(_ (println "about to get our_code: " body)) - (our_code (flat_map (lambda (inss) (map (lambda (ins) (ins inner_name_dict_with_depth)) inss)) - body)) - ;(_ (println "resulting code " our_code)) - ) (array - outer_name_dict - ; type - (concat type (array our_type )) - ; import - import - ; function - (concat function (array (len function) )) - ; table - table - ; memory - memory - ; global - global - ; export - export - ; start - start - ; element - elem - ; code - (concat code (array (array compressed_locals our_code ) )) - ; data - data - )) - )))) - - ;;;;;;;;;;;;;;; - ; Instructions - ;;;;;;;;;;;;;;; - (unreachable (lambda () (array (lambda (name_dict) (array 'unreachable))))) - (drop (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'drop)))))) - (i32.const (lambda (const) (array (lambda (name_dict) (array 'i32.const const))))) - (i64.const (lambda (const) (array (lambda (name_dict) (array 'i64.const const))))) - (local.get (lambda (const) (array (lambda (name_dict) (array 'local.get (if (int? const) const (get-value name_dict const))))))) - (local.set (lambda (const . flatten) (concat (apply concat flatten) (array (lambda (name_dict) (array 'local.set (if (int? const) const (get-value name_dict const)))))))) - (local.tee (lambda (const . flatten) (concat (apply concat flatten) (array (lambda (name_dict) (array 'local.tee (if (int? const) const (get-value name_dict const)))))))) - (global.get (lambda (const) (array (lambda (name_dict) (array 'global.get (if (int? const) const (get-value name_dict const))))))) - (global.set (lambda (const . flatten) (concat (apply concat flatten) (array (lambda (name_dict) (array 'global.set (if (int? const) const (get-value name_dict const)))))))) - (i32.add (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.add)))))) - (i32.sub (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.sub)))))) - (i32.mul (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.mul)))))) - (i32.div_s (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.div_s)))))) - (i32.div_u (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.div_u)))))) - (i32.rem_s (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.rem_s)))))) - (i32.rem_u (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.rem_u)))))) - (i32.and (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.and)))))) - (i32.or (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.or)))))) - (i64.add (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.add)))))) - (i64.sub (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.sub)))))) - (i64.mul (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.mul)))))) - (i64.div_s (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.div_s)))))) - (i64.div_u (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.div_u)))))) - (i64.rem_s (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.rem_s)))))) - (i64.rem_u (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.rem_u)))))) - (i64.and (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.and)))))) - (i64.or (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.or)))))) - (i64.xor (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.xor)))))) - - (i32.eqz (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.eqz)))))) - (i32.eq (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.eq)))))) - (i32.ne (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.ne)))))) - (i32.lt_s (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.lt_s)))))) - (i32.lt_u (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.lt_u)))))) - (i32.gt_s (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.gt_s)))))) - (i32.gt_u (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.gt_u)))))) - (i32.le_s (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.le_s)))))) - (i32.le_u (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.le_u)))))) - (i32.ge_s (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.ge_s)))))) - (i32.ge_u (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.ge_u)))))) - (i64.eqz (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.eqz)))))) - (i64.eq (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.eq)))))) - (i64.ne (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.ne)))))) - (i64.lt_s (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.lt_s)))))) - (i64.lt_u (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.lt_u)))))) - (i64.gt_s (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.gt_s)))))) - (i64.gt_u (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.gt_u)))))) - (i64.le_s (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.le_s)))))) - (i64.le_u (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.le_u)))))) - (i64.ge_s (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.ge_s)))))) - (i64.ge_u (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.ge_u)))))) - - (mem_load (lambda (op align) (lambda flatten (dlet ( - (explicit_offset (int? (idx flatten 0))) - (offset (if explicit_offset (idx flatten 0) 0)) - (flatten_rest (if explicit_offset (slice flatten 1 -1) flatten)) - ) (concat (apply concat flatten_rest) (array (lambda (name_dict) (array op align offset)))))))) - - (i32.load (mem_load 'i32.load 2)) - (i64.load (mem_load 'i64.load 3)) - (i32.store (mem_load 'i32.store 2)) - (i64.store (mem_load 'i64.store 3)) - (i32.store8 (mem_load 'i32.store8 0)) - (i32.store16 (mem_load 'i32.store16 1)) - (i64.store8 (mem_load 'i64.store8 0)) - (i64.store16 (mem_load 'i64.store16 1)) - - (i32.load8_s (mem_load 'i32.load8_s 0)) - (i32.load8_u (mem_load 'i32.load8_u 0)) - (i32.load16_s (mem_load 'i32.load16_s 1)) - (i32.load16_u (mem_load 'i32.load16_u 1)) - (i64.load8_s (mem_load 'i64.load8_s 0)) - (i64.load8_u (mem_load 'i64.load8_u 0)) - (i64.load16_s (mem_load 'i64.load16_s 1)) - (i64.load16_u (mem_load 'i64.load16_u 1)) - (i64.load32_s (mem_load 'i64.load32_s 2)) - (i64.load32_u (mem_load 'i64.load32_u 2)) - - (memory.grow (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'memory.grow)))))) - (i32.shl (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.shl)))))) - (i32.shr_u (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.shr_u)))))) - (i64.shl (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.shl)))))) - (i64.shr_s (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.shr_s)))))) - (i64.shr_u (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.shr_u)))))) - - (i32.wrap_i64 (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.wrap_i64)))))) - (i64.extend_i32_s (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.extend_i32_s)))))) - (i64.extend_i32_u (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.extend_i32_u)))))) - - (memory.copy (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'memory.copy)))))) - - (block_like_body (lambda (name_dict name inner) (let* ( - (new_depth (+ 1 (get-value name_dict 'depth))) - (inner_env (put (put name_dict name new_depth) 'depth new_depth)) - ) (flat_map (lambda (inss) (map (lambda (ins) (ins inner_env)) inss)) inner)))) - - - (block (lambda (name . inner) (array (lambda (name_dict) (array 'block (array) (block_like_body name_dict name inner)))))) - (_loop (lambda (name . inner) (array (lambda (name_dict) (array 'loop (array) (block_like_body name_dict name inner)))))) - (_if (lambda (name . inner) (dlet ( - ((end_idx else_section) (if (= 'else (idx (idx inner -1) 0)) (array -2 (slice (idx inner -1) 1 -1) ) - (array -1 nil ))) - ((end_idx then_section) (if (= 'then (idx (idx inner end_idx) 0)) (array (- end_idx 1) (slice (idx inner end_idx) 1 -1) ) - (array (- end_idx 1) (array (idx inner end_idx) ) ))) - ((start_idx result_t) (if (= 'result (idx (idx inner 0) 0)) (array 1 (idx (idx inner 0) 1)) - (array 0 (array)))) - (flattened (apply concat (slice inner start_idx end_idx))) - ;(_ (println "result_t " result_t " flattened " flattened " then_section " then_section " else_section " else_section)) - ) (concat flattened (array (lambda (name_dict) (concat (array 'if result_t (block_like_body name_dict name then_section)) - (if (!= nil else_section) (array (block_like_body name_dict name else_section)) - (array))))))))) - - (then (lambda rest (cons 'then rest))) - (else (lambda rest (cons 'else rest))) - - (br (lambda (block) (array (lambda (name_dict) (array 'br (if (int? block) block (- (get-value name_dict 'depth) (get-value name_dict block)))))))) - (br_if (lambda (block . flatten) (concat (apply concat flatten) (array (lambda (name_dict) (array 'br_if (if (int? block) block (- (get-value name_dict 'depth) (get-value name_dict block))))))))) - (call (lambda (f . flatten) (concat (apply concat flatten) (array (lambda (name_dict) (array 'call (if (int? f) f (get-value name_dict f)))))))) - (call_indirect (lambda (type_idx table_idx . flatten) (concat (apply concat flatten) (array (lambda (name_dict) (array 'call_indirect type_idx table_idx)))))) - - ;;;;;;;;;;;;;;;;;;; - ; End Instructions - ;;;;;;;;;;;;;;;;;;; - - - (import (lambda (mod_name name t_idx_typ) (array (lambda (name_dict type import function table memory global export start elem code data) (dlet ( - (_ (if (!= 'func (idx t_idx_typ 0)) (error "only supporting importing functions rn"))) - ((import_type idx_name param_type result_type) t_idx_typ) - (actual_type_idx (len type)) - (actual_type (array (slice param_type 1 -1) (slice result_type 1 -1) )) - ) - (array (put name_dict idx_name (len function)) (concat type (array actual_type)) (concat import (array (array mod_name name import_type actual_type_idx) )) (concat function (array nil)) table memory global export start elem code data )) - )))) - - (global (lambda (idx_name global_type expr) (array (lambda (name_dict type import function table memory global export start elem code data) - (array (put name_dict idx_name (len global)) - type import function table memory - (concat global (array (array (if (array? global_type) (reverse global_type) (array global_type 'const)) (map (lambda (x) (x empty_dict)) expr) ))) - export start elem code data ) - )))) - - (export (lambda (name t_v) (array (lambda (name_dict type import function table memory global export start elem code data) - (array name_dict type import function table memory global - (concat export (array (array name (idx t_v 0) (get-value name_dict (idx t_v 1)) ) )) - start elem code data ) - )))) - - (start (lambda (name) (array (lambda (name_dict type import function table memory global export start elem code data) - (array name_dict type import function table memory global export (concat start (array (get-value name_dict name))) elem code data ) - )))) - - (elem (lambda (offset . entries) (array (lambda (name_dict type import function table memory global export start elem code data) - (array name_dict type import function table memory global export start (concat elem (array (array (map (lambda (x) (x empty_dict)) offset) (map (lambda (x) (if (int? x) x (get-value name_dict x))) entries)))) code data ) - )))) - - (data (lambda it (array (lambda (name_dict type import function table memory global export start elem code data) - (array name_dict type import function table memory global export start elem code - (concat data (array (map (lambda (x) (if (array? x) (map (lambda (y) (y empty_dict)) x) x)) it)))))))) - - - ; Everything is an i64, and we're on a 32 bit wasm system, so we have a good many bits to play with - - ; Int - should maximize int - ; xxxxx0 - - ; String - should be close to array, bitpacked, just different ptr rep? - ; 011 - - ; Symbol - ideally interned (but not yet) also probs small-symbol-opt (def not yet) - ; 111 - - ; Array / Nil - ; 101 / 0..0 101 - - ; Combiner - a double of func index and closure (which could just be the env, actually, even if we trim...) - ; |0001 - - ; Env - ; 0..001001 - ; Env object is - ; each being the full 64 bit objects. - ; This lets key_array exist in constant mem, and value array to come directly from passed params. - - ; True / False - ; 0..0 1 11001 / 0..0 0 11001 - - (to_hex_digit (lambda (x) (string (integer->char (if (< x 10) (+ x #x30) - (+ x #x37)))))) - (le_hexify_helper (rec-lambda recurse (x i) (if (= i 0) "" - (concat "\\" (to_hex_digit (remainder (quotient x 16) 16)) (to_hex_digit (remainder x 16)) (recurse (quotient x 256) (- i 1)))))) - (i64_le_hexify (lambda (x) (le_hexify_helper x 8))) - (i32_le_hexify (lambda (x) (le_hexify_helper x 4))) - - (compile (dlambda ((pectx partial_eval_err marked_code)) (mif partial_eval_err (error partial_eval_err) (wasm_to_binary (module - (import "wasi_unstable" "path_open" - '(func $path_open (param i32 i32 i32 i32 i32 i64 i64 i32 i32) - (result i32))) - (import "wasi_unstable" "fd_read" - '(func $fd_read (param i32 i32 i32 i32) - (result i32))) - (import "wasi_unstable" "fd_write" - '(func $fd_write (param i32 i32 i32 i32) - (result i32))) - (global '$malloc_head '(mut i32) (i32.const 0)) - (global '$phs '(mut i32) (i32.const 0)) - (global '$phl '(mut i32) (i32.const 0)) - (dlet ( - (nil_val #b0101) - (true_val #b000111001) - (false_val #b000011001) - (alloc_data (dlambda (d (watermark datas)) (cond ((str? d) (let ((size (+ 8 (band (len d) -8)))) - (array (+ watermark 8) - (len d) - (array (+ watermark 8 size) - (concat datas - (data (i32.const watermark) - (concat (i32_le_hexify size) "\\00\\00\\00\\80" d))))))) - (true (error (str "can't alloc_data for anything else besides strings yet" d))) - ) - )) - ; We won't use 0 because some impls seem to consider that NULL and crash on reading/writing? - (iov_tmp 8) ; <32bit len><32bit ptr> + <32bit numwitten> - (datasi (array (+ iov_tmp 16) (array))) - ((true_loc true_length datasi) (alloc_data "true" datasi)) - ((false_loc false_length datasi) (alloc_data "false" datasi)) - - ((bad_params_number_loc bad_params_length datasi) (alloc_data "\nError: passed a bad number of parameters\n" datasi)) - (bad_params_number_msg_val (bor (<< bad_params_length 32) bad_params_number_loc #b011)) - - ((bad_params_type_loc bad_params_length datasi) (alloc_data "\nError: passed a bad type of parameters\n" datasi)) - (bad_params_type_msg_val (bor (<< bad_params_length 32) bad_params_type_loc #b011)) - - ((error_loc error_length datasi) (alloc_data "\nError: " datasi)) - (error_msg_val (bor (<< error_length 32) error_loc #b011)) - ((log_loc log_length datasi) (alloc_data "\nLog: " datasi)) - (log_msg_val (bor (<< log_length 32) log_loc #b011)) - - ((call_ok_loc call_ok_length datasi) (alloc_data "call ok!" datasi)) - (call_ok_msg_val (bor (<< call_ok_length 32) call_ok_loc #b011)) - - ((newline_loc newline_length datasi) (alloc_data "\n" datasi)) - (newline_msg_val (bor (<< newline_length 32) newline_loc #b011)) - - ((space_loc space_length datasi) (alloc_data " " datasi)) - (space_msg_val (bor (<< space_length 32) space_loc #b011)) - - ((remaining_eval_loc remaining_eval_length datasi) (alloc_data "\nError: trying to call remainin eval\n" datasi)) - (remaining_eval_msg_val (bor (<< remaining_eval_length 32) remaining_eval_loc #b011)) - - ((remaining_vau_loc remaining_vau_length datasi) (alloc_data "\nError: trying to call remainin vau (primitive)\n" datasi)) - (remaining_vau_msg_val (bor (<< remaining_vau_length 32) remaining_vau_loc #b011)) - - ((remaining_cond_loc remaining_cond_length datasi) (alloc_data "\nError: trying to call remainin cond\n" datasi)) - (remaining_cond_msg_val (bor (<< remaining_cond_length 32) remaining_cond_loc #b011)) - - ((weird_wrap_loc weird_wrap_length datasi) (alloc_data "\nError: trying to call a combiner with a weird wrap (not 0 or 1)\n" datasi)) - (weird_wrap_msg_val (bor (<< weird_wrap_length 32) weird_wrap_loc #b011)) - - ((bad_not_vau_loc bad_not_vau_length datasi) (alloc_data "\nError: Trying to call a function (not vau) but the parameters caused a compile error\n" datasi)) - (bad_not_vau_msg_val (bor (<< bad_not_vau_length 32) bad_not_vau_loc #b011)) - - ((going_up_loc going_up_length datasi) (alloc_data "going up" datasi)) - (going_up_msg_val (bor (<< going_up_length 32) going_up_loc #b011)) - - ((starting_from_loc starting_from_length datasi) (alloc_data "starting from " datasi)) - (starting_from_msg_val (bor (<< starting_from_length 32) starting_from_loc #b011)) - - ((got_it_loc got_it_length datasi) (alloc_data "got it" datasi)) - (got_it_msg_val (bor (<< got_it_length 32) got_it_loc #b011)) - - ((couldnt_parse_1_loc couldnt_parse_1_length datasi) (alloc_data "\nError: Couldn't parse:\n" datasi)) - ( couldnt_parse_1_msg_val (bor (<< couldnt_parse_1_length 32) couldnt_parse_1_loc #b011)) - ((couldnt_parse_2_loc couldnt_parse_2_length datasi) (alloc_data "\nAt character:\n" datasi)) - ( couldnt_parse_2_msg_val (bor (<< couldnt_parse_2_length 32) couldnt_parse_2_loc #b011)) - ((parse_remaining_loc parse_remaining_length datasi) (alloc_data "\nLeft over after parsing, starting at byte offset:\n" datasi)) - ( parse_remaining_msg_val (bor (<< parse_remaining_length 32) parse_remaining_loc #b011)) - - ((quote_sym_loc quote_sym_length datasi) (alloc_data "quote" datasi)) - (quote_sym_val (bor (<< quote_sym_length 32) quote_sym_loc #b111)) - - ; 0 is path_open, 1 is fd_read, 2 is fd_write - ;(num_pre_functions 2) - (num_pre_functions 3) - ((func_idx funcs) (array num_pre_functions (array))) - - ; malloc allocates with size and refcount in header - ((k_malloc func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$malloc '(param $bytes i32) '(result i32) '(local $result i32) '(local $ptr i32) '(local $last i32) '(local $pages i32) - (local.set '$bytes (i32.add (i32.const 8) (local.get '$bytes))) - (local.set '$result (i32.const 0)) - (_if '$has_head - (i32.ne (i32.const 0) (global.get '$malloc_head)) - (then - (local.set '$ptr (global.get '$malloc_head)) - (local.set '$last (i32.const 0)) - (_loop '$l - (_if '$fits - (i32.ge_u (i32.load 0 (local.get '$ptr)) (local.get '$bytes)) - (then - (local.set '$result (local.get '$ptr)) - (_if '$head - (i32.eq (local.get '$result) (global.get '$malloc_head)) - (then - (global.set '$malloc_head (i32.load 4 (global.get '$malloc_head))) - ) - (else - (i32.store 4 (local.get '$last) (i32.load 4 (local.get '$result))) - ) - ) - ) - (else - (local.set '$last (local.get '$ptr)) - (local.set '$ptr (i32.load 4 (local.get '$ptr))) - (br_if '$l (i32.ne (i32.const 0) (local.get '$ptr))) - ) - ) - ) - ) - ) - (_if '$result_0 - (i32.eqz (local.get '$result)) - (then - (local.set '$pages (i32.add (i32.const 1) (i32.shr_u (local.get '$bytes) (i32.const 16)))) - (local.set '$result (i32.shl (memory.grow (local.get '$pages)) (i32.const 16))) - (i32.store 0 (local.get '$result) (i32.shl (local.get '$pages) (i32.const 16))) - ) - ) - (i32.store 4 (local.get '$result) (i32.const 1)) - (i32.add (local.get '$result) (i32.const 8)) - )))) - - ((k_free func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$free '(param $bytes i32) - ;(local.set '$bytes (i32.sub (local.get '$bytes) (i32.const 8))) - ;(i32.store 4 (local.get '$bytes) (global.get '$malloc_head)) - ;(global.set '$malloc_head (local.get '$bytes)) - )))) - - ((k_get_ptr func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$get_ptr '(param $bytes i64) '(result i32) - (_if '$is_not_string_symbol_array_int '(result i32) - (i64.eq (i64.const #b001) (i64.and (i64.const #b111) (local.get '$bytes))) - (then - (_if '$is_true_false '(result i32) - (i64.eq (i64.const #b11001) (i64.and (i64.const #b11111) (local.get '$bytes))) - (then (i32.const 0)) - (else - (_if '$is_env '(result i32) - (i64.eq (i64.const #b01001) (i64.and (i64.const #b11111) (local.get '$bytes))) - (then (i32.wrap_i64 (i64.shr_u (local.get '$bytes) (i64.const 5)))) - (else (i32.wrap_i64 (i64.and (i64.const #xFFFFFFF8) (i64.shr_u (local.get '$bytes) (i64.const 3))))) ; is comb - ) - ) - ) - ) - (else - (_if '$is_int '(result i32) - (i64.eq (i64.const #b0) (i64.and (i64.const #b1) (local.get '$bytes))) - (then (i32.const 0)) - (else (i32.wrap_i64 (i64.and (i64.const -8) (local.get '$bytes)))) ; str symbol and array all get ptrs just masking FFFFFFF8 - ) - ) - ) - )))) - ((k_dup func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$dup '(param $bytes i64) '(result i64) '(local $ptr i32) '(local $old_val i32) - (local.set '$ptr (call '$get_ptr (local.get '$bytes))) - (_if '$not_null - (i32.ne (i32.const 0) (local.get '$ptr)) - (then - (local.set '$ptr (i32.sub (local.get '$ptr) (i32.const 8))) - (_if '$not_max_neg - ;(i32.ne (i32.const (- #x80000000)) (local.tee '$old_val (i32.load 4 (local.get '$ptr)))) - (i32.gt_s (local.tee '$old_val (i32.load 4 (local.get '$ptr))) (i32.const 0)) - (then - (i32.store 4 (local.get '$ptr) (i32.add (local.get '$old_val) (i32.const 1))) - ) - ) - ) - ) - (local.get '$bytes) - )))) - ((k_drop func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$drop '(param $it i64) '(local $ptr i32) '(local $old_val i32) '(local $new_val i32) '(local $i i32) - (local.set '$ptr (call '$get_ptr (local.get '$it))) - (_if '$not_null - (i32.ne (i32.const 0) (local.get '$ptr)) - (then - (_if '$not_max_neg - ;(i32.ne (i32.const (- #x80000000)) (local.tee '$old_val (i32.load (i32.add (i32.const -4) (local.get '$ptr))))) - (i32.gt_s (local.tee '$old_val (i32.load (i32.add (i32.const -4) (local.get '$ptr)))) (i32.const 0)) - (then - (_if '$zero - (i32.eqz (local.tee '$new_val (i32.sub (local.get '$old_val) (i32.const 1)))) - (then - (_if '$needs_inner_drop - (i64.eq (i64.const #b01) (i64.and (i64.const #b11) (local.get '$it))) - (then - (_if '$is_array - (i64.eq (i64.const #b101) (i64.and (i64.const #b111) (local.get '$it))) - (then - (local.set '$i (i32.wrap_i64 (i64.shr_u (local.get '$it) (i64.const 32)))) - (_loop '$l - (call '$drop (i64.load (local.get '$ptr))) - (local.set '$ptr (i32.add (local.get '$ptr) (i32.const 8))) - (local.set '$i (i32.sub (local.get '$i) (i32.const 1))) - (br_if '$l (i32.ne (i32.const 0) (local.get '$i))) - ) - ) - (else - (call '$drop (i64.load 0 (local.get '$ptr))) - (call '$drop (i64.load 8 (local.get '$ptr))) - (call '$drop (i64.load 16 (local.get '$ptr))) - ) - ) - ) - ) - (call '$free (local.get '$ptr)) - ) - (else (i32.store (i32.add (i32.const -4) (local.get '$ptr)) (local.get '$new_val))) - ) - ) - ) - ) - ) - )))) - - ; 0..001001 - ((k_env_alloc func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$env_alloc '(param $keys i64) '(param $vals i64) '(param $upper i64) '(result i64) '(local $tmp i32) - (local.set '$tmp (call '$malloc (i32.const (* 8 3)))) - (i64.store 0 (local.get '$tmp) (local.get '$keys)) - (i64.store 8 (local.get '$tmp) (local.get '$vals)) - (i64.store 16 (local.get '$tmp) (local.get '$upper)) - (i64.or (i64.shl (i64.extend_i32_u (local.get '$tmp)) (i64.const 5)) (i64.const #b01001)) - )))) - - ; 101 / 0..0 101 - ((k_array1_alloc func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$array1_alloc '(param $item i64) '(result i64) '(local $tmp i32) - (local.set '$tmp (call '$malloc (i32.const 8))) - (i64.store 0 (local.get '$tmp) (local.get '$item)) - (i64.or (i64.extend_i32_u (local.get '$tmp)) (i64.const #x0000000100000005)) - )))) - ((k_array2_alloc func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$array2_alloc '(param $a i64) '(param $b i64) '(result i64) '(local $tmp i32) - (local.set '$tmp (call '$malloc (i32.const 16))) - (i64.store 0 (local.get '$tmp) (local.get '$a)) - (i64.store 8 (local.get '$tmp) (local.get '$b)) - (i64.or (i64.extend_i32_u (local.get '$tmp)) (i64.const #x0000000200000005)) - )))) - - ; Not called with actual objects, not subject to refcounting - ((k_int_digits func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$int_digits '(param $int i64) '(result i32) '(local $tmp i32) - (_if '$is_neg - (i64.lt_s (local.get '$int) (i64.const 0)) - (then - (local.set '$int (i64.sub (i64.const 0) (local.get '$int))) - (local.set '$tmp (i32.const 2)) - ) - (else - (local.set '$tmp (i32.const 1)) - ) - ) - (block '$b - (_loop '$l - (br_if '$b (i64.le_u (local.get '$int) (i64.const 9))) - (local.set '$tmp (i32.add (i32.const 1) (local.get '$tmp))) - (local.set '$int (i64.div_u (local.get '$int) (i64.const 10))) - (br '$l) - ) - ) - (local.get '$tmp) - )))) - ; Utility method, not subject to refcounting - ((k_str_len func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$str_len '(param $to_str_len i64) '(result i32) '(local $running_len_tmp i32) '(local $i_tmp i32) '(local $x_tmp i32) '(local $y_tmp i32) '(local $ptr_tmp i32) '(local $item i64) - (_if '$is_true '(result i32) - (i64.eq (i64.const true_val) (local.get '$to_str_len)) - (then (i32.const true_length)) - (else - (_if '$is_false '(result i32) - (i64.eq (i64.const false_val) (local.get '$to_str_len)) - (then (i32.const false_length)) - (else - (_if '$is_str_or_symbol '(result i32) - (i64.eq (i64.const #b11) (i64.and (i64.const #b11) (local.get '$to_str_len))) - (then (_if '$is_str '(result i32) - (i64.eq (i64.const #b000) (i64.and (i64.const #b100) (local.get '$to_str_len))) - (then (i32.add (i32.const 2) (i32.wrap_i64 (i64.shr_u (local.get '$to_str_len) (i64.const 32))))) - (else (i32.add (i32.const 1) (i32.wrap_i64 (i64.shr_u (local.get '$to_str_len) (i64.const 32))))) - )) - (else - (_if '$is_array '(result i32) - (i64.eq (i64.const #b101) (i64.and (i64.const #b111) (local.get '$to_str_len))) - (then - (local.set '$running_len_tmp (i32.const 1)) - (local.set '$i_tmp (i32.wrap_i64 (i64.shr_u (local.get '$to_str_len) (i64.const 32)))) - (local.set '$x_tmp (i32.wrap_i64 (i64.and (local.get '$to_str_len) (i64.const -8)))) - (block '$b - (_loop '$l - (local.set '$running_len_tmp (i32.add (local.get '$running_len_tmp) (i32.const 1))) - (br_if '$b (i32.eq (local.get '$i_tmp) (i32.const 0))) - (local.set '$running_len_tmp (i32.add (local.get '$running_len_tmp) (call '$str_len (i64.load (local.get '$x_tmp))))) - (local.set '$x_tmp (i32.add (local.get '$x_tmp) (i32.const 8))) - (local.set '$i_tmp (i32.sub (local.get '$i_tmp) (i32.const 1))) - (br '$l) - ) - ) - (local.get '$running_len_tmp) - ) - (else - (_if '$is_env '(result i32) - (i64.eq (i64.const #b01001) (i64.and (i64.const #b11111) (local.get '$to_str_len))) - (then - (local.set '$running_len_tmp (i32.const 0)) - - ; ptr to env - (local.set '$ptr_tmp (i32.wrap_i64 (i64.shr_u (local.get '$to_str_len) (i64.const 5)))) - ; ptr to start of array of symbols - (local.set '$x_tmp (i32.wrap_i64 (i64.and (i64.load (local.get '$ptr_tmp)) (i64.const -8)))) - ; ptr to start of array of values - (local.set '$y_tmp (i32.wrap_i64 (i64.and (i64.load 8 (local.get '$ptr_tmp)) (i64.const -8)))) - ; lenght of both arrays, pulled from array encoding of x - (local.set '$i_tmp (i32.wrap_i64 (i64.shr_u (i64.load (local.get '$ptr_tmp)) (i64.const 32)))) - - (block '$b - (_loop '$l - (local.set '$running_len_tmp (i32.add (local.get '$running_len_tmp) (i32.const 2))) - ; break if 0 length left - (br_if '$b (i32.eq (local.get '$i_tmp) (i32.const 0))) - - (local.set '$running_len_tmp (i32.add (local.get '$running_len_tmp) - (call '$str_len (i64.load (local.get '$x_tmp))))) - (local.set '$running_len_tmp (i32.add (local.get '$running_len_tmp) - (call '$str_len (i64.load (local.get '$y_tmp))))) - (local.set '$running_len_tmp (i32.add (local.get '$running_len_tmp) (i32.const 2))) - - (local.set '$x_tmp (i32.add (local.get '$x_tmp) (i32.const 8))) - (local.set '$y_tmp (i32.add (local.get '$y_tmp) (i32.const 8))) - (local.set '$i_tmp (i32.sub (local.get '$i_tmp) (i32.const 1))) - (br '$l) - ) - ) - ;; deal with upper - (local.set '$item (i64.load 16 (local.get '$ptr_tmp))) - (_if '$is_upper_env - (i64.eq (i64.const #b01001) (i64.and (i64.const #b11111) (local.get '$item))) - (then - (local.set '$running_len_tmp (i32.add (local.get '$running_len_tmp) (i32.const 1))) - (local.set '$running_len_tmp (i32.add (local.get '$running_len_tmp) (call '$str_len (local.get '$item)))) - ) - ) - - (local.get '$running_len_tmp) - ) - (else - (_if '$is_comb '(result i32) - (i64.eq (i64.const #b0001) (i64.and (i64.const #b1111) (local.get '$to_str_len))) - (then - (i32.const 5) - ) - (else - ;; must be int - (call '$int_digits (i64.shr_s (local.get '$to_str_len) (i64.const 1))) - ) - ) - ) - ) - ) - ) - ) - ) - ) - ) - ) - ) - )))) - ; Utility method, not subject to refcounting - ((k_str_helper func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$str_helper '(param $to_str i64) '(param $buf i32) '(result i32) '(local $len_tmp i32) '(local $buf_tmp i32) '(local $ptr_tmp i32) '(local $x_tmp i32) '(local $y_tmp i32) '(local $i_tmp i32) '(local $item i64) - (_if '$is_true '(result i32) - (i64.eq (i64.const true_val) (local.get '$to_str)) - (then (memory.copy (local.get '$buf) - (i32.const true_loc) - (i32.const true_length)) - (i32.const true_length)) - (else - (_if '$is_false '(result i32) - (i64.eq (i64.const false_val) (local.get '$to_str)) - (then (memory.copy (local.get '$buf) - (i32.const false_loc) - (i32.const false_length)) - (i32.const false_length)) - (else - (_if '$is_str_or_symbol '(result i32) - (i64.eq (i64.const #b11) (i64.and (i64.const #b11) (local.get '$to_str))) - (then (_if '$is_str '(result i32) - (i64.eq (i64.const #b000) (i64.and (i64.const #b100) (local.get '$to_str))) - (then - (i32.store8 (local.get '$buf) (i32.const #x22)) - (memory.copy (i32.add (i32.const 1) (local.get '$buf)) - (i32.wrap_i64 (i64.and (i64.const -8) (local.get '$to_str))) - (local.tee '$len_tmp (i32.wrap_i64 (i64.shr_u (local.get '$to_str) (i64.const 32))))) - (i32.store8 1 (i32.add (local.get '$buf) (local.get '$len_tmp)) (i32.const #x22)) - (i32.add (i32.const 2) (local.get '$len_tmp)) - ) - (else - (i32.store8 (local.get '$buf) (i32.const #x27)) - (memory.copy (i32.add (i32.const 1) (local.get '$buf)) - (i32.wrap_i64 (i64.and (i64.const -8) (local.get '$to_str))) - (local.tee '$len_tmp (i32.wrap_i64 (i64.shr_u (local.get '$to_str) (i64.const 32))))) - (i32.add (i32.const 1) (local.get '$len_tmp)) - ) - )) - (else - (_if '$is_array '(result i32) - (i64.eq (i64.const #b101) (i64.and (i64.const #b101) (local.get '$to_str))) - (then - (local.set '$len_tmp (i32.const 0)) - (local.set '$i_tmp (i32.wrap_i64 (i64.shr_u (local.get '$to_str) (i64.const 32)))) - (local.set '$ptr_tmp (i32.wrap_i64 (i64.and (local.get '$to_str) (i64.const -8)))) - (block '$b - (_loop '$l - (i32.store8 (i32.add (local.get '$buf) (local.get '$len_tmp)) (i32.const #x20)) - (local.set '$len_tmp (i32.add (local.get '$len_tmp) (i32.const 1))) - (br_if '$b (i32.eq (local.get '$i_tmp) (i32.const 0))) - (local.set '$len_tmp (i32.add (local.get '$len_tmp) (call '$str_helper (i64.load (local.get '$ptr_tmp)) (i32.add (local.get '$buf) (local.get '$len_tmp))))) - (local.set '$ptr_tmp (i32.add (local.get '$ptr_tmp) (i32.const 8))) - (local.set '$i_tmp (i32.sub (local.get '$i_tmp) (i32.const 1))) - (br '$l) - ) - ) - (i32.store8 (local.get '$buf) (i32.const #x28)) - (i32.store8 (i32.add (local.get '$buf) (local.get '$len_tmp)) (i32.const #x29)) - (i32.add (local.get '$len_tmp) (i32.const 1)) - ) - (else - (_if '$is_env '(result i32) - (i64.eq (i64.const #b01001) (i64.and (i64.const #b11111) (local.get '$to_str))) - (then - (local.set '$len_tmp (i32.const 0)) - - ; ptr to env - (local.set '$ptr_tmp (i32.wrap_i64 (i64.shr_u (local.get '$to_str) (i64.const 5)))) - ; ptr to start of array of symbols - (local.set '$x_tmp (i32.wrap_i64 (i64.and (i64.load (local.get '$ptr_tmp)) (i64.const -8)))) - ; ptr to start of array of values - (local.set '$y_tmp (i32.wrap_i64 (i64.and (i64.load 8 (local.get '$ptr_tmp)) (i64.const -8)))) - ; lenght of both arrays, pulled from array encoding of x - (local.set '$i_tmp (i32.wrap_i64 (i64.shr_u (i64.load (local.get '$ptr_tmp)) (i64.const 32)))) - - (block '$b - (_loop '$l - (i32.store8 (i32.add (local.get '$buf) (local.get '$len_tmp)) (i32.const #x20)) - (local.set '$len_tmp (i32.add (local.get '$len_tmp) (i32.const 1))) - ; break if 0 length left - (br_if '$b (i32.eq (local.get '$i_tmp) (i32.const 0))) - - (local.set '$len_tmp (i32.add (local.get '$len_tmp) (call '$str_helper (i64.load (local.get '$x_tmp)) (i32.add (local.get '$buf) (local.get '$len_tmp))))) - (i32.store8 (i32.add (local.get '$len_tmp) (local.get '$buf)) (i32.const #x3A)) - (local.set '$len_tmp (i32.add (local.get '$len_tmp) (i32.const 1))) - (i32.store8 (i32.add (local.get '$len_tmp) (local.get '$buf)) (i32.const #x20)) - (local.set '$len_tmp (i32.add (local.get '$len_tmp) (i32.const 1))) - (local.set '$len_tmp (i32.add (local.get '$len_tmp) (call '$str_helper (i64.load (local.get '$y_tmp)) (i32.add (local.get '$buf) (local.get '$len_tmp))))) - (i32.store8 (i32.add (local.get '$len_tmp) (local.get '$buf)) (i32.const #x2C)) - (local.set '$len_tmp (i32.add (local.get '$len_tmp) (i32.const 1))) - - (local.set '$x_tmp (i32.add (local.get '$x_tmp) (i32.const 8))) - (local.set '$y_tmp (i32.add (local.get '$y_tmp) (i32.const 8))) - (local.set '$i_tmp (i32.sub (local.get '$i_tmp) (i32.const 1))) - (br '$l) - ) - ) - ;; deal with upper - (local.set '$item (i64.load 16 (local.get '$ptr_tmp))) - (_if '$is_upper_env - (i64.eq (i64.const #b01001) (i64.and (i64.const #b11111) (local.get '$item))) - (then - (i32.store8 -2 (i32.add (local.get '$buf) (local.get '$len_tmp)) (i32.const #x20)) - (i32.store8 -1 (i32.add (local.get '$buf) (local.get '$len_tmp)) (i32.const #x7C)) - (i32.store8 (i32.add (local.get '$len_tmp) (local.get '$buf)) (i32.const #x20)) - (local.set '$len_tmp (i32.add (local.get '$len_tmp) (i32.const 1))) - (local.set '$len_tmp (i32.add (local.get '$len_tmp) (call '$str_helper (local.get '$item) (i32.add (local.get '$buf) (local.get '$len_tmp))))) - ) - ) - (i32.store8 (local.get '$buf) (i32.const #x7B)) - (i32.store8 (i32.add (local.get '$buf) (local.get '$len_tmp)) (i32.const #x7D)) - (local.set '$len_tmp (i32.add (local.get '$len_tmp) (i32.const 1))) - (local.get '$len_tmp) - ) - (else - (_if '$is_comb '(result i32) - (i64.eq (i64.const #b0001) (i64.and (i64.const #b1111) (local.get '$to_str))) - (then - (i32.store (local.get '$buf) (i32.const #x626D6F63)) - (i32.store8 4 (local.get '$buf) - (i32.add (i32.const #x30) - (i32.and (i32.const #b11) - (i32.wrap_i64 (i64.shr_u (local.get '$to_str) (i64.const 4)))))) - (i32.const 5) - ) - (else - ;; must be int - (local.set '$to_str (i64.shr_s (local.get '$to_str) (i64.const 1))) - (local.set '$len_tmp (call '$int_digits (local.get '$to_str))) - (local.set '$buf_tmp (i32.add (local.get '$buf) (local.get '$len_tmp))) - - (_if '$is_neg - (i64.lt_s (local.get '$to_str) (i64.const 0)) - (then - (local.set '$to_str (i64.sub (i64.const 0) (local.get '$to_str))) - (i64.store8 (local.get '$buf) (i64.const #x2D)) - ) - ) - - (block '$b - (_loop '$l - (local.set '$buf_tmp (i32.sub (local.get '$buf_tmp) (i32.const 1))) - (i64.store8 (local.get '$buf_tmp) (i64.add (i64.const #x30) (i64.rem_u (local.get '$to_str) (i64.const 10)))) - (local.set '$to_str (i64.div_u (local.get '$to_str) (i64.const 10))) - (br_if '$b (i64.eq (local.get '$to_str) (i64.const 0))) - (br '$l) - ) - ) - - (local.get '$len_tmp) - ) - ) - ) - ) - ) - ) - ) - ) - ) - ) - ) - ) - )))) - ; Utility method, not subject to refcounting - ((k_print func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$print '(param $to_print i64) '(local $iov i32) '(local $data_size i32) - (local.set '$iov (call '$malloc (i32.add (i32.const 8) - (local.tee '$data_size (call '$str_len (local.get '$to_print)))))) - (drop (call '$str_helper (local.get '$to_print) (i32.add (i32.const 8) (local.get '$iov)))) - (i32.store (local.get '$iov) (i32.add (i32.const 8) (local.get '$iov))) ;; adder of data - (i32.store 4 (local.get '$iov) (local.get '$data_size)) ;; len of data - (drop (call '$fd_write - (i32.const 1) ;; file descriptor - (local.get '$iov) ;; *iovs - (i32.const 1) ;; iovs_len - (local.get '$iov) ;; nwritten - )) - (call '$free (local.get '$iov)) - )))) - - ; Utility method, but does refcount - ((k_slice_impl func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$slice_impl '(param $array i64) '(param $s i32) '(param $e i32) '(result i64) '(local $size i32) '(local $new_size i32) '(local $i i32) '(local $ptr i32) '(local $new_ptr i32) - (local.set '$size (i32.wrap_i64 (i64.shr_u (local.get '$array) (i64.const 32)))) - (local.set '$ptr (i32.wrap_i64 (i64.and (local.get '$array) (i64.const -8)))) - (_if '$s_lt_0 - (i32.lt_s (local.get '$s) (i32.const 0)) - (then - (local.set '$s (i32.add (i32.const 1) (i32.add (local.get '$s) (local.get '$size)))) - ) - ) - (_if '$e_lt_0 - (i32.lt_s (local.get '$e) (i32.const 0)) - (then - (local.set '$e (i32.add (i32.const 1) (i32.add (local.get '$e) (local.get '$size)))) - ) - ) - - (_if '$s_lt_0 (i32.lt_s (local.get '$s) (i32.const 0)) (then (unreachable))) - (_if '$e_lt_s (i32.lt_s (local.get '$e) (local.get '$s)) (then (unreachable))) - (_if '$e_gt_size (i32.gt_s (local.get '$e) (local.get '$size)) (then (unreachable))) - - (local.set '$new_size (i32.sub (local.get '$e) (local.get '$s))) - (_if '$new_size_0 '(result i64) - (i32.eqz (local.get '$new_size)) - (then - (i64.const nil_val) - ) - (else - (local.set '$new_ptr (call '$malloc (i32.shl (local.get '$new_size) (i32.const 3)))) ; malloc(size*8) - - (local.set '$i (i32.const 0)) - (block '$exit_loop - (_loop '$l - (br_if '$exit_loop (i32.eq (local.get '$i) (local.get '$new_size))) - (i64.store (i32.add (i32.shl (local.get '$i) (i32.const 3)) (local.get '$new_ptr)) - (call '$dup (i64.load (i32.add (i32.shl (i32.add (local.get '$s) (local.get '$i)) (i32.const 3)) (local.get '$ptr))))) ; n[i] = dup(o[i+s]) - (local.set '$i (i32.add (i32.const 1) (local.get '$i))) - (br '$l) - ) - ) - (call '$drop (local.get '$array)) - - (i64.or (i64.or (i64.extend_i32_u (local.get '$new_ptr)) (i64.const #x5)) - (i64.shl (i64.extend_i32_u (local.get '$new_size)) (i64.const 32))) - ) - ) - )))) - - ; chose k_slice_impl because it will never be called, so that - ; no function will have a 0 func index and count as falsy - (dyn_start (+ 0 k_slice_impl)) - - - ; This and is 1111100011 - ; The end ensuring 01 makes only - ; array comb env and bool apply - ; catching only 0array and false - ; and a comb with func idx 0 - ; and null env. If we prevent - ; this from happening, it's - ; exactly what we want - (truthy_test (lambda (x) (i64.ne (i64.const #b01) (i64.and (i64.const -29) x)))) - (falsey_test (lambda (x) (i64.eq (i64.const #b01) (i64.and (i64.const -29) x)))) - - (set_len_ptr (concat (local.set '$len (i32.wrap_i64 (i64.shr_u (local.get '$p) (i64.const 32)))) - (local.set '$ptr (i32.wrap_i64 (i64.and (local.get '$p) (i64.const -8)))) - )) - (ensure_not_op_n_params_set_ptr_len (lambda (op n) (concat set_len_ptr - (_if '$is_2_params - (op (local.get '$len) (i32.const n)) - (then - (call '$print (i64.const bad_params_number_msg_val)) - (unreachable) - ) - ) - ))) - (drop_p_d (concat - (call '$drop (local.get '$p)) - (call '$drop (local.get '$d)))) - - - - ((bad_not_vau_loc bad_not_vau_length datasi) (alloc_data "\nError: Trying to call a function (not vau) but the parameters caused a compile error\n" datasi)) - (bad_not_vau_msg_val (bor (<< bad_not_vau_length 32) bad_not_vau_loc #b011)) - - ((k_log_loc k_log_length datasi) (alloc_data "k_log" datasi)) - (k_log_msg_val (bor (<< k_log_length 32) k_log_loc #b011)) - ((k_log func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$log '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) - (call '$print (i64.const log_msg_val)) - (call '$print (local.get '$p)) - (call '$print (i64.const newline_msg_val)) - drop_p_d - (i64.const nil_val) - )))) - ((k_error_loc k_error_length datasi) (alloc_data "k_error" datasi)) - (k_error_msg_val (bor (<< k_error_length 32) k_error_loc #b011)) - ((k_error func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$error '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) - (call '$print (i64.const error_msg_val)) - (call '$print (local.get '$p)) - (call '$print (i64.const newline_msg_val)) - drop_p_d - (unreachable) - )))) - ((k_str_loc k_str_length datasi) (alloc_data "k_str" datasi)) - (k_str_msg_val (bor (<< k_str_length 32) k_str_loc #b011)) - ((k_str func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$str '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $buf i32) '(local $size i32) - (local.set '$buf (call '$malloc (local.tee '$size (call '$str_len (local.get '$p))))) - (drop (call '$str_helper (local.get '$p) (local.get '$buf))) - drop_p_d - (i64.or (i64.or (i64.shl (i64.extend_i32_u (local.get '$size)) (i64.const 32)) - (i64.extend_i32_u (local.get '$buf))) - (i64.const #b011)) - )))) - - (typecheck (dlambda (idx result_type op (mask value) then_branch else_branch) - (apply _if (concat (array '$matches) result_type - (array (op (i64.const value) (i64.and (i64.const mask) (i64.load (* 8 idx) (local.get '$ptr))))) - then_branch - else_branch - )) - )) - - (pred_func (lambda (name type_check) (func name '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $ptr i32) '(local $len i32) - (ensure_not_op_n_params_set_ptr_len i32.ne 1) - (typecheck 0 (array '(result i64)) - i64.eq type_check - (array (then (i64.const true_val))) - (array (else (i64.const false_val))) - ) - drop_p_d - ))) - - (type_assert (lambda (i type_check name_msg_val) - (typecheck i (array) - i64.ne type_check - (array (then - (call '$print (i64.const bad_params_type_msg_val)) - (call '$print (i64.const (<< i 1))) - (call '$print (i64.const space_msg_val)) - (call '$print (i64.const name_msg_val)) - (call '$print (i64.const space_msg_val)) - (call '$print (i64.load (* 8 i) (local.get '$ptr))) - (unreachable) - )) - nil - ) - )) - - (type_int (array #b1 #b0)) - (type_string (array #b111 #b011)) - (type_symbol (array #b111 #b111)) - (type_array (array #b111 #b101)) - (type_combiner (array #b1111 #b0001)) - (type_env (array #b11111 #b01001)) - (type_bool (array #b11111 #b11001)) - - ((k_nil_loc k_nil_length datasi) (alloc_data "k_nil" datasi)) - (k_nil_msg_val (bor (<< k_nil_length 32) k_nil_loc #b011)) - ((k_nil? func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (pred_func '$nil? (array -1 #x0000000000000005))))) - ((k_array_loc k_array_length datasi) (alloc_data "k_array" datasi)) - (k_array_msg_val (bor (<< k_array_length 32) k_array_loc #b011)) - ((k_array? func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (pred_func '$array? type_array)))) - ((k_bool_loc k_bool_length datasi) (alloc_data "k_bool" datasi)) - (k_bool_msg_val (bor (<< k_bool_length 32) k_bool_loc #b011)) - ((k_bool? func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (pred_func '$bool? type_bool)))) - ((k_env_loc k_env_length datasi) (alloc_data "k_env" datasi)) - (k_env_msg_val (bor (<< k_env_length 32) k_env_loc #b011)) - ((k_env? func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (pred_func '$env? type_env)))) - ((k_combiner_loc k_combiner_length datasi) (alloc_data "k_combiner" datasi)) - (k_combiner_msg_val (bor (<< k_combiner_length 32) k_combiner_loc #b011)) - ((k_combiner? func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (pred_func '$combiner type_combiner)))) - ((k_string_loc k_string_length datasi) (alloc_data "k_string" datasi)) - (k_string_msg_val (bor (<< k_string_length 32) k_string_loc #b011)) - ((k_string? func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (pred_func '$string? type_string)))) - ((k_int_loc k_int_length datasi) (alloc_data "k_int" datasi)) - (k_int_msg_val (bor (<< k_int_length 32) k_int_loc #b011)) - ((k_int? func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (pred_func '$int? type_int)))) - ((k_symbol_loc k_symbol_length datasi) (alloc_data "k_symbol" datasi)) - (k_symbol_msg_val (bor (<< k_symbol_length 32) k_symbol_loc #b011)) - ((k_symbol? func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (pred_func '$symbol? type_symbol)))) - - ((k_str_sym_comp func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$str_sym_comp '(param $a i64) '(param $b i64) '(param $lt_val i64) '(param $eq_val i64) '(param $gt_val i64) '(result i64) '(local $result i64) '(local $a_len i32) '(local $b_len i32) '(local $a_ptr i32) '(local $b_ptr i32) - (local.set '$result (local.get '$eq_val)) - (local.set '$a_len (i32.wrap_i64 (i64.shr_u (local.get '$a) (i64.const 32)))) - (local.set '$b_len (i32.wrap_i64 (i64.shr_u (local.get '$b) (i64.const 32)))) - (local.set '$a_ptr (i32.wrap_i64 (i64.and (local.get '$a) (i64.const #xFFFFFFF8)))) - (local.set '$b_ptr (i32.wrap_i64 (i64.and (local.get '$b) (i64.const #xFFFFFFF8)))) - (block '$b - (_if '$a_len_lt_b_len - (i32.lt_s (local.get '$a_len) (local.get '$b_len)) - (then (local.set '$result (local.get '$lt_val)) - (br '$b))) - (_if '$a_len_gt_b_len - (i32.gt_s (local.get '$a_len) (local.get '$b_len)) - (then (local.set '$result (local.get '$gt_val)) - (br '$b))) - - (_loop '$l - (br_if '$b (i32.eqz (local.get '$a_len))) - - (local.set '$a (i64.load8_u (local.get '$a_ptr))) - (local.set '$b (i64.load8_u (local.get '$b_ptr))) - - (_if '$a_lt_b - (i64.lt_s (local.get '$a) (local.get '$b)) - (then (local.set '$result (local.get '$lt_val)) - (br '$b))) - (_if '$a_gt_b - (i64.gt_s (local.get '$a) (local.get '$b)) - (then (local.set '$result (local.get '$gt_val)) - (br '$b))) - - (local.set '$a_len (i32.sub (local.get '$a_len) (i32.const 1))) - (local.set '$a_ptr (i32.add (local.get '$a_ptr) (i32.const 1))) - (local.set '$b_ptr (i32.add (local.get '$b_ptr) (i32.const 1))) - (br '$l) - ) - ) - (local.get '$result) - )))) - - ((k_comp_helper_helper func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$comp_helper_helper '(param $a i64) '(param $b i64) '(param $lt_val i64) '(param $eq_val i64) '(param $gt_val i64) '(result i64) '(local $result i64) '(local $a_tmp i32) '(local $b_tmp i32) '(local $a_ptr i32) '(local $b_ptr i32) '(local $result_tmp i64) - (block '$b - ;; INT - (_if '$a_int - (i64.eqz (i64.and (i64.const 1) (local.get '$a))) - (then - (_if '$b_int - (i64.eqz (i64.and (i64.const 1) (local.get '$b))) - (then - (_if '$a_lt_b - (i64.lt_s (local.get '$a) (local.get '$b)) - (then (local.set '$result (local.get '$lt_val)) - (br '$b))) - (_if '$a_gt_b - (i64.gt_s (local.get '$a) (local.get '$b)) - (then (local.set '$result (local.get '$gt_val)) - (br '$b))) - (local.set '$result (local.get '$eq_val)) - (br '$b) - ) - ) - ; Else, b is not an int, so a < b - (local.set '$result (local.get '$lt_val)) - (br '$b) - ) - ) - (_if '$b_int - (i64.eqz (i64.and (i64.const 1) (local.get '$b))) - (then - (local.set '$result (local.get '$gt_val)) - (br '$b)) - ) - ;; STRING - (_if '$a_string - (i64.eq (i64.const #b011) (i64.and (i64.const #b111) (local.get '$a))) - (then - (_if '$b_string - (i64.eq (i64.const #b011) (i64.and (i64.const #b111) (local.get '$b))) - (then - (local.set '$result (call '$str_sym_comp (local.get '$a) (local.get '$b) (local.get '$lt_val) (local.get '$eq_val) (local.get '$gt_val))) - (br '$b)) - ) - ; else b is not an int or string, so bigger - (local.set '$result (local.get '$lt_val)) - (br '$b) - ) - ) - (_if '$b_string - (i64.eq (i64.const #b011) (i64.and (i64.const #b111) (local.get '$b))) - (then - (local.set '$result (local.get '$gt_val)) - (br '$b)) - ) - ;; SYMBOL - (_if '$a_symbol - (i64.eq (i64.const #b111) (i64.and (i64.const #b111) (local.get '$a))) - (then - (_if '$b_symbol - (i64.eq (i64.const #b111) (i64.and (i64.const #b111) (local.get '$b))) - (then - (local.set '$result (call '$str_sym_comp (local.get '$a) (local.get '$b) (local.get '$lt_val) (local.get '$eq_val) (local.get '$gt_val))) - (br '$b)) - ) - ; else b is not an int or string or symbol, so bigger - (local.set '$result (local.get '$lt_val)) - (br '$b) - ) - ) - (_if '$b_symbol - (i64.eq (i64.const #b111) (i64.and (i64.const #b111) (local.get '$b))) - (then - (local.set '$result (local.get '$gt_val)) - (br '$b)) - ) - ;; ARRAY - (_if '$a_array - (i64.eq (i64.const #b101) (i64.and (i64.const #b111) (local.get '$a))) - (then - (_if '$b_array - (i64.eq (i64.const #b101) (i64.and (i64.const #b111) (local.get '$b))) - (then - (local.set '$a_tmp (i32.wrap_i64 (i64.shr_u (local.get '$a) (i64.const 32)))) - (local.set '$b_tmp (i32.wrap_i64 (i64.shr_u (local.get '$b) (i64.const 32)))) - - (_if '$a_len_lt_b_len - (i32.lt_s (local.get '$a_tmp) (local.get '$b_tmp)) - (then (local.set '$result (local.get '$lt_val)) - (br '$b))) - (_if '$a_len_gt_b_len - (i32.gt_s (local.get '$a_tmp) (local.get '$b_tmp)) - (then (local.set '$result (local.get '$gt_val)) - (br '$b))) - - (local.set '$a_ptr (i32.wrap_i64 (i64.and (local.get '$a) (i64.const #xFFFFFFF8)))) - (local.set '$b_ptr (i32.wrap_i64 (i64.and (local.get '$b) (i64.const #xFFFFFFF8)))) - - (_loop '$l - (br_if '$b (i32.eqz (local.get '$a_tmp))) - - (local.set '$result_tmp (call '$comp_helper_helper (i64.load (local.get '$a_ptr)) - (i64.load (local.get '$b_ptr)) - (i64.const -1) (i64.const 0) (i64.const 1))) - - (_if '$a_lt_b - (i64.eq (local.get '$result_tmp) (i64.const -1)) - (then (local.set '$result (local.get '$lt_val)) - (br '$b))) - (_if '$a_gt_b - (i64.eq (local.get '$result_tmp) (i64.const 1)) - (then (local.set '$result (local.get '$gt_val)) - (br '$b))) - - (local.set '$a_tmp (i32.sub (local.get '$a_tmp) (i32.const 1))) - (local.set '$a_ptr (i32.add (local.get '$a_ptr) (i32.const 8))) - (local.set '$b_ptr (i32.add (local.get '$b_ptr) (i32.const 8))) - (br '$l) - ) - (br '$b)) - ) - ; else b is not an int or string or symbol or array, so bigger - (local.set '$result (local.get '$lt_val)) - (br '$b) - ) - ) - (_if '$b_array - (i64.eq (i64.const #b111) (i64.and (i64.const #b111) (local.get '$b))) - (then - (local.set '$result (local.get '$gt_val)) - (br '$b)) - ) - ;; COMBINER - (_if '$a_comb - (i64.eq (i64.const #b0001) (i64.and (i64.const #b1111) (local.get '$a))) - (then - (_if '$b_comb - (i64.eq (i64.const #b0001) (i64.and (i64.const #b1111) (local.get '$b))) - (then - ; compare func indicies first - (local.set '$a_tmp (i32.wrap_i64 (i64.shr_u (local.get '$a) (i64.const 35)))) - (local.set '$b_tmp (i32.wrap_i64 (i64.shr_u (local.get '$b) (i64.const 35)))) - (_if '$a_tmp_lt_b_tmp - (i32.lt_s (local.get '$a_tmp) (local.get '$b_tmp)) - (then - (local.set '$result (local.get '$lt_val)) - (br '$b)) - ) - (_if '$a_tmp_eq_b_tmp - (i32.gt_s (local.get '$a_tmp) (local.get '$b_tmp)) - (then - (local.set '$result (local.get '$gt_val)) - (br '$b)) - ) - ; Idx was the same, so recursively comp envs - (local.set '$result (call '$comp_helper_helper (i64.or (i64.shl (i64.extend_i32_u (local.get '$a_tmp)) (i64.const 5)) (i64.const #b01001)) - (i64.or (i64.shl (i64.extend_i32_u (local.get '$b_tmp)) (i64.const 5)) (i64.const #b01001)) - (local.get '$lt_val) (local.get '$eq_val) (local.get '$gt_val))) - (br '$b)) - ) - ; else b is not an int or string or symbol or array or combiner, so bigger - (local.set '$result (local.get '$lt_val)) - (br '$b) - ) - ) - (_if '$b_comb - (i64.eq (i64.const #b0001) (i64.and (i64.const #b1111) (local.get '$b))) - (then - (local.set '$result (local.get '$gt_val)) - (br '$b)) - ) - ;; ENV - (_if '$a_env - (i64.eq (i64.const #b01001) (i64.and (i64.const #b11111) (local.get '$a))) - (then - (_if '$b_comb - (i64.eq (i64.const #b01001) (i64.and (i64.const #b11111) (local.get '$b))) - (then - (local.set '$a_ptr (i32.wrap_i64 (i64.shr_u (local.get '$a) (i64.const 5)))) - (local.set '$b_ptr (i32.wrap_i64 (i64.shr_u (local.get '$b) (i64.const 5)))) - - ; First, compare their symbol arrays - (local.set '$result_tmp (call '$comp_helper_helper (i64.load 0 (local.get '$a_ptr)) - (i64.load 0 (local.get '$b_ptr)) - (i64.const -1) (i64.const 0) (i64.const 1))) - (_if '$a_lt_b - (i64.eq (local.get '$result_tmp) (i64.const -1)) - (then (local.set '$result (local.get '$lt_val)) - (br '$b))) - (_if '$a_gt_b - (i64.eq (local.get '$result_tmp) (i64.const 1)) - (then (local.set '$result (local.get '$gt_val)) - (br '$b))) - - ; Second, compare their value arrays - (local.set '$result_tmp (call '$comp_helper_helper (i64.load 8 (local.get '$a_ptr)) - (i64.load 8 (local.get '$b_ptr)) - (i64.const -1) (i64.const 0) (i64.const 1))) - (_if '$a_lt_b - (i64.eq (local.get '$result_tmp) (i64.const -1)) - (then (local.set '$result (local.get '$lt_val)) - (br '$b))) - (_if '$a_gt_b - (i64.eq (local.get '$result_tmp) (i64.const 1)) - (then (local.set '$result (local.get '$gt_val)) - (br '$b))) - - ; Finally, just accept the result of recursion - (local.set '$result (call '$comp_helper_helper (i64.load 16 (local.get '$a_ptr)) - (i64.load 16 (local.get '$b_ptr)) - (local.get '$lt_val) (local.get '$eq_val) (local.get '$gt_val))) - - (br '$b)) - ) - ; else b is bool, so bigger - (local.set '$result (local.get '$lt_val)) - (br '$b) - ) - ) - (_if '$b_env - (i64.eq (i64.const #b01001) (i64.and (i64.const #b11111) (local.get '$b))) - (then - (local.set '$result (local.get '$gt_val)) - (br '$b)) - ) - ;; BOOL hehe - (_if '$a_lt_b - (i64.lt_s (local.get '$a) (local.get '$b)) - (then - (local.set '$result (local.get '$lt_val)) - (br '$b)) - ) - (_if '$a_eq_b - (i64.eq (local.get '$a) (local.get '$b)) - (then - (local.set '$result (local.get '$eq_val)) - (br '$b)) - ) - (local.set '$result (local.get '$gt_val)) - (br '$b) - ) - (local.get '$result) - )))) - - ((k_comp_helper func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$comp_helper '(param $p i64) '(param $d i64) '(param $s i64) '(param $lt_val i64) '(param $eq_val i64) '(param $gt_val i64) '(result i64) '(local $ptr i32) '(local $len i32) '(local $result i64) '(local $a i64) '(local $b i64) - set_len_ptr - (local.set '$result (i64.const true_val)) - (block '$b - (_loop '$l - (br_if '$b (i32.le_u (local.get '$len) (i32.const 1))) - (local.set '$a (i64.load (local.get '$ptr))) - (local.set '$ptr (i32.add (local.get '$ptr) (i32.const 8))) - (local.set '$b (i64.load (local.get '$ptr))) - (_if '$was_false - (i64.eq (i64.const false_val) (call '$comp_helper_helper (local.get '$a) (local.get '$b) (local.get '$lt_val) (local.get '$eq_val) (local.get '$gt_val))) - (then - (local.set '$result (i64.const false_val)) - (br '$b) - ) - ) - (local.set '$len (i32.sub (local.get '$len) (i32.const 1))) - (br '$l) - ) - ) - (local.get '$result) - drop_p_d - )))) - - ((k_eq_loc k_eq_length datasi) (alloc_data "k_eq" datasi)) - (k_eq_msg_val (bor (<< k_eq_length 32) k_eq_loc #b011)) - ((k_eq func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$eq '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) - (call '$comp_helper (local.get '$p) (local.get '$d) (local.get '$s) (i64.const false_val) (i64.const true_val) (i64.const false_val)) - )))) - ((k_neq_loc k_neq_length datasi) (alloc_data "k_neq" datasi)) - (k_neq_msg_val (bor (<< k_neq_length 32) k_neq_loc #b011)) - ((k_neq func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$neq '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) - (call '$comp_helper (local.get '$p) (local.get '$d) (local.get '$s) (i64.const true_val) (i64.const false_val) (i64.const true_val)) - )))) - ((k_geq_loc k_geq_length datasi) (alloc_data "k_geq" datasi)) - (k_geq_msg_val (bor (<< k_geq_length 32) k_geq_loc #b011)) - ((k_geq func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$geq '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) - (call '$comp_helper (local.get '$p) (local.get '$d) (local.get '$s) (i64.const false_val) (i64.const true_val) (i64.const true_val)) - )))) - ((k_gt_loc k_gt_length datasi) (alloc_data "k_gt" datasi)) - (k_gt_msg_val (bor (<< k_gt_length 32) k_gt_loc #b011)) - ((k_gt func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$gt '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) - (call '$comp_helper (local.get '$p) (local.get '$d) (local.get '$s) (i64.const false_val) (i64.const false_val) (i64.const true_val)) - )))) - ((k_leq_loc k_leq_length datasi) (alloc_data "k_leq" datasi)) - (k_leq_msg_val (bor (<< k_leq_length 32) k_leq_loc #b011)) - ((k_leq func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$leq '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) - (call '$comp_helper (local.get '$p) (local.get '$d) (local.get '$s) (i64.const true_val) (i64.const true_val) (i64.const false_val)) - )))) - ((k_lt_loc k_lt_length datasi) (alloc_data "k_lt" datasi)) - (k_lt_msg_val (bor (<< k_lt_length 32) k_lt_loc #b011)) - ((k_lt func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$lt '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) - (call '$comp_helper (local.get '$p) (local.get '$d) (local.get '$s) (i64.const true_val) (i64.const false_val) (i64.const false_val)) - )))) - - (math_function (lambda (name sensitive op) - (func name '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $ptr i32) '(local $len i32) '(local $i i32) '(local $cur i64) '(local $next i64) - (ensure_not_op_n_params_set_ptr_len i32.eq 0) - (local.set '$i (i32.const 1)) - (local.set '$cur (i64.load (local.get '$ptr))) - (_if '$not_num (i64.ne (i64.const 0) (i64.and (i64.const 1) (local.get '$cur))) - (then (unreachable)) - ) - (block '$b - (_loop '$l - (br_if '$b (i32.eq (local.get '$len) (local.get '$i))) - (local.set '$ptr (i32.add (i32.const 8) (local.get '$ptr))) - (local.set '$next (i64.load (local.get '$ptr))) - (_if '$not_num (i64.ne (i64.const 0) (i64.and (i64.const 1) (local.get '$next))) - (then (unreachable)) - ) - (local.set '$cur (if sensitive (i64.shl (op (i64.shr_s (local.get '$cur) (i64.const 1)) (i64.shr_s (local.get '$next) (i64.const 1))) (i64.const 1)) - (op (local.get '$cur) (local.get '$next)))) - (local.set '$i (i32.add (local.get '$i) (i32.const 1))) - (br '$l) - ) - ) - (local.get '$cur) - ) - )) - - ((k_mod_loc k_mod_length datasi) (alloc_data "k_mod" datasi)) - (k_mod_msg_val (bor (<< k_mod_length 32) k_mod_loc #b011)) - ((k_mod func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (math_function '$mod true i64.rem_s)))) - ((k_div_loc k_div_length datasi) (alloc_data "k_div" datasi)) - (k_div_msg_val (bor (<< k_div_length 32) k_div_loc #b011)) - ((k_div func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (math_function '$div true i64.div_s)))) - ((k_mul_loc k_mul_length datasi) (alloc_data "k_mul" datasi)) - (k_mul_msg_val (bor (<< k_mul_length 32) k_mul_loc #b011)) - ((k_mul func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (math_function '$mul true i64.mul)))) - ((k_sub_loc k_sub_length datasi) (alloc_data "k_sub" datasi)) - (k_sub_msg_val (bor (<< k_sub_length 32) k_sub_loc #b011)) - ((k_sub func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (math_function '$sub true i64.sub)))) - ((k_add_loc k_add_length datasi) (alloc_data "k_add" datasi)) - (k_add_msg_val (bor (<< k_add_length 32) k_add_loc #b011)) - ((k_add func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (math_function '$add false i64.add)))) - ((k_band_loc k_band_length datasi) (alloc_data "k_band" datasi)) - (k_band_msg_val (bor (<< k_band_length 32) k_band_loc #b011)) - ((k_band func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (math_function '$band false i64.and)))) - ((k_bor_loc k_bor_length datasi) (alloc_data "k_bor" datasi)) - (k_bor_msg_val (bor (<< k_bor_length 32) k_bor_loc #b011)) - ((k_bor func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (math_function '$bor false i64.or)))) - ((k_bxor_loc k_bxor_length datasi) (alloc_data "k_bxor" datasi)) - (k_bxor_msg_val (bor (<< k_bxor_length 32) k_bxor_loc #b011)) - ((k_bxor func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (math_function '$bxor false i64.xor)))) - - ((k_bnot_loc k_bnot_length datasi) (alloc_data "k_bnot" datasi)) - (k_bnot_msg_val (bor (<< k_bnot_length 32) k_bnot_loc #b011)) - ((k_bnot func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$bnot '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $ptr i32) '(local $len i32) - (ensure_not_op_n_params_set_ptr_len i32.ne 1) - (type_assert 0 type_int k_bnot_msg_val) - (i64.xor (i64.const -2) (i64.load (local.get '$ptr))) - drop_p_d - )))) - - ((k_ls_loc k_ls_length datasi) (alloc_data "k_ls" datasi)) - (k_ls_msg_val (bor (<< k_ls_length 32) k_ls_loc #b011)) - ((k_ls func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$ls '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $ptr i32) '(local $len i32) - (ensure_not_op_n_params_set_ptr_len i32.ne 2) - (type_assert 0 type_int k_ls_msg_val) - (type_assert 1 type_int k_ls_msg_val) - (i64.shl (i64.load 0 (local.get '$ptr)) (i64.shr_s (i64.load 8 (local.get '$ptr)) (i64.const 1))) - drop_p_d - )))) - ((k_rs_loc k_rs_length datasi) (alloc_data "k_rs" datasi)) - (k_rs_msg_val (bor (<< k_rs_length 32) k_rs_loc #b011)) - ((k_rs func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$rs '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $ptr i32) '(local $len i32) - (ensure_not_op_n_params_set_ptr_len i32.ne 2) - (type_assert 0 type_int k_rs_msg_val) - (type_assert 1 type_int k_rs_msg_val) - (i64.and (i64.const -2) (i64.shr_s (i64.load 0 (local.get '$ptr)) (i64.shr_s (i64.load 8 (local.get '$ptr)) (i64.const 1)))) - drop_p_d - )))) - - ((k_concat_loc k_concat_length datasi) (alloc_data "k_concat" datasi)) - (k_concat_msg_val (bor (<< k_concat_length 32) k_concat_loc #b011)) - ((k_concat func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$concat '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $ptr i32) '(local $len i32) '(local $size i32) '(local $i i32) '(local $it i64) '(local $new_ptr i32) '(local $inner_ptr i32) '(local $inner_size i32) '(local $new_ptr_traverse i32) - set_len_ptr - (local.set '$size (i32.const 0)) - (local.set '$i (i32.const 0)) - (block '$b - (_loop '$l - (br_if '$b (i32.eq (local.get '$len) (local.get '$i))) - (local.set '$it (i64.load (i32.add (i32.shl (local.get '$i) (i32.const 3)) (local.get '$ptr)))) - (_if '$not_array (i64.ne (i64.const #b101) (i64.and (i64.const #b111) (local.get '$it))) - (then (unreachable)) - ) - (local.set '$size (i32.add (local.get '$size) (i32.wrap_i64 (i64.shr_u (local.get '$it) (i64.const 32))))) - (local.set '$i (i32.add (local.get '$i) (i32.const 1))) - (br '$l) - ) - ) - (_if '$size_0 '(result i64) - (i32.eqz (local.get '$size)) - (then (i64.const nil_val)) - (else - (local.set '$new_ptr (call '$malloc (i32.shl (local.get '$size) (i32.const 3)))) ; malloc(size*8) - (local.set '$new_ptr_traverse (local.get '$new_ptr)) - - (local.set '$i (i32.const 0)) - (block '$exit_outer_loop - (_loop '$outer_loop - (br_if '$exit_outer_loop (i32.eq (local.get '$len) (local.get '$i))) - (local.set '$it (i64.load (i32.add (i32.shl (local.get '$i) (i32.const 3)) (local.get '$ptr)))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ; There's some serious optimization we could do here - ; Moving the items from the sub arrays to this one without - ; going through all the dup/drop - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (local.set '$inner_ptr (i32.wrap_i64 (i64.and (local.get '$it) (i64.const -8)))) - (local.set '$inner_size (i32.wrap_i64 (i64.shr_u (local.get '$it) (i64.const 32)))) - - (block '$exit_inner_loop - (_loop '$inner_loop - (br_if '$exit_inner_loop (i32.eqz (local.get '$inner_size))) - (i64.store (local.get '$new_ptr_traverse) - (call '$dup (i64.load (local.get '$inner_ptr)))) - (local.set '$inner_ptr (i32.add (local.get '$inner_ptr) (i32.const 8))) - (local.set '$new_ptr_traverse (i32.add (local.get '$new_ptr_traverse) (i32.const 8))) - (local.set '$inner_size (i32.sub (local.get '$inner_size) (i32.const 1))) - (br '$inner_loop) - ) - ) - (local.set '$i (i32.add (local.get '$i) (i32.const 1))) - (br '$outer_loop) - ) - ) - - (i64.or (i64.or (i64.extend_i32_u (local.get '$new_ptr)) (i64.const #x5)) - (i64.shl (i64.extend_i32_u (local.get '$size)) (i64.const 32))) - ) - ) - drop_p_d - )))) - ((k_slice_loc k_slice_length datasi) (alloc_data "k_slice" datasi)) - (k_slice_msg_val (bor (<< k_slice_length 32) k_slice_loc #b011)) - ((k_slice func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$slice '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $ptr i32) '(local $len i32) - (ensure_not_op_n_params_set_ptr_len i32.ne 3) - (type_assert 0 type_array k_slice_msg_val) - (type_assert 1 type_int k_slice_msg_val) - (type_assert 2 type_int k_slice_msg_val) - (call '$slice_impl (call '$dup (i64.load 0 (local.get '$ptr))) - (i32.wrap_i64 (i64.shr_s (i64.load 8 (local.get '$ptr)) (i64.const 1))) - (i32.wrap_i64 (i64.shr_s (i64.load 16 (local.get '$ptr)) (i64.const 1)))) - drop_p_d - )))) - ((k_idx_loc k_idx_length datasi) (alloc_data "k_idx" datasi)) - (k_idx_msg_val (bor (<< k_idx_length 32) k_idx_loc #b011)) - ((k_idx func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$idx '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $ptr i32) '(local $len i32) '(local $array i64) '(local $idx i32) '(local $size i32) - (ensure_not_op_n_params_set_ptr_len i32.ne 2) - (type_assert 0 type_array k_idx_msg_val) - (type_assert 1 type_int k_idx_msg_val) - (local.set '$array (i64.load 0 (local.get '$ptr))) - (local.set '$idx (i32.wrap_i64 (i64.shr_s (i64.load 8 (local.get '$ptr)) (i64.const 1)))) - (local.set '$size (i32.wrap_i64 (i64.shr_u (local.get '$array) (i64.const 32)))) - - (_if '$i_lt_0 (i32.lt_s (local.get '$idx) (i32.const 0)) (then (unreachable))) - (_if '$i_ge_s (i32.ge_s (local.get '$idx) (local.get '$size)) (then (unreachable))) - - (call '$dup (i64.load (i32.add (i32.wrap_i64 (i64.and (local.get '$array) (i64.const -8))) - (i32.shl (local.get '$idx) (i32.const 3))))) - drop_p_d - )))) - ((k_len_loc k_len_length datasi) (alloc_data "k_len" datasi)) - (k_len_msg_val (bor (<< k_len_length 32) k_len_loc #b011)) - ((k_len func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$len '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $ptr i32) '(local $len i32) - (ensure_not_op_n_params_set_ptr_len i32.ne 1) - (type_assert 0 type_array k_len_msg_val) - (i64.and (i64.shr_u (i64.load 0 (local.get '$ptr)) (i64.const 31)) (i64.const -2)) - drop_p_d - )))) - ((k_array_loc k_array_length datasi) (alloc_data "k_array" datasi)) - (k_array_msg_val (bor (<< k_array_length 32) k_array_loc #b011)) - ((k_array func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$array '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) - (local.get '$p) - (call '$drop (local.get '$d)) - ; s is 0 - )))) - - ((k_get_loc k_get_length datasi) (alloc_data "k_get" datasi)) - (k_get_msg_val (bor (<< k_get_length 32) k_get_loc #b011)) - ((k_get-text func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$get-text '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $ptr i32) '(local $len i32) - (ensure_not_op_n_params_set_ptr_len i32.ne 1) - (type_assert 0 type_symbol k_get_msg_val) - (call '$dup (i64.and (i64.const -5) (i64.load (local.get '$ptr)))) - drop_p_d - )))) - ((k_str_loc k_str_length datasi) (alloc_data "k_str" datasi)) - (k_str_msg_val (bor (<< k_str_length 32) k_str_loc #b011)) - ((k_str-to-symbol func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$str-to-symbol '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $ptr i32) '(local $len i32) - (ensure_not_op_n_params_set_ptr_len i32.ne 1) - (type_assert 0 type_string k_str_msg_val) - (call '$dup (i64.or (i64.const #b100) (i64.load (local.get '$ptr)))) - drop_p_d - )))) - - ((k_unwrap_loc k_unwrap_length datasi) (alloc_data "k_unwrap" datasi)) - (k_unwrap_msg_val (bor (<< k_unwrap_length 32) k_unwrap_loc #b011)) - ((k_unwrap func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$unwrap '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $ptr i32) '(local $len i32) '(local $comb i64) '(local $wrap_level i64) - (ensure_not_op_n_params_set_ptr_len i32.ne 1) - (type_assert 0 type_combiner k_unwrap_msg_val) - (local.set '$comb (i64.load (local.get '$ptr))) - (local.set '$wrap_level (i64.and (i64.shr_u (local.get '$comb) (i64.const 4)) (i64.const #b11))) - (_if '$wrap_level_0 - (i64.eqz (local.get '$wrap_level)) - (then (unreachable)) - ) - (call '$dup (i64.or (i64.and (local.get '$comb) (i64.const -49)) - (i64.shl (i64.sub (local.get '$wrap_level) (i64.const 1)) (i64.const 4)))) - drop_p_d - )))) - ((k_wrap_loc k_wrap_length datasi) (alloc_data "k_wrap" datasi)) - (k_wrap_msg_val (bor (<< k_wrap_length 32) k_wrap_loc #b011)) - ((k_wrap func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$wrap '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $ptr i32) '(local $len i32) '(local $comb i64) '(local $wrap_level i64) - (ensure_not_op_n_params_set_ptr_len i32.ne 1) - (type_assert 0 type_combiner k_wrap_msg_val) - (local.set '$comb (i64.load (local.get '$ptr))) - (local.set '$wrap_level (i64.and (i64.shr_u (local.get '$comb) (i64.const 4)) (i64.const #b11))) - (_if '$wrap_level_3 - (i64.eq (i64.const 3) (local.get '$wrap_level)) - (then (unreachable)) - ) - (call '$dup (i64.or (i64.and (local.get '$comb) (i64.const -49)) - (i64.shl (i64.add (local.get '$wrap_level) (i64.const 1)) (i64.const 4)))) - drop_p_d - )))) - - ((k_lapply_loc k_lapply_length datasi) (alloc_data "k_lapply" datasi)) - (k_lapply_msg_val (bor (<< k_lapply_length 32) k_lapply_loc #b011)) - ((k_lapply func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$lapply '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $ptr i32) '(local $len i32) '(local $comb i64) '(local $params i64) '(local $wrap_level i64) - (ensure_not_op_n_params_set_ptr_len i32.ne 2) - (type_assert 0 type_combiner k_lapply_msg_val) - (type_assert 1 type_array k_lapply_msg_val) - (local.set '$comb (call '$dup (i64.load 0 (local.get '$ptr)))) - (local.set '$params (call '$dup (i64.load 8 (local.get '$ptr)))) - (call '$drop (local.get '$d)) - (local.set '$wrap_level (i64.and (i64.shr_u (local.get '$comb) (i64.const 4)) (i64.const #b11))) - (_if '$wrap_level_ne_1 - (i64.ne (i64.const 1) (local.get '$wrap_level)) - (then (unreachable)) - ) - - (call_indirect - ;type - k_wrap - ;table - 0 - ;params - (local.get '$params) - ; pass through d env - (local.get '$d) - ; static env - (i64.or (i64.shl (i64.and (local.get '$comb) (i64.const #x3FFFFFFC0)) - (i64.const 2)) (i64.const #b01001)) - ;func_idx - (i32.wrap_i64 (i64.shr_u (local.get '$comb) (i64.const 35))) - ) - )))) - - ((k_vapply_loc k_vapply_length datasi) (alloc_data "k_vapply" datasi)) - (k_vapply_msg_val (bor (<< k_vapply_length 32) k_vapply_loc #b011)) - ((k_vapply func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$vapply '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $ptr i32) '(local $len i32) '(local $comb i64) '(local $params i64) '(local $wrap_level i64) '(local $denv i64) - (ensure_not_op_n_params_set_ptr_len i32.ne 3) - (type_assert 0 type_combiner k_vapply_msg_val) - (type_assert 1 type_array k_vapply_msg_val) - (type_assert 2 type_env k_vapply_msg_val) - (local.set '$comb (call '$dup (i64.load 0 (local.get '$ptr)))) - (local.set '$params (call '$dup (i64.load 8 (local.get '$ptr)))) - (local.set '$denv (call '$dup (i64.load 16 (local.get '$ptr)))) - drop_p_d - (local.set '$wrap_level (i64.and (i64.shr_u (local.get '$comb) (i64.const 4)) (i64.const #b11))) - (_if '$wrap_level_ne_0 - (i64.ne (i64.const 0) (local.get '$wrap_level)) - (then (unreachable)) - ) - - (call_indirect - ;type - k_wrap - ;table - 0 - ;params - (local.get '$params) - ; passed in denv, not our $d env - (local.get '$denv) - ; static env - (i64.or (i64.shl (i64.and (local.get '$comb) (i64.const #x3FFFFFFC0)) - (i64.const 2)) (i64.const #b01001)) - ;func_idx - (i32.wrap_i64 (i64.shr_u (local.get '$comb) (i64.const 35))) - ) - )))) - - ;true_val #b000111001 - ;false_val #b00001100) - (empty_parse_value #b00101100) - (close_peren_value #b01001100) - (error_parse_value #b01101100) - ; *GLOBAL ALERT* - ((k_parse_helper func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$parse_helper '(result i64) '(local $result i64) '(local $tmp i32) '(local $sub_result i64) '(local $asiz i32) '(local $acap i32) '(local $aptr i32) '(local $bptr i32) '(local $bcap i32) '(local $neg_multiplier i64) '(local $radix i64) - (block '$b1 - (block '$b2 - (_loop '$l - (br_if '$b2 (i32.eqz (global.get '$phl))) - (local.set '$tmp (i32.load8_u (global.get '$phs))) - (call '$print (i64.shl (i64.extend_i32_u (local.get '$tmp)) (i64.const 1))) - (_if '$whitespace (i32.or (i32.or (i32.eq (i32.const #x9) (local.get '$tmp)) ; tab - (i32.eq (i32.const #xA) (local.get '$tmp))) ; newline - (i32.or (i32.eq (i32.const #xD) (local.get '$tmp)) ; carrige return - (i32.eq (i32.const #x20) (local.get '$tmp)))) ; space - (then - (global.set '$phs (i32.add (global.get '$phs) (i32.const 1))) - (global.set '$phl (i32.sub (global.get '$phl) (i32.const 1))) - (br '$l) - ) - ) - (_if '$comment (i32.eq (i32.const #x3B) (local.get '$tmp)) - (then - (_loop '$li - (global.set '$phs (i32.add (global.get '$phs) (i32.const 1))) - (global.set '$phl (i32.sub (global.get '$phl) (i32.const 1))) - (br_if '$b2 (i32.eqz (global.get '$phl))) - (local.set '$tmp (i32.load8_u (global.get '$phs))) - (br_if '$li (i32.ne (i32.const #xA) (local.get '$tmp))) - ) - (br '$l) - ) - ) - ) - ) - (local.set '$result (i64.const empty_parse_value)) - (_if '$at_least1 - (i32.ge_u (global.get '$phl) (i32.const 1)) - (then - (local.set '$tmp (i32.load8_u (global.get '$phs))) - ; string - (_if '$is_open - (i32.eq (local.get '$tmp) (i32.const #x22)) - (then - (global.set '$phs (i32.add (global.get '$phs) (i32.const 1))) - (global.set '$phl (i32.sub (global.get '$phl) (i32.const 1))) - (local.set '$asiz (i32.const 0)) - (local.set '$bptr (global.get '$phs)) - - ; Count size - (block '$b2 - (_loop '$il - (_if '$doesnt_have_next - (i32.eqz (global.get '$phl)) - (then - (local.set '$result (i64.const error_parse_value)) - (br '$b1) - ) - ) - - (br_if '$b2 (i32.eq (i32.load8_u (global.get '$phs)) (i32.const #x22))) - - (_if '$an_escape - (i32.eq (i32.load8_u (global.get '$phs)) (i32.const #x5C)) - (then - (global.set '$phs (i32.add (global.get '$phs) (i32.const 1))) - (global.set '$phl (i32.sub (global.get '$phl) (i32.const 1))) - (_if '$doesnt_have_next - (i32.eqz (global.get '$phl)) - (then - (local.set '$result (i64.const error_parse_value)) - (br '$b1) - ) - ) - ) - ) - (local.set '$asiz (i32.add (local.get '$asiz) (i32.const 1))) - - (global.set '$phs (i32.add (global.get '$phs) (i32.const 1))) - (global.set '$phl (i32.sub (global.get '$phl) (i32.const 1))) - (br '$il) - ) - ) - - (global.set '$phs (i32.add (global.get '$phs) (i32.const 1))) - (global.set '$phl (i32.sub (global.get '$phl) (i32.const 1))) - - (local.set '$bcap (local.get '$asiz)) - (local.set '$aptr (call '$malloc (local.get '$asiz))) - - ; copy the bytes, implementing the escapes - (block '$b2 - (_loop '$il - (br_if '$b2 (i32.eqz (local.get '$bcap))) - - (_if '$an_escape - (i32.eq (i32.load8_u (local.get '$bptr)) (i32.const #x5C)) - (then - (_if '$escaped_slash - (i32.eq (i32.load8_u 1 (local.get '$bptr)) (i32.const #x5C)) - (then - (i32.store8 (local.get '$aptr) (i32.const #x5C)) - ) - (else - (_if '$escaped_quote - (i32.eq (i32.load8_u 1 (local.get '$bptr)) (i32.const #x22)) - (then - (i32.store8 (local.get '$aptr) (i32.const #x22)) - ) - (else - (_if '$escaped_newline - (i32.eq (i32.load8_u 1 (local.get '$bptr)) (i32.const #x6E)) - (then - (i32.store8 (local.get '$aptr) (i32.const #x0A)) - ) - (else - (_if '$escaped_tab - (i32.eq (i32.load8_u 1 (local.get '$bptr)) (i32.const #x74)) - (then - (i32.store8 (local.get '$aptr) (i32.const #x09)) - ) - (else - (global.set '$phl (i32.add (global.get '$phl) (i32.sub (global.get '$phs) (local.get '$bptr)))) - (global.set '$phs (local.get '$bptr)) - (local.set '$result (i64.const error_parse_value)) - (br '$b1) - ) - ) - ) - ) - ) - ) - ) - ) - (local.set '$bptr (i32.add (local.get '$bptr) (i32.const 2))) - ) - (else - (i32.store8 (local.get '$aptr) (i32.load8_u (local.get '$bptr))) - (local.set '$bptr (i32.add (local.get '$bptr) (i32.const 1))) - ) - ) - (local.set '$bcap (i32.sub (local.get '$bcap) (i32.const 1))) - (local.set '$aptr (i32.add (local.get '$aptr) (i32.const 1))) - (br '$il) - ) - ) - (local.set '$aptr (i32.sub (local.get '$aptr) (local.get '$asiz))) - (local.set '$result (i64.or (i64.or (i64.extend_i32_u (local.get '$aptr)) (i64.const #x3)) - (i64.shl (i64.extend_i32_u (local.get '$asiz)) (i64.const 32)))) - (br '$b1) - ) - ) - - ; negative int - (local.set '$neg_multiplier (i64.const 1)) - (_if '$is_dash_and_more - (i32.and (i32.eq (local.get '$tmp) (i32.const #x2D)) (i32.ge_u (global.get '$phl) (i32.const 2))) - (then - (_if '$next_is_letter - (i32.and (i32.ge_u (i32.load8_u 1 (global.get '$phs)) (i32.const #x30)) (i32.le_u (i32.load8_u 1 (global.get '$phs)) (i32.const #x39))) - (then - (global.set '$phs (i32.add (global.get '$phs) (i32.const 1))) - (global.set '$phl (i32.sub (global.get '$phl) (i32.const 1))) - (local.set '$tmp (i32.load8_u (global.get '$phs))) - (local.set '$neg_multiplier (i64.const -1)) - ) - ) - ) - ) - ; int - (local.set '$radix (i64.const 10)) - (_if '$is_zero_through_nine - (i32.and (i32.ge_u (local.get '$tmp) (i32.const #x30)) (i32.le_u (local.get '$tmp) (i32.const #x39))) - (then - (local.set '$result (i64.const 0)) - (_loop '$il - (_if '$is_zero_through_nine_inner - (i32.and (i32.ge_u (local.get '$tmp) (i32.const #x30)) (i32.le_u (local.get '$tmp) (i32.const #x39))) - (then - (local.set '$tmp (i32.sub (local.get '$tmp) (i32.const #x30))) - ) - (else - (local.set '$tmp (i32.sub (local.get '$tmp) (i32.const #x37))) - ) - ) - (local.set '$result (i64.add (i64.mul (local.get '$radix) (local.get '$result)) (i64.extend_i32_u (local.get '$tmp)))) - (global.set '$phs (i32.add (global.get '$phs) (i32.const 1))) - (global.set '$phl (i32.sub (global.get '$phl) (i32.const 1))) - (_if '$at_least1 - (i32.ge_u (global.get '$phl) (i32.const 1)) - (then - (local.set '$tmp (i32.load8_u (global.get '$phs))) - (_if '$is_hex_and_more - (i32.and (i32.eq (local.get '$tmp) (i32.const #x78)) (i32.ge_u (global.get '$phl) (i32.const 2))) - (then - (global.set '$phs (i32.add (global.get '$phs) (i32.const 1))) - (global.set '$phl (i32.sub (global.get '$phl) (i32.const 1))) - (local.set '$tmp (i32.load8_u (global.get '$phs))) - (local.set '$radix (i64.const 16)) - ) - (else - (_if '$is_hex_and_more - (i32.and (i32.eq (local.get '$tmp) (i32.const #x62)) (i32.ge_u (global.get '$phl) (i32.const 2))) - (then - (global.set '$phs (i32.add (global.get '$phs) (i32.const 1))) - (global.set '$phl (i32.sub (global.get '$phl) (i32.const 1))) - (local.set '$tmp (i32.load8_u (global.get '$phs))) - (local.set '$radix (i64.const 2)) - ) - ) - ) - ) - (br_if '$il (i32.or (i32.and (i32.ge_u (local.get '$tmp) (i32.const #x30)) (i32.le_u (local.get '$tmp) (i32.const #x39))) - (i32.and (i32.ge_u (local.get '$tmp) (i32.const #x41)) (i32.le_u (local.get '$tmp) (i32.const #x46))))) - ) - ) - ) - (local.set '$result (i64.shl (i64.mul (local.get '$neg_multiplier) (local.get '$result)) (i64.const 1))) - (br '$b1) - ) - ) - - ; []? - ; ' - (_if '$is_quote - (i32.eq (local.get '$tmp) (i32.const #x27)) - (then - (global.set '$phs (i32.add (global.get '$phs) (i32.const 1))) - (global.set '$phl (i32.sub (global.get '$phl) (i32.const 1))) - (local.set '$sub_result (call '$parse_helper)) - (_if '$ended - (i64.eq (i64.const close_peren_value) (local.get '$sub_result)) - (then - (local.set '$result (i64.const error_parse_value)) - (br '$b1) - ) - ) - (_if '$error - (i32.or (i64.eq (i64.const error_parse_value) (local.get '$sub_result)) - (i64.eq (i64.const empty_parse_value) (local.get '$sub_result))) - (then - (local.set '$result (local.get '$sub_result)) - (br '$b1) - ) - ) - (local.set '$result (call '$array2_alloc (i64.const quote_sym_val) (local.get '$sub_result))) - (br '$b1) - ) - ) - - ; symbol - (_if '$is_dash_and_more - ; 21 ! - ; 22 " X - ; 23-26 #-& - ; 27 ' X - ; 28-29 (-) X - ; 2A-2F *-/ - ; 30-39 0-9 / - ; 3A : - ; 3B ; - ; 3C-40 <-@ - ; 41-5A A-Z - ; 5B-60 [-` - ; 61-7A a-z - ; 7B-7E {-~ - (i32.or (i32.or (i32.eq (local.get '$tmp) (i32.const #x21)) - (i32.and (i32.ge_u (local.get '$tmp) (i32.const #x23)) (i32.le_u (local.get '$tmp) (i32.const #x26)))) - (i32.or (i32.and (i32.ge_u (local.get '$tmp) (i32.const #x2A)) (i32.le_u (local.get '$tmp) (i32.const #x2F))) - (i32.or (i32.eq (local.get '$tmp) (i32.const #x3A)) - (i32.and (i32.ge_u (local.get '$tmp) (i32.const #x3C)) (i32.le_u (local.get '$tmp) (i32.const #x7E)))))) - (then - (local.set '$asiz (i32.const 0)) - (local.set '$bptr (global.get '$phs)) - (block '$loop_break - (_loop '$il - (global.set '$phs (i32.add (global.get '$phs) (i32.const 1))) - (global.set '$phl (i32.sub (global.get '$phl) (i32.const 1))) - (local.set '$asiz (i32.add (local.get '$asiz) (i32.const 1))) - (_if '$doesnt_have_next - (i32.eqz (global.get '$phl)) - (then (br '$loop_break)) - ) - (local.set '$tmp (i32.load8_u (global.get '$phs))) - (br_if '$il (i32.or (i32.or (i32.eq (local.get '$tmp) (i32.const #x21)) - (i32.and (i32.ge_u (local.get '$tmp) (i32.const #x23)) (i32.le_u (local.get '$tmp) (i32.const #x26)))) - (i32.or (i32.and (i32.ge_u (local.get '$tmp) (i32.const #x2A)) (i32.le_u (local.get '$tmp) (i32.const #x3A))) - (i32.and (i32.ge_u (local.get '$tmp) (i32.const #x3C)) (i32.le_u (local.get '$tmp) (i32.const #x7E)))))) - ) - ) - (_if '$is_true1 - (i32.eq (local.get '$asiz) (i32.const 4)) - (then - (_if '$is_true2 - (i32.eq (i32.load (local.get '$bptr)) (i32.const #x65757274)) - (then - (local.set '$result (i64.const true_val)) - (br '$b1) - ) - ) - ) - ) - (_if '$is_false1 - (i32.eq (local.get '$asiz) (i32.const 5)) - (then - (_if '$is_false2 - (i32.and (i32.eq (i32.load (local.get '$bptr)) (i32.const #x736C6166)) (i32.eq (i32.load8_u 4 (local.get '$bptr)) (i32.const #x65))) - (then - (local.set '$result (i64.const false_val)) - (br '$b1) - ) - ) - ) - ) - (local.set '$aptr (call '$malloc (local.get '$asiz))) - (memory.copy (local.get '$aptr) - (local.get '$bptr) - (local.get '$asiz)) - (local.set '$result (i64.or (i64.or (i64.extend_i32_u (local.get '$aptr)) (i64.const #x7)) - (i64.shl (i64.extend_i32_u (local.get '$asiz)) (i64.const 32)))) - (br '$b1) - ) - ) - - ; lists (arrays)! - (_if '$is_open - (i32.eq (local.get '$tmp) (i32.const #x28)) - (then - (global.set '$phs (i32.add (global.get '$phs) (i32.const 1))) - (global.set '$phl (i32.sub (global.get '$phl) (i32.const 1))) - (local.set '$asiz (i32.const 0)) - (local.set '$acap (i32.const 4)) - (local.set '$aptr (call '$malloc (i32.const (* 4 8)))) - (_loop '$il - (local.set '$sub_result (call '$parse_helper)) - (_if '$ended - (i64.eq (i64.const close_peren_value) (local.get '$sub_result)) - (then - (_if '$nil - (i32.eqz (local.get '$asiz)) - (then - (call '$free (local.get '$aptr)) - (local.set '$result (i64.const nil_val)) - ) - (else - (local.set '$result (i64.or (i64.or (i64.extend_i32_u (local.get '$aptr)) (i64.const #x5)) - (i64.shl (i64.extend_i32_u (local.get '$asiz)) (i64.const 32)))) - ) - ) - (br '$b1) - ) - ) - (_if '$error - (i32.or (i64.eq (i64.const error_parse_value) (local.get '$sub_result)) - (i64.eq (i64.const empty_parse_value) (local.get '$sub_result))) - (then - (local.set '$result (local.get '$sub_result)) - (br '$b1) - ) - ) - (_if '$need_to_grow - (i32.eq (local.get '$asiz) (local.get '$acap)) - (then - (local.set '$bcap (i32.shl (local.get '$acap) (i32.const 1))) - (local.set '$bptr (call '$malloc (i32.shl (local.get '$bcap) (i32.const 3)))) - (local.set '$asiz (i32.const 0)) - (_loop '$iil - (i64.store (i32.add (local.get '$bptr) (i32.shl (local.get '$asiz) (i32.const 3))) - (i64.load (i32.add (local.get '$aptr) (i32.shl (local.get '$asiz) (i32.const 3))))) - (local.set '$asiz (i32.add (local.get '$asiz) (i32.const 1))) - (br_if '$iil (i32.lt_u (local.get '$asiz) (local.get '$acap))) - ) - (local.set '$acap (local.get '$bcap)) - (call '$free (local.get '$aptr)) - (local.set '$aptr (local.get '$bptr)) - ) - ) - (i64.store (i32.add (local.get '$aptr) (i32.shl (local.get '$asiz) (i32.const 3))) - (local.get '$sub_result)) - (local.set '$asiz (i32.add (local.get '$asiz) (i32.const 1))) - (br '$il) - ) - ) - ) - (_if '$is_close - (i32.eq (local.get '$tmp) (i32.const #x29)) - (then - (local.set '$result (i64.const close_peren_value)) - (global.set '$phs (i32.add (global.get '$phs) (i32.const 1))) - (global.set '$phl (i32.sub (global.get '$phl) (i32.const 1))) - (br '$b1) - ) - ) - ) - ) - ) - (local.get '$result) - )))) - ((k_read_loc k_read_length datasi) (alloc_data "k_read" datasi)) - (k_read_msg_val (bor (<< k_read_length 32) k_read_loc #b011)) - ((k_read-string func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$read-string '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $ptr i32) '(local $len i32) '(local $str i64) '(local $result i64) '(local $tmp_result i64) '(local $tmp_offset i32) - (ensure_not_op_n_params_set_ptr_len i32.ne 1) - (type_assert 0 type_string k_read_msg_val) - (local.set '$str (i64.load (local.get '$ptr))) - (call '$print (local.get '$str)) - (global.set '$phl (i32.wrap_i64 (i64.shr_u (local.get '$str) (i64.const 32)))) - (global.set '$phs (i32.wrap_i64 (i64.and (local.get '$str) (i64.const #xFFFFFFF8)))) - (local.set '$result (call '$parse_helper)) - (_if '$was_empty_parse - (i32.or (i64.eq (i64.const error_parse_value) (local.get '$result)) - (i32.or (i64.eq (i64.const empty_parse_value) (local.get '$result)) - (i64.eq (i64.const close_peren_value) (local.get '$result)))) - (then - (call '$print (i64.const couldnt_parse_1_msg_val)) - (call '$print (local.get '$str)) - (call '$print (i64.const couldnt_parse_2_msg_val)) - (call '$print (i64.shl (i64.add (i64.const 1) (i64.sub (i64.shr_u (local.get '$str) (i64.const 32)) (i64.extend_i32_u (global.get '$phl)))) (i64.const 1))) - (call '$print (i64.const newline_msg_val)) - (unreachable) - ) - ) - (_if '$remaining - (i32.ne (i32.const 0) (global.get '$phl)) - (then - (local.set '$tmp_offset (global.get '$phl)) - (local.set '$tmp_result (call '$parse_helper)) - (_if '$wasnt_empty_parse - (i64.ne (i64.const empty_parse_value) (local.get '$tmp_result)) - (then - (call '$print (i64.const parse_remaining_msg_val)) - (call '$print (i64.shl (i64.sub (i64.shr_u (local.get '$str) (i64.const 32)) (i64.extend_i32_u (local.get '$tmp_offset))) (i64.const 1))) - (call '$print (i64.const newline_msg_val)) - (unreachable) - ) - ) - ) - ) - (local.get '$result) - drop_p_d - )))) - ((k_eval_loc k_eval_length datasi) (alloc_data "k_eval" datasi)) - (k_eval_msg_val (bor (<< k_eval_length 32) k_eval_loc #b011)) - ((k_eval func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$eval '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) - - (call '$print (i64.const remaining_eval_msg_val)) - (unreachable) - )))) - ((k_vau_loc k_vau_length datasi) (alloc_data "k_vau" datasi)) - (k_vau_msg_val (bor (<< k_vau_length 32) k_vau_loc #b011)) - ((k_vau func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$vau '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) - (call '$print (i64.const remaining_vau_msg_val)) - (unreachable) - )))) - ((k_cond_loc k_cond_length datasi) (alloc_data "k_cond" datasi)) - (k_cond_msg_val (bor (<< k_cond_length 32) k_cond_loc #b011)) - ((k_cond func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$cond '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) - (call '$print (i64.const remaining_cond_msg_val)) - (unreachable) - )))) - - (get_passthrough (dlambda (hash (datasi funcs memo env pectx)) (let ((r (get-value-or-false memo hash))) - (if r (array r nil nil (array datasi funcs memo env pectx)) #f)))) - - ; This is the second run at this, and is a little interesting - ; It can return a value OR code OR an error string. An error string should be propegated, - ; unless it was expected as a possiblity, which can happen when compling a call that may or - ; may not be a Vau. When it recurses, if the thing you're currently compiling could be a value - ; but your recursive calls return code, you will likely have to swap back to code. - - ; ctx is (datasi funcs memo env pectx) - ; return is (value? code? error? (datasi funcs memo env pectx)) - (compile-inner (rec-lambda compile-inner (ctx c need_value) (cond - ((val? c) (let ((v (.val c))) - (cond ((int? v) (array (<< v 1) nil nil ctx)) - ((= true v) (array true_val nil nil ctx)) - ((= false v) (array false_val nil nil ctx)) - ((str? v) (or (get_passthrough (.hash c) ctx) - (dlet ( ((datasi funcs memo env pectx) ctx) - ((c_loc c_len datasi) (alloc_data v datasi)) - (a (bor (<< c_len 32) c_loc #b011)) - (memo (put memo (.hash c) a)) - ) (array a nil nil (array datasi funcs memo env pectx))))) - (true (error (str "Can't compile impossible value " v)))))) - ((marked_symbol? c) (cond ((.marked_symbol_is_val c) (or ;(begin (print "pre get_passthrough " (.hash c) "ctx is " ctx ) - (get_passthrough (.hash c) ctx) - ;) - (dlet ( ((datasi funcs memo env pectx) ctx) - ((c_loc c_len datasi) (alloc_data (symbol->string (.marked_symbol_value c)) datasi)) - (result (bor (<< c_len 32) c_loc #b111)) - (memo (put memo (.hash c) result)) - ) (array result nil nil (array datasi funcs memo env pectx))))) - - - - (true (dlet ( ((datasi funcs memo env pectx) ctx) - ; not a recoverable error, so just do here - (_ (if (= nil env) (error "nil env when trying to compile a non-value symbol"))) - (lookup_helper (rec-lambda lookup-recurse (dict key i code) (cond - ((and (= i (- (len dict) 1)) (= nil (idx dict i))) (array nil (str "for code-symbol lookup, couldn't find " key))) - ((= i (- (len dict) 1)) (lookup-recurse (.env_marked (idx dict i)) key 0 (i64.load 16 (i32.wrap_i64 (i64.shr_u code (call '$print (i64.const going_up_msg_val)) (i64.const 5)))))) - ((= key (idx (idx dict i) 0)) (array (i64.load (* 8 i) ; offset in array to value - (i32.wrap_i64 (i64.and (i64.const -8) ; get ptr from array value - (i64.load 8 (i32.wrap_i64 (i64.shr_u code - (i64.const 5)) (call '$print (i64.const got_it_msg_val)) ))))) nil)) - (true (lookup-recurse dict key (+ i 1) code))))) - - - ((val err) (lookup_helper (.env_marked env) (.marked_symbol_value c) 0 (concat - (call '$print (i64.const starting_from_msg_val)) - (call '$print (local.get '$s_env)) - (local.get '$s_env)))) - (err (mif err (str "got " err ", started searching in " (str_strip env)) (if need_value (str "needed value, but non val symbol " (.marked_symbol_value c)) nil))) - (result (mif val (call '$dup val))) - ) (array nil result err (array datasi funcs memo env pectx)))))) - ((marked_array? c) (if (.marked_array_is_val c) (or (get_passthrough (.hash c) ctx) - (let ((actual_len (len (.marked_array_values c)))) - (if (= 0 actual_len) (array nil_val nil nil ctx) - (dlet (((comp_values err ctx) (foldr (dlambda (x (a err ctx)) (dlet (((v c e ctx) (compile-inner ctx x need_value))) - (array (cons v a) (or (mif err err false) (mif e e false) (mif c (str "got code " c) false)) ctx))) (array (array) nil ctx) (.marked_array_values c))) - ) (mif err (array nil nil (str err ", from an array value compile " (str_strip c)) ctx) (dlet ( - ((datasi funcs memo env pectx) ctx) - ((c_loc c_len datasi) (alloc_data (apply concat (map i64_le_hexify comp_values)) datasi)) - (result (bor (<< actual_len 32) c_loc #b101)) - (memo (put memo (.hash c) result)) - ) (array result nil nil (array datasi funcs memo env pectx)))))))) - - (if need_value (array nil nil (str "errr, needed value and was call " (str_strip c)) ctx) - (if (= 0 (len (.marked_array_values c))) (array nil nil (str "errr, empty call array" (str_strip c)) ctx) - (dlet ( - - ; This can weirdly cause infinate recursion on the compile side, if partial_eval - ; returns something that, when compiled, will cause partial eval to return that thing again. - ; Partial eval won't recurse infinately, since it has memo, but it can return something of that - ; shape in that case which will cause compile to keep stepping. - - ((datasi funcs memo env pectx) ctx) - (hit_recursion (= 'RECURSE_FAIL (get-value-or-false memo (.hash c)))) - - (compile_params (lambda (unval_and_eval ctx params) - (foldr (dlambda (x (a err ctx)) (dlet ( - - ((datasi funcs memo env pectx) ctx) - ((x err ctx) (mif err (array nil err ctx) - (if (not unval_and_eval) (array x err ctx) - (dlet ( - ((ok x) (try_unval x (lambda (_) nil))) - (err (if (not ok) "couldn't unval in compile" err)) - - ; TODO: This might fail because we don't have the real env stack, which we *should*! - ; In the mean time, if it does, just fall back to the non-more-evaled ones. - ((pectx e pex) (if (or (!= nil err) hit_recursion) - (array pectx err nil) - (partial_eval_helper x false env (array) pectx 1 false))) - - (ctx (array datasi funcs memo env pectx)) - - ) (array (mif e x pex) err ctx))))) - ((datasi funcs memo env pectx) ctx) - (memo (put memo (.hash c) 'RECURSE_FAIL)) - (ctx (array datasi funcs memo env pectx)) - ((val code err ctx) (mif err (array nil nil err ctx) - (compile-inner ctx x false))) - ((datasi funcs memo env pectx) ctx) - (memo (put memo (.hash c) 'RECURSE_OK)) - (ctx (array datasi funcs memo env pectx)) - ) (array (cons (mif val (i64.const val) code) a) err ctx))) - - (array (array) nil ctx) params))) - - (func_param_values (.marked_array_values c)) - (num_params (- (len func_param_values) 1)) - (params (slice func_param_values 1 -1)) - (func_value (idx func_param_values 0)) - ((param_codes err ctx) (compile_params false ctx params)) - - (wrap_level (if (or (comb? func_value) (prim_comb? func_value)) (.any_comb_wrap_level func_value) nil)) - ; I don't think it makes any sense for a function literal to have wrap > 0 - (_ (if (and (!= nil wrap_level) (> wrap_level 0)) (error "call to function literal has wrap >0"))) - - ;; Insert test for the function being a constant to inline - ;; Namely, vcond - ) (cond - ((!= nil err) (array nil nil (str err " from function params (non-unval-evaled) in call " (str_strip c)) ctx)) - ((and (prim_comb? func_value) (= (.prim_comb_sym func_value) 'vcond)) - (mif err (array nil nil (str err " from function params in call to comb " (str_strip c)) ctx) - (dlet ( - ((datasi funcs memo env pectx) ctx) - ) (array nil ((rec-lambda recurse (codes i) (cond - ((< i (- (len codes) 1)) (_if '_cond_flat '(result i64) - (truthy_test (idx codes i)) - (then (idx codes (+ i 1))) - (else (recurse codes (+ i 2))) - )) - ((= i (- (len codes) 1)) (error "compiling bad length comb")) - (true (unreachable)) - )) param_codes 0) err ctx)))) - (true (dlet ( - ((func_val func_code func_err ctx) (compile-inner ctx func_value false)) - ;(_ (print_strip "func val " func_val " func code " func_code " func err " func_err " param_codes " param_codes " err " err " from " func_value)) - (func_code (mif func_val (i64.const func_val) func_code)) - ((unval_param_codes err ctx) (compile_params true ctx params)) - ((bad_unval_params_msg_val _ _ ctx) (compile-inner ctx (marked_val (str "error was with unval-evaling parameters of " (str_strip c))) true)) - (result_code (concat - func_code - (local.set '$tmp) - (_if '$is_wrap_0 - (i64.eq (i64.const #x00) (i64.and (local.get '$tmp) (i64.const #x30))) - (then - (local.get '$tmp) ; saving ito restore it - (apply concat param_codes) - (local.set '$param_ptr (call '$malloc (i32.const (* 8 num_params)))) - (flat_map (lambda (i) (i64.store (* i 8) (local.set '$tmp) (local.get '$param_ptr) (local.get '$tmp))) - (range (- num_params 1) -1)) - (local.set '$tmp) ; restoring tmp - ) - (else - (_if '$is_wrap_1 - (i64.eq (i64.const #x10) (i64.and (local.get '$tmp) (i64.const #x30))) - (then - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ; Since we're not sure if it's going to be a vau or not, - ; this code might not be compilable, so we gracefully handle - ; compiler errors and instead emit code that throws the error if this - ; spot is ever reached at runtime. - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (mif err (concat (call '$print (i64.const bad_not_vau_msg_val)) - (call '$print (i64.const bad_unval_params_msg_val)) - (unreachable)) - (concat - (local.get '$tmp) ; saving ito restore it - (apply concat unval_param_codes) - (local.set '$param_ptr (call '$malloc (i32.const (* 8 num_params)))) - (flat_map (lambda (i) (i64.store (* i 8) (local.set '$tmp) (local.get '$param_ptr) (local.get '$tmp))) - (range (- num_params 1) -1)) - (local.set '$tmp) ; restoring tmp - )) - ) - (else - ; TODO: Handle other wrap levels - (call '$print (i64.const weird_wrap_msg_val)) - (unreachable) - ) - ) - ) - ) - (call_indirect - ;type - k_vau - ;table - 0 - ;params - (i64.or (i64.extend_i32_u (local.get '$param_ptr)) - (i64.const (bor (<< num_params 32) #x5))) - ;dynamic env (is caller's static env) - (call '$dup (local.get '$s_env)) - ; static env - (i64.or (i64.shl (i64.and (local.get '$tmp) (i64.const #x3FFFFFFC0)) - (i64.const 2)) (i64.const #b01001)) - ;func_idx - (i32.wrap_i64 (i64.shr_u (local.get '$tmp) (i64.const 35))) - ))) - ) (array nil result_code func_err ctx))) - )))))) - - ((marked_env? c) (or (get_passthrough (.hash c) ctx) (dlet ((e (.env_marked c)) - - (generate_env_access (dlambda ((datasi funcs memo env pectx) env_id reason) ((rec-lambda recurse (code this_env) - (cond - ((= env_id (.marked_env_idx this_env)) (array nil (call '$dup code) nil (array datasi funcs memo env pectx))) - ((= nil (.marked_env_upper this_env)) (array nil nil (str "bad env, upper is nil and we haven't found " env_id ", (this is *possiblely* because we're not recreating val/notval chains?) maxing out at " (str_strip this_env) ", having started at " (str_strip env) ", we're generating because " reason) (array datasi funcs memo env pectx))) - (true (recurse (i64.load 16 (i32.wrap_i64 (i64.shr_u code (i64.const 5)))) - (.marked_env_upper this_env))) - ) - ) (local.get '$s_env) env))) - - ) (if (not (marked_env_real? c)) (begin (print_strip "env wasn't real: " (marked_env_real? c) ", so generating access (env was) " c) (if need_value (array nil nil (str "marked env not real, though we need_value: " (str_strip c)) ctx) (generate_env_access ctx (.marked_env_idx c) "it wasn't real: " (str_strip c)))) - (dlet ( - - - ((kvs vvs ctx) (foldr (dlambda ((k v) (ka va ctx)) (dlet (((kv _ _ ctx) (compile-inner ctx (marked_symbol nil k) true)) - ((vv code err ctx) (compile-inner ctx v need_value)) - ;(_ (print_strip "result of (kv is " kv ") v compile-inner vv " vv " code " code " err " err ", based on " v)) - ;(_ (if (= nil vv) (print_strip "VAL NIL CODE IN ENV B/C " k " = " v) nil)) - ;(_ (if (!= nil err) (print_strip "ERRR IN ENV B/C " err " " k " = " v) nil)) - ) - (if (= false ka) (array false va ctx) - (if (or (= nil vv) (!= nil err)) (array false (str "vv was " vv " err is " err " and we needed_value? " need_value " based on v " (str_strip v)) ctx) - (array (cons kv ka) (cons vv va) ctx))))) - (array (array) (array) ctx) - (slice e 0 -2))) - - ((uv ucode err ctx) (mif (idx e -1) (compile-inner ctx (idx e -1) need_value) - (array nil_val nil nil ctx))) - ) (mif (or (= false kvs) (= nil uv) (!= nil err)) (begin (print_strip "kvs " kvs " vvs " vvs " uv " uv " or err " err " based off of " c) (if need_value (array nil nil (str "had to generate env access (course " need_value ") for " (str_strip c) "vvs is " vvs " err was " err) ctx) (generate_env_access ctx (.marked_env_idx c) (str " vvs " vvs " uv " uv " or err " err " based off of " (str_strip c))))) - (dlet ( - ((datasi funcs memo env pectx) ctx) - ((kvs_array datasi) (if (= 0 (len kvs)) (array nil_val datasi) - (dlet (((kvs_loc kvs_len datasi) (alloc_data (apply concat (map i64_le_hexify kvs)) datasi))) - (array (bor (<< (len kvs) 32) kvs_loc #b101) datasi)))) - ((vvs_array datasi) (if (= 0 (len vvs)) (array nil_val datasi) - (dlet (((vvs_loc vvs_len datasi) (alloc_data (apply concat (map i64_le_hexify vvs)) datasi))) - (array (bor (<< (len vvs) 32) vvs_loc #b101) datasi)))) - (all_hex (map i64_le_hexify (array kvs_array vvs_array uv))) - ((c_loc c_len datasi) (alloc_data (apply concat all_hex) datasi)) - (result (bor (<< c_loc 5) #b01001)) - (memo (put memo (.hash c) result)) - ) (array result nil nil (array datasi funcs memo env pectx))))))))) - - ((prim_comb? c) (cond ((= 'vau (.prim_comb_sym c)) (array (bor (<< (- k_vau dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) - ((= 'cond (.prim_comb_sym c)) (array (bor (<< (- k_cond dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) - ((= 'eval (.prim_comb_sym c)) (array (bor (<< (- k_eval dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) - ((= 'read-string (.prim_comb_sym c)) (array (bor (<< (- k_read-string dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) - ((= 'log (.prim_comb_sym c)) (array (bor (<< (- k_log dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) - ((= 'error (.prim_comb_sym c)) (array (bor (<< (- k_error dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) - ((= 'str (.prim_comb_sym c)) (array (bor (<< (- k_str dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) - ((= '>= (.prim_comb_sym c)) (array (bor (<< (- k_geq dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) - ((= '> (.prim_comb_sym c)) (array (bor (<< (- k_gt dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) - ((= '<= (.prim_comb_sym c)) (array (bor (<< (- k_leq dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) - ((= '< (.prim_comb_sym c)) (array (bor (<< (- k_lt dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) - ((= '!= (.prim_comb_sym c)) (array (bor (<< (- k_neq dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) - ((= '= (.prim_comb_sym c)) (array (bor (<< (- k_eq dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) - ((= '% (.prim_comb_sym c)) (array (bor (<< (- k_mod dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) - ((= '/ (.prim_comb_sym c)) (array (bor (<< (- k_div dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) - ((= '* (.prim_comb_sym c)) (array (bor (<< (- k_mul dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) - ((= '+ (.prim_comb_sym c)) (array (bor (<< (- k_add dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) - ((= '- (.prim_comb_sym c)) (array (bor (<< (- k_sub dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) - ((= 'band (.prim_comb_sym c)) (array (bor (<< (- k_band dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) - ((= 'bor (.prim_comb_sym c)) (array (bor (<< (- k_bor dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) - ((= 'bxor (.prim_comb_sym c)) (array (bor (<< (- k_bxor dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) - ((= 'bnot (.prim_comb_sym c)) (array (bor (<< (- k_bnot dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) - ((= '<< (.prim_comb_sym c)) (array (bor (<< (- k_ls dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) - ((= '>> (.prim_comb_sym c)) (array (bor (<< (- k_rs dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) - ((= 'array (.prim_comb_sym c)) (array (bor (<< (- k_array dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) - ((= 'concat (.prim_comb_sym c)) (array (bor (<< (- k_concat dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) - ((= 'slice (.prim_comb_sym c)) (array (bor (<< (- k_slice dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) - ((= 'idx (.prim_comb_sym c)) (array (bor (<< (- k_idx dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) - ((= 'len (.prim_comb_sym c)) (array (bor (<< (- k_len dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) - ((= 'array? (.prim_comb_sym c)) (array (bor (<< (- k_array? dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) - ((= 'get-text (.prim_comb_sym c)) (array (bor (<< (- k_get-text dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) - ((= 'str-to-symbol (.prim_comb_sym c)) (array (bor (<< (- k_str-to-symbol dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) - ((= 'bool? (.prim_comb_sym c)) (array (bor (<< (- k_bool? dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) - ((= 'nil? (.prim_comb_sym c)) (array (bor (<< (- k_nil? dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) - ((= 'env? (.prim_comb_sym c)) (array (bor (<< (- k_env? dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) - ((= 'combiner? (.prim_comb_sym c)) (array (bor (<< (- k_combiner? dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) - ((= 'string? (.prim_comb_sym c)) (array (bor (<< (- k_string? dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) - ((= 'int? (.prim_comb_sym c)) (array (bor (<< (- k_int? dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) - ((= 'symbol? (.prim_comb_sym c)) (array (bor (<< (- k_symbol? dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) - ((= 'unwrap (.prim_comb_sym c)) (array (bor (<< (- k_unwrap dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) - ((= 'vapply (.prim_comb_sym c)) (array (bor (<< (- k_vapply dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) - ((= 'lapply (.prim_comb_sym c)) (array (bor (<< (- k_lapply dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) - ((= 'wrap (.prim_comb_sym c)) (array (bor (<< (- k_wrap dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) - (true (error (str "Can't compile prim comb " (.prim_comb_sym c) " right now"))))) - - - - - ((comb? c) (dlet ( - (maybe_func (get_passthrough (.hash c) ctx)) - ((func_value _ func_err ctx) (mif maybe_func maybe_func - (dlet ( - ((wrap_level env_id de? se variadic params body) (.comb c)) - ((name_msg_value _ _ ctx) (compile-inner ctx (marked_val (str "\n\ncalling function " (true_str_strip c) " with: ")) true)) - - ; This can be optimized for common cases, esp with no de? and varidaic to make it much faster - ; But not prematurely, I just had to redo it after doing that the first time, we'll get there when we get there - (inner_env (make_tmp_inner_env params de? se env_id)) - (full_params (concat params (mif de? (array de?) (array)))) - (normal_params_length (if variadic (- (len params) 1) (len params))) - ((params_vec _ _ ctx) (compile-inner ctx (marked_array true false nil (map (lambda (k) (marked_symbol nil k)) full_params)) true)) - (env_setup_code (concat - - (local.set '$s_env (call '$env_alloc (i64.const params_vec) - - (local.set '$param_ptr (i32.wrap_i64 (i64.and (i64.const -8) (local.get '$params)))) - (local.set '$tmp_ptr (call '$malloc (i32.const (* 8 (len full_params))))) - (flat_map (lambda (i) (i64.store (* i 8) (local.get '$tmp_ptr) (call '$dup (i64.load (* i 8) (local.get '$param_ptr))))) - (range 0 normal_params_length)) - (if variadic - (i64.store (* 8 normal_params_length) (local.get '$tmp_ptr) - (call '$slice_impl (local.get '$params) (i32.const (- (len params) 1)) (i32.const -1))) - (call '$drop (local.get '$params))) - (mif de? - (i64.store (* 8 (- (len full_params) 1)) (local.get '$tmp_ptr) (local.get '$d_env)) - (call '$drop (local.get '$d_env))) - (i64.or (i64.extend_i32_u (local.get '$tmp_ptr)) - (i64.const (bor (<< (len full_params) 32) #x5))) - - (local.get '$s_env))) - - )) - - (setup_code (concat - (call '$print (i64.const name_msg_value)) - (call '$print (local.get '$params)) - (call '$print (i64.const space_msg_val)) - (call '$print (i64.shl (i64.shr_u (local.get '$params) (i64.const 32)) (i64.const 1))) - (call '$print (i64.const space_msg_val)) - (call '$print (i64.const (<< (len params) 1))) - (call '$print (i64.const newline_msg_val)) - (call '$print (i64.const newline_msg_val)) - (_if '$params_len_good - (if variadic (i64.lt_u (i64.shr_u (local.get '$params) (i64.const 32)) (i64.const (- (len params) 1))) - (i64.ne (i64.shr_u (local.get '$params) (i64.const 32)) (i64.const (len params)))) - (then - (call '$drop (local.get '$params)) - (call '$drop (local.get '$s_env)) - (call '$drop (local.get '$d_env)) - (call '$print (i64.const bad_params_number_msg_val)) - (unreachable) - ) - (else - (call '$print (i64.const call_ok_msg_val)) - (call '$print (i64.const newline_msg_val)) - ;(call '$print (local.get '$s_env)) - (call '$print (i64.const newline_msg_val)) - ) - ) env_setup_code - )) - - ((datasi funcs memo env pectx) ctx) - ((inner_value inner_code err ctx) (compile-inner (array datasi funcs memo inner_env pectx) body false)) - ; Don't overwrite env with what was our inner env! Env is returned as part of context to our caller! - ((datasi funcs memo _was_inner_env pectx) ctx) - ;(_ (print_strip "inner_value for maybe const is " inner_value " inner_code is " inner_code " err is " err " this was for " body)) - (inner_code (mif inner_value (i64.const inner_value) inner_code)) - (end_code (call '$drop (local.get '$s_env))) - (our_func (func '$len '(param $params i64) '(param $d_env i64) '(param $s_env i64) '(result i64) '(local $param_ptr i32) '(local $tmp_ptr i32) '(local $tmp i64) - (concat setup_code inner_code end_code) - )) - (funcs (concat funcs our_func)) - (our_func_idx (+ (- (len funcs) dyn_start) (- num_pre_functions 1))) - (func_value (bor (<< our_func_idx 35) (<< wrap_level 4) #b0001)) - (memo (put memo (.hash c) func_value)) - (_ (print_strip "the hash " (.hash c) " with value " func_value " corresponds to " c)) - - ) (array func_value nil err (array datasi funcs memo env pectx))) - )) - (_ (print_strip "returning " func_value " for " c)) - (_ (if (not (int? func_value)) (error "BADBADBADfunc"))) - - ((wrap_level env_id de? se variadic params body) (.comb c)) - ; I belive this env_code should actually re-create the actual env chain (IN THE ENV COMPILING CODE, NOT HERE) - ; It might not just be s_env, because we might have been partially-evaled and returned - ; from a deeper call and have some real env frames before we run into what is currently - ; s_env. Additionally, this changes depending on where this value currently is, though - ; I think as of right now you can only have an incomplete-chain-closure once, since it - ; would never count as a value it could never be moved into another function etc. - ; ON THE OTHER HAND - perhaps two (textually) identical lambdas could? - ; Also, if we go for value lambda than we should't be compiling with the - ; current actual stack... (we really need to change the compile-time stacks to be - ; identical / mostly get rid of them all together) - ((env_val env_code env_err ctx) (if (and need_value (not (marked_env_real? se))) - (array nil nil "Env wasn't real when compiling comb, but need value" ctx) - (compile-inner ctx se need_value))) - (_ (print_strip "result of compiling env for comb is val " env_val " code " env_code " err " env_err " and it was real? " (marked_env_real? se) " based off of env " se)) - (_ (if (not (or (= nil env_val) (int? env_val))) (error "BADBADBADenv_val"))) - ; |0001 - ; e29><2><4> = 6 - ; 0..0<3 bits>01001 - ; e29><3><5> = 8 - ; 0..001001 - ; x+2+4 = y + 3 + 5 - ; x + 6 = y + 8 - ; x - 2 = y - ) (mif env_val (array (bor (band #x7FFFFFFC0 (>> env_val 2)) func_value) nil (mif func_err (str func_err ", from compiling comb body") (mif env_err (str env_err ", from compiling comb env") nil)) ctx) - (array nil (i64.or (i64.const func_value) (i64.and (i64.const #x7FFFFFFC0) (i64.shr_u env_code (i64.const 2)))) (mif func_err (str func_err ", from compiling comb body (env as code)") (mif env_err (str env_err ", from compiling comb env (as code)") nil)) ctx)) - )) - - (true (error (str "Can't compile-inner impossible " c))) - ))) - - ;(_ (println "compiling partial evaled " (str_strip marked_code))) - (_ (true_print "compiling partial evaled " (true_str_strip marked_code))) - (memo empty_dict) - (ctx (array datasi funcs memo root_marked_env pectx)) - - ((exit_val _ _ ctx) (compile-inner ctx (marked_symbol nil 'exit) true)) - ((read_val _ _ ctx) (compile-inner ctx (marked_symbol nil 'read) true)) - ((write_val _ _ ctx) (compile-inner ctx (marked_symbol nil 'write) true)) - ((open_val _ _ ctx) (compile-inner ctx (marked_symbol nil 'open) true)) - ((monad_error_msg_val _ _ ctx) (compile-inner ctx (marked_val "Not a legal monad ( ['read fd len ] / ['write fd data ] / ['open fd path ] /['exit exit_code])") true)) - ((bad_read_val _ _ ctx) (compile-inner ctx (marked_val "") true)) - ((exit_msg_val _ _ ctx) (compile-inner ctx (marked_val "Exiting with code:") true)) - ((root_marked_env_val _ _ ctx) (compile-inner ctx root_marked_env true)) - - - ((compiled_value_ptr compiled_value_code compiled_value_error ctx) (compile-inner ctx marked_code true)) - ((datasi funcs memo root_marked_env pectx) ctx) - - ; Swap for when need to profile what would be an error - ;(compiled_value_ptr (mif compiled_value_error 0 compiled_value_ptr)) - (_ (mif compiled_value_error (error compiled_value_error))) - - (_ (if (= nil compiled_value_ptr) (error (str "compiled top-level to code for some reason!? have code " compiled_value_code)))) - - ; Ok, so the outer loop handles the IO monads - ; ('exit code) - ; ('read fd len ) - ; ('write fd "data" ) - ; ('open fd path ) - ; Could add some to open like lookup flags, o flags, base rights - ; ineriting rights, fdflags - - (start (func '$start '(local $it i64) '(local $tmp i64) '(local $ptr i32) '(local $monad_name i64) '(local $len i32) '(local $buf i32) '(local $code i32) '(local $str i64) '(local $result i64) - (local.set '$it (i64.const compiled_value_ptr)) - (block '$exit_block - (block '$error_block - (_loop '$l - ; Not array -> out - (br_if '$error_block (i64.ne (i64.const #b101) (i64.and (i64.const #b101) (local.get '$it)))) - ; less than len 2 -> out - (br_if '$error_block (i64.lt_u (i64.shr_u (local.get '$it) (i64.const 32)) (i64.const 2))) - (local.set '$ptr (i32.wrap_i64 (i64.and (local.get '$it) (i64.const -8)))) - ; second entry isn't an int -> out - (br_if '$error_block (i64.ne (i64.and (i64.load 8 (local.get '$ptr)) (i64.const #b1)) (i64.const #b0))) - (local.set '$monad_name (i64.load (local.get '$ptr))) - - ; ('exit code) - (_if '$is_exit - (i64.eq (i64.const exit_val) (local.get '$monad_name)) - (then - ; len != 2 - (br_if '$error_block (i64.ne (i64.shr_u (local.get '$it) (i64.const 32)) (i64.const 2))) - (call '$print (i64.const exit_msg_val)) - (call '$print (i64.load 8 (local.get '$ptr))) - (br '$exit_block) - ) - ) - - ; if len != 4 - (br_if '$error_block (i64.ne (i64.shr_u (local.get '$it) (i64.const 32)) (i64.const 4))) - - ; ('read fd len ) - (_if '$is_read - (i64.eq (i64.const read_val) (local.get '$monad_name)) - (then - ; third entry isn't an int -> out - (br_if '$error_block (i64.ne (i64.and (i64.load 16 (local.get '$ptr)) (i64.const #b1)) (i64.const #b0))) - ; fourth entry isn't a comb -> out - (br_if '$error_block (i64.ne (i64.and (i64.load 24 (local.get '$ptr)) (i64.const #b1111)) (i64.const #b0001))) - ; iov <32bit len><32bit addr> + <32bit num written> - (i32.store 0 (i32.const iov_tmp) (local.tee '$buf (call '$malloc (local.get '$len)))) - (i32.store 4 (i32.const iov_tmp) (local.tee '$len (i32.wrap_i64 (i64.shr_u (i64.load 16 (local.get '$ptr)) (i64.const 1))))) - (local.set '$code (call '$fd_read - (i32.wrap_i64 (i64.shr_u (i64.load 8 (local.get '$ptr)) (i64.const 1))) ;; file descriptor - (i32.const iov_tmp) ;; *iovs - (i32.const 1) ;; iovs_len - (i32.const (+ 8 iov_tmp)) ;; nwritten - )) - ; 011 - (local.set '$str (i64.or (i64.shl (i64.extend_i32_u (i32.load 8 (i32.const iov_tmp))) (i64.const 32)) - (i64.extend_i32_u (i32.or (local.get '$buf) (i32.const #b011))))) - (_if '$is_error - (i32.eqz (local.get '$code)) - (then - (local.set '$result (call '$array2_alloc (local.get '$str) - (i64.const 0))) - ) - (else - (call '$drop (local.get '$str)) - (local.set '$result (call '$array2_alloc (i64.const bad_read_val) - (i64.shl (i64.extend_i32_u (local.get '$code)) (i64.const 1)))) - ) - ) - - (local.set '$tmp (call '$dup (i64.load 24 (local.get '$ptr)))) - (call '$drop (local.get '$it)) - (local.set '$it (call_indirect - ;type - k_vau - ;table - 0 - ;params - (local.get '$result) - ;top_env - (i64.const root_marked_env_val) - ; static env - (i64.or (i64.shl (i64.and (local.get '$tmp) (i64.const #x3FFFFFFC0)) (i64.const 2)) (i64.const #b01001)) - ;func_idx - (i32.wrap_i64 (i64.shr_u (local.get '$tmp) (i64.const 35))) - )) - (br '$l) - ) - ) - - ; ('write fd "data" ) - (_if '$is_write - (i64.eq (i64.const write_val) (local.get '$monad_name)) - (then - ; third entry isn't a string -> out - (br_if '$error_block (i64.ne (i64.and (i64.load 16 (local.get '$ptr)) (i64.const #b111)) (i64.const #b011))) - ; fourth entry isn't a comb -> out - (br_if '$error_block (i64.ne (i64.and (i64.load 24 (local.get '$ptr)) (i64.const #b1111)) (i64.const #b0001))) - ; 011 - (local.set '$str (i64.load 16 (local.get '$ptr))) - - ; iov <32bit addr><32bit len> + <32bit num written> - (i32.store 0 (i32.const iov_tmp) (i32.wrap_i64 (i64.and (local.get '$str) (i64.const #xFFFFFFF8)))) - (i32.store 4 (i32.const iov_tmp) (i32.wrap_i64 (i64.shr_u (local.get '$str) (i64.const 32)))) - (local.set '$code (call '$fd_write - (i32.wrap_i64 (i64.shr_u (i64.load 8 (local.get '$ptr)) (i64.const 1))) ;; file descriptor - (i32.const iov_tmp) ;; *iovs - (i32.const 1) ;; iovs_len - (i32.const (+ 8 iov_tmp)) ;; nwritten - )) - (local.set '$result (call '$array2_alloc (i64.shl (i64.extend_i32_u (i32.load (i32.const (+ 8 iov_tmp)))) (i64.const 1)) - (i64.shl (i64.extend_i32_u (local.get '$code)) (i64.const 1)))) - - (local.set '$tmp (call '$dup (i64.load 24 (local.get '$ptr)))) - (call '$drop (local.get '$it)) - (local.set '$it (call_indirect - ;type - k_vau - ;table - 0 - ;params - (local.get '$result) - ;top_env - (i64.const root_marked_env_val) - ; static env - (i64.or (i64.shl (i64.and (local.get '$tmp) (i64.const #x3FFFFFFC0)) (i64.const 2)) (i64.const #b01001)) - ;func_idx - (i32.wrap_i64 (i64.shr_u (local.get '$tmp) (i64.const 35))) - )) - (br '$l) - ) - ) - ; ('open fd path ) - (_if '$is_open - (i64.eq (i64.const open_val) (local.get '$monad_name)) - (then - ; third entry isn't a string -> out - (br_if '$error_block (i64.ne (i64.and (i64.load 16 (local.get '$ptr)) (i64.const #b111)) (i64.const #b011))) - ; fourth entry isn't a comb -> out - (br_if '$error_block (i64.ne (i64.and (i64.load 24 (local.get '$ptr)) (i64.const #b1111)) (i64.const #b0001))) - ; 011 - (local.set '$str (i64.load 16 (local.get '$ptr))) - - (local.set'$code (call '$path_open - (i32.wrap_i64 (i64.shr_u (i64.load 8 (local.get '$ptr)) (i64.const 1))) ;; file descriptor - (i32.const 0) ;; lookup flags - (i32.wrap_i64 (i64.and (local.get '$str) (i64.const #xFFFFFFF8))) ;; path string * - (i32.wrap_i64 (i64.shr_u (local.get '$str) (i64.const 32))) ;; path string len - (i32.const 1) ;; o flags - (i64.const 66) ;; base rights - (i64.const 66) ;; inheriting rights - (i32.const 0) ;; fdflags - (i32.const iov_tmp) ;; opened fd out ptr - )) - - (local.set '$result (call '$array2_alloc (i64.shl (i64.extend_i32_u (i32.load (i32.const iov_tmp))) (i64.const 1)) - (i64.shl (i64.extend_i32_u (local.get '$code)) (i64.const 1)))) - - (local.set '$tmp (call '$dup (i64.load 24 (local.get '$ptr)))) - (call '$drop (local.get '$it)) - (local.set '$it (call_indirect - ;type - k_vau - ;table - 0 - ;params - (local.get '$result) - ;top_env - (i64.const root_marked_env_val) - ; static env - (i64.or (i64.shl (i64.and (local.get '$tmp) (i64.const #x3FFFFFFC0)) (i64.const 2)) (i64.const #b01001)) - ;func_idx - (i32.wrap_i64 (i64.shr_u (local.get '$tmp) (i64.const 35))) - )) - (br '$l) - ) - ) - ) - ) - ; print error - (call '$print (i64.const monad_error_msg_val)) - (call '$print (local.get '$it)) - ) - (call '$drop (local.get '$it)) - )) - ((watermark datas) datasi) - ) (concat - (global '$data_end '(mut i32) (i32.const watermark)) - datas funcs start - (table '$tab (len funcs) 'funcref) - (apply elem (cons (i32.const 0) (range dyn_start (+ num_pre_functions (len funcs))))) - (memory '$mem (+ 2 (>> watermark 16))) - )) - (export "memory" '(memory $mem)) - (export "_start" '(func $start)) - ))))) - - - (run_partial_eval_test (lambda (s) (dlet ( - (_ (print "\n\ngoing to partial eval " s)) - ((pectx err result) (partial_eval (read-string s))) - (_ (print "result of test \"" s "\" => " (str_strip result) " and err " err)) - (_ (print "with a hash of " (.hash result))) - ) nil))) - (test-most (lambda () (begin - (print (val? '(val))) - (print "take 3" (take '(1 2 3 4 5 6 7 8 9 10) 3)) - ; shadowed by wasm - ;(print "drop 3" (drop '(1 2 3 4 5 6 7 8 9 10) 3)) - (print (slice '(1 2 3) 1 2)) - (print (slice '(1 2 3) 1 -1)) - (print (slice '(1 2 3) -1 -1)) - (print (slice '(1 2 3) -2 -1)) - - (print "ASWDF") - (print (str-to-symbol (str '(a b)))) - (print (symbol? (str-to-symbol (str '(a b))))) - (print ( (dlambda ((a b)) a) '(1337 1338))) - (print ( (dlambda ((a b)) b) '(1337 1338))) - - (print (str 1 2 3 (array 1 23 4) "a" "B")) - - (print (dlet ( (x 2) ((a b) '(1 2)) (((i i2) i3) '((5 6) 7)) ) (+ x a b i i2 i3))) - - (print (array 1 2 3)) - (print (command-line-arguments)) - - (print (call-with-input-string "'(1 2)" (lambda (p) (read p)))) - (print (read (open-input-string "'(3 4)"))) - - (print "mif tests") - (print (mif true 1 2)) - (print (mif false 1 2)) - (print (mif true 1)) - (print (mif false 1)) - (print "mif tests end") - - (print "zip " (zip '(1 2 3) '(4 5 6) '(7 8 9))) - - (print (run_partial_eval_test "(+ 1 2)")) - (print) (print) - (print (run_partial_eval_test "(cond false 1 true 2)")) - (print (run_partial_eval_test "(log 1)")) - (print (run_partial_eval_test "((vau (x) (+ x 1)) 2)")) - - - (print (run_partial_eval_test "(+ 1 2)")) - (print (run_partial_eval_test "(vau (y) (+ 1 2))")) - (print (run_partial_eval_test "((vau (y) (+ 1 2)) 4)")) - (print (run_partial_eval_test "((vau (y) y) 4)")) - (print (run_partial_eval_test "((vau (y) (+ 13 2 y)) 4)")) - (print (run_partial_eval_test "((wrap (vau (y) (+ 13 2 y))) (+ 3 4))")) - (print (run_partial_eval_test "(vau de (y) (+ (eval y de) (+ 1 2)))")) - (print (run_partial_eval_test "((vau de (y) ((vau dde (z) (+ 1 (eval z dde))) y)) 17)")) - - (print (run_partial_eval_test "(cond false 1 false 2 (+ 1 2) 3 true 1337)")) - (print (run_partial_eval_test "(vau de (x) (cond false 1 false 2 x 3 true 42))")) - (print (run_partial_eval_test "(vau de (x) (cond false 1 false 2 3 x true 42))")) - - (print (run_partial_eval_test "(combiner? true)")) - (print (run_partial_eval_test "(combiner? (vau de (x) x))")) - (print (run_partial_eval_test "(vau de (x) (combiner? x))")) - - (print (run_partial_eval_test "((vau (x) x) a)")) - - (print (run_partial_eval_test "(env? true)")) - ; this doesn't partially eval, but it could with a more percise if the marked values were more percise - (print (run_partial_eval_test "(vau de (x) (env? de))")) - (print (run_partial_eval_test "(vau de (x) (env? x))")) - (print (run_partial_eval_test "((vau de (x) (env? de)) 1)")) - - (print (run_partial_eval_test "((wrap (vau (let1) (let1 a 12 (+ a 1)))) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de)))")) - (print (run_partial_eval_test "((wrap (vau (let1) (let1 a 12 (vau (x) (+ a 1))))) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de)))")) - (print (run_partial_eval_test "((wrap (vau (let1) (let1 a 12 (wrap (vau (x) (+ x a 1)))))) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de)))")) - (print (run_partial_eval_test "((wrap (vau (let1) (let1 a 12 (wrap (vau (x) (let1 y (+ a 1) (+ y x a))))))) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de)))")) - - ;(print "\n\nnil test\n") - ;(print (run_partial_eval_test "nil")) - ;(print (run_partial_eval_test "(nil? 1)")) - ;(print (run_partial_eval_test "(nil? nil)")) - - (print "\n\nlet 4.3\n\n") - (print (run_partial_eval_test "((wrap (vau (let1) - (let1 a 12 (wrap (vau (x) (let1 y (+ a 1) (+ y x a)))) - ))) (vau de (s v b) (eval (array (array wrap (array vau (array s) b)) v) de)))")) - (print "\n\nlet 4.7\n\n") - (print (run_partial_eval_test "((wrap (vau (let1) - (let1 a 12 (wrap (vau (x) (let1 y (+ x a 1) (+ y x a)))) - ))) (vau de (s v b) (eval (array (array wrap (array vau (array s) b)) v) de)))")) - - (print "\n\nlet 5\n\n") - (print (run_partial_eval_test "((wrap (vau (let1) - (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)))")) - - (print "\n\nlambda 1\n\n") - (print (run_partial_eval_test "((wrap (vau (let1) - (let1 lambda (vau se (p b) (wrap (eval (array vau p b) se))) - (lambda (x) x) - ))) (vau de (s v b) (eval (array (array wrap (array vau (array s) b)) v) de)))")) - (print "\n\nlambda 2\n\n") - (print (run_partial_eval_test "((wrap (vau (let1) - (let1 lambda (vau se (p b) (wrap (eval (array vau p b) se))) - (let1 a 12 - (lambda (x) (+ a x))) - ))) (vau de (s v b) (eval (array (array wrap (array vau (array s) b)) v) de)))")) - (print "\n\nlambda 3\n\n") - (print (run_partial_eval_test "((wrap (vau (let1) - (let1 lambda (vau se (p b) (wrap (eval (array vau p b) se))) - (let1 a 12 - (lambda (x) (let1 b (+ a x) - (+ a x b)))) - ))) (vau de (s v b) (eval (array (array wrap (array vau (array s) b)) v) de)))")) - - (print (run_partial_eval_test "(array 1 2 3 4 5)")) - (print (run_partial_eval_test "((wrap (vau (a & rest) rest)) 1 2 3 4 5)")) - - (print "\n\nrecursion test\n\n") - (print (run_partial_eval_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 (!= 0 n) (* n (recurse recurse (- n 1))) - true 1 )) 5) - ))) (vau de (s v b) (eval (array (array wrap (array vau (array s) b)) v) de)))")) - - (print "\n\nlambda recursion test\n\n") - (print (run_partial_eval_test "((wrap (vau (let1) - (let1 lambda (vau se (p b) (wrap (eval (array vau p b) se))) - (lambda (n) ((lambda (x n) (x x n)) (lambda (recurse n) (cond (!= 0 n) (* n (recurse recurse (- n 1))) - true 1 )) n)) - ))) (vau de (s v b) (eval (array (array wrap (array vau (array s) b)) v) de)))")) - - ; The issue with this one is that (x2 x2) trips the infinate recursion protector, but then - ; that array gets marked as attempted & needing no more evaluation, and is frozen forever. - ; Then, when the recursion is actually being used, it won't keep going and you only get - ; the first level. - (print "\n\nlambda recursion Y combiner test\n\n") - (print (run_partial_eval_test "((wrap (vau (let1) - (let1 lambda (vau se (p b) (wrap (eval (array vau p b) se))) - (let1 lapply (lambda (f1 p) (eval (concat (array (unwrap f1)) p))) - (let1 Y (lambda (f3) - ((lambda (x1) (x1 x1)) - (lambda (x2) (f3 (lambda (& y) (lapply (x2 x2) y)))))) - ((Y (lambda (recurse) (lambda (n) (cond (!= 0 n) (* n (recurse (- n 1))) - true 1)))) - 5) - ))))) (vau de (s v b) (eval (array (array wrap (array vau (array s) b)) v) de)))")) - - - - (print "ok, hex of 0 is " (hex_digit #\0)) - (print "ok, hex of 1 is " (hex_digit #\1)) - (print "ok, hex of a is " (hex_digit #\a)) - (print "ok, hex of A is " (hex_digit #\A)) - (print "ok, hexify of 1337 is " (i64_le_hexify 1337)) - (print "ok, hexify of 10 is " (i64_le_hexify 10)) - (print "ok, hexify of 15 is " (i64_le_hexify 15)) - (print "ok, hexfy of 15 << 60 is " (i64_le_hexify (<< 15 60))) - (let* ( - ;(output1 (wasm_to_binary (module))) - ;(output2 (wasm_to_binary (module - ; (import "wasi_unstable" "path_open" - ; '(func $path_open (param i32 i32 i32 i32 i32 i64 i64 i32 i32) - ; (result i32))) - ; (import "wasi_unstable" "fd_prestat_dir_name" - ; '(func $fd_prestat_dir_name (param i32 i32 i32) - ; (result i32))) - ; (import "wasi_unstable" "fd_read" - ; '(func $fd_read (param i32 i32 i32 i32) - ; (result i32))) - ; (import "wasi_unstable" "fd_write" - ; '(func $fd_write (param i32 i32 i32 i32) - ; (result i32))) - ; (memory '$mem 1) - ; (global '$gi 'i32 (i32.const 8)) - ; (global '$gb '(mut i64) (i64.const 9)) - ; (table '$tab 2 'funcref) - ; (data (i32.const 16) "HellH") ;; adder to put, then data - - - ; (func '$start - ; (i32.store (i32.const 8) (i32.const 16)) ;; adder of data - ; (i32.store (i32.const 12) (i32.const 5)) ;; len of data - ; ;; open file - ; (call 0 ;$path_open - ; (i32.const 3) ;; file descriptor - ; (i32.const 0) ;; lookup flags - ; (i32.const 16) ;; path string * - ; (i32.load (i32.const 12)) ;; path string len - ; (i32.const 1) ;; o flags - ; (i64.const 66) ;; base rights - ; (i64.const 66) ;; inheriting rights - ; (i32.const 0) ;; fdflags - ; (i32.const 4) ;; opened fd out ptr - ; ) - ; (drop) - ; (block '$a - ; (block '$b - ; (br '$a) - ; (br_if '$b - ; (i32.const 3)) - ; (_loop '$l - ; (br '$a) - ; (br '$l) - ; ) - ; (_if '$myif - ; (i32.const 1) - ; (then - ; (i32.const 1) - ; (drop) - ; (br '$b) - ; ) - ; (else - ; (br '$myif) - ; ) - ; ) - ; (_if '$another - ; (i32.const 1) - ; (br '$b)) - ; (i32.const 1) - ; (_if '$third - ; (br '$b)) - ; (_if '$fourth - ; (br '$fourth)) - ; ) - ; ) - ; (call '$fd_read - ; (i32.const 0) ;; file descriptor - ; (i32.const 8) ;; *iovs - ; (i32.const 1) ;; iovs_len - ; (i32.const 12) ;; nwritten, overwrite buf len with it - ; ) - ; (drop) - - ; ;; print name - ; (call '$fd_write - ; (i32.load (i32.const 4)) ;; file descriptor - ; (i32.const 8) ;; *iovs - ; (i32.const 1) ;; iovs_len - ; (i32.const 4) ;; nwritten - ; ) - ; (drop) - ; ) - - ; (elem (i32.const 0) '$start '$start) - ; (export "memory" '(memory $mem)) - ; (export "_start" '(func $start)) - ;))) - (output3 (compile (partial_eval (read-string "(array 1 (array ((vau (x) x) a) (array \"asdf\")) 2)")))) - (output3 (compile (partial_eval (read-string "(array 1 (array 1 2 3 4) 2 (array 1 2 3 4))")))) - (output3 (compile (partial_eval (read-string "empty_env")))) - (output3 (compile (partial_eval (read-string "(eval (array (array vau ((vau (x) x) (a b)) (array (array vau ((vau (x) x) x) (array) ((vau (x) x) x)))) 1 2) empty_env)")))) - (output3 (compile (partial_eval (read-string "(eval (array (array vau ((vau (x) x) (a b)) (array (array vau ((vau (x) x) x) (array) ((vau (x) x) x)))) empty_env 2) empty_env)")))) - (output3 (compile (partial_eval (read-string "(eval (array (array vau ((vau (x) x) x) (array) ((vau (x) x) x))))")))) - (output3 (compile (partial_eval (read-string "(vau (x) x)")))) - (output3 (compile (partial_eval (read-string "(vau (x) 1)")))) - - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) exit) 1)")))) - - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (array ((vau (x) x) exit) 1)))")))) - - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (array ((vau (x) x) exit) written)))")))) - - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) written))")))) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) code))")))) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (array 1337 written 1338 code 1339)))")))) - - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (cond (= 0 code) written true code)))")))) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (str (= 0 code) written true (array) code)))")))) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (log (= 0 code) written true (array) code)))")))) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (error (= 0 code) written true code)))")))) - ;(output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (or (= 0 code) written true code)))")))) - - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (+ written code 1337)))")))) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (- written code 1337)))")))) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (* written 1337)))")))) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (/ 1337 written)))")))) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (% 1337 written)))")))) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (band 1337 written)))")))) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (bor 1337 written)))")))) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (bnot written)))")))) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (bxor 1337 written)))")))) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (<< 1337 written)))")))) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (>> 1337 written)))")))) - - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (<= (array written) (array 1337))))")))) - - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (read-string (cond written \"true\" true 3))))")))) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (read-string (cond written \" true\" true 3))))")))) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (read-string (cond written \" true \" true 3))))")))) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (read-string (cond written \" false\" true 3))))")))) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (read-string (cond written \"(false (true () true) true)\" true 3))))")))) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (read-string (cond written \"(false (true () true) true) true\" true 3))))")))) - - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) open) 3 \"test_out\" (vau (fd code) (array ((vau (x) x) write) fd \"waa\" (vau (written code) (array written code)))))")))) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) open) 3 \"test_out\" (vau (fd code) (array ((vau (x) x) read) fd 10 (vau (data code) (array data code)))))")))) - - ;(_ (print (slurp "test_parse_in"))) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) open) 3 \"test_parse_in\" (vau (fd code) (array ((vau (x) x) read) fd 1000 (vau (data code) (read-string data)))))")))) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"test_parse_in\" (vau (written code) (array (array written))))")))) - - - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (& args) (slice args 1 -1)))")))) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (& args) (len args)))")))) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (& args) (idx args 0)))")))) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (& args) (slice (concat args (array 1 2 3 4) args) 1 -2)))")))) - - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (& args) (str-to-symbol (str args))))")))) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (& args) (get-text (str-to-symbol (str args)))))")))) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (& args) (wrap (cond args idx true 0))))")))) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (& args) (wrap (wrap (cond args idx true 0)))))")))) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (& args) (wrap (wrap (wrap (cond args idx true 0))))))")))) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (& args) (unwrap (cond args idx true 0))))")))) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (& args) (unwrap (cond args vau true 0))))")))) - - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (array (nil? written) (array? written) (bool? written) (env? written) (combiner? written) (string? written) (int? written) (symbol? written))))")))) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau de (written code) (array (nil? (cond written (array) true 4)) (array? (cond written (array 1 2) true 4)) (bool? (= 3 written)) (env? de) (combiner? (cond written (vau () 1) true 43)) (string? (cond written \"a\" 3 3)) (int? (cond written \"a\" 3 3)) (symbol? (cond written ((vau (x) x) x) 3 3)) written)))")))) - - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (& args) args))")))) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (a & args) a))")))) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (a & args) args))")))) - - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) read) 0 10 (vau (data code) data))")))) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) read) 0 10 (vau (data code) (array ((vau (x) x) write) 1 data (vau (written code) (array written code)))))")))) - - (output3 (compile (partial_eval (read-string "(wrap (vau (x) x))")))) - (output3 (compile (partial_eval (read-string "len")))) - (output3 (compile (partial_eval (read-string "vau")))) - (output3 (compile (partial_eval (read-string "(array len 3 len)")))) - (output3 (compile (partial_eval (read-string "(+ 1 1337 (+ 1 2))")))) - (output3 (compile (partial_eval (read-string "\"hello world\"")))) - (output3 (compile (partial_eval (read-string "((vau (x) x) asdf)")))) - (output3 (compile (partial_eval (read-string "((wrap (vau (let1) - (let1 lambda (vau se (p b) (wrap (eval (array vau p b) se))) - (array ((vau (x) x) write) 1 \"hahah\" (vau (written code) ((lambda (x n) (x x n)) (lambda (recurse n) (cond (!= 0 n) (* n (recurse recurse (- n 1))) - true 1)) written))) - ))) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de)))")))) - (_ (write_file "./csc_out.wasm" output3)) - (output3 (compile (partial_eval (read-string "(nil? 1)")))) - ;(output3 (compile (partial_eval (read-string "(nil? nil)")))) - ) (void)) - ))) - - (single-test (lambda () (dlet ( - ;(output3 (compile (partial_eval (read-string "1337")))) - ;(output3 (compile (partial_eval (read-string "\"This is a longish sring to make sure alloc data is working properly\"")))) - ;(output3 (compile (partial_eval (read-string "((vau (x) x) write)")))) - ;(output3 (compile (partial_eval (read-string "(wrap (vau (x) x))")))) - ;(output3 (compile (partial_eval (read-string "(wrap (vau (x) (log 1337)))")))) - ;(output3 (compile (partial_eval (read-string "(wrap (vau (x) (+ x 1337)))")))) - ;(output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"w\" (vau (written code) (+ written code 1337)))")))) - ;(output3 (compile (partial_eval (read-string "((wrap (vau (let1) - ; (let1 lambda (vau se (p b) (wrap (eval (array vau p b) se))) - ; (array ((vau (x) x) write) 1 \"hahah\" (vau (written code) ((lambda (x n) (x x n)) (lambda (recurse n) (cond (!= 0 n) (* n (recurse recurse (- n 1))) - ; true 1)) written))) - ; ))) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de)))")))) - - - (output3 (compile (partial_eval (read-string - "((wrap (vau root_env (quote) - ((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)) - ) void))) - - (run-compiler (lambda () - (write_file "./csc_out.wasm" (compile (partial_eval (read-string (slurp "to_compile.kp"))))) - )) - -;) (test-most)) -) (run-compiler)) -;) (single-test)) -) - -;;;;;;;;;;;;;; -; Known TODOs -;;;;;;;;;;;;;; -; -; * ARRAY FUNCTIONS FOR STRINGS, in both PARTIAL_EVAL *AND* COMPILED -; * Finish supporting calling vaus in compiled code -; * NON NAIVE REFCOUNTING -; * Of course, memoizing partial_eval -; -; -; EVENTUALLY: Support some hard core partial_eval that an fully make (foldl or stuff) short circut effeciencly with double-inlining, finally -; addressing the strict-languages-don't-compose thing -; -; If function result has a closed over symbol, but also we have a real env it would resolve too, that should be fine -; Not sure if this is a mod to the function call or the close over -; diff --git a/partial_eval.scm b/partial_eval.scm index 1584bde..a4f3a2e 100644 --- a/partial_eval.scm +++ b/partial_eval.scm @@ -3,10 +3,10 @@ ; In Chez, arithmetic-shift is bitwise-arithmetic-shift ; Chicken -;(import (chicken process-context)) (import (chicken port)) (import (chicken io)) (import (chicken bitwise)) (import (chicken string)) (import (r5rs)) +(import (chicken process-context)) (import (chicken port)) (import (chicken io)) (import (chicken bitwise)) (import (chicken string)) (import (r5rs)) (define write_file (lambda (file bytes) (call-with-output-file file (lambda (out) (foldl (lambda (_ o) (write-byte o out)) (void) bytes))))) ; Chez -;(define print pretty-print) (define arithmetic-shift bitwise-arithmetic-shift) +;(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))) '()))) ; 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) @@ -34,6 +34,13 @@ (syntax-rules () ((_ params body) (lambda fullparams (dlet ((params fullparams)) body))))) +(define-syntax mif + (syntax-rules () + ((_ con then ) (if (let ((x con)) (and (not (equal? (list) x)) x)) then '())) + ((_ con then else) (if (let ((x con)) (and (not (equal? (list) x)) x)) then else)))) + +(define error (lambda args (apply error args))) + ; Adapted from https://stackoverflow.com/questions/16335454/reading-from-file-using-scheme WTH (define (slurp path) (list->string (call-with-input-file path @@ -80,12 +87,16 @@ (empty_dict (array)) (put (lambda (m k v) (cons (array k v) m))) - ;(get-value (lambda (d k) (let ((result (alist-ref k d))) - ; (if (array? result) (idx result 0) - ; (error (print "could not find " k " in " d)))))) - ;(get-value-or-false (lambda (d k) (let ((result (alist-ref k d))) - ; (if (array? result) (idx result 0) - ; false)))) + (my-alist-ref (lambda (k d) ((rec-lambda recurse (d k i) (cond ((= (len d) i) false) + ((= k (idx (idx d i) 0)) (array (idx (idx d i) 1))) + (true (recurse d k (+ 1 i))))) + d k 0))) + (get-value (lambda (d k) (let ((result (my-alist-ref k d))) + (if (array? result) (idx result 0) + (error (print "could not find " k " in " d)))))) + (get-value-or-false (lambda (d k) (let ((result (my-alist-ref k d))) + (if (array? result) (idx result 0) + false)))) (% modulo) (int? integer?) @@ -120,51 +131,4278 @@ (get-output-string mp)))) (print (lambda args (print (apply str args)))) + (true_print print) + (print (lambda x 0)) + ;(true_print print) + (println print) - (write_file (lambda (file bytes) (call-with-output-file file (lambda (out) (foldl (lambda (_ o) (write-byte o out)) (void) bytes))))) - ) + + + ; Ok, actual definitions + (in_array (let ((helper (rec-lambda recurse (x a i) (cond ((= i (len a)) false) + ((= x (idx a i)) true) + (true (recurse x a (+ i 1))))))) + (lambda (x a) (helper x a 0)))) + + (val? (lambda (x) (= 'val (idx x 0)))) + (marked_array? (lambda (x) (= 'marked_array (idx x 0)))) + (marked_symbol? (lambda (x) (= 'marked_symbol (idx x 0)))) + (comb? (lambda (x) (= 'comb (idx x 0)))) + (prim_comb? (lambda (x) (= 'prim_comb (idx x 0)))) + (marked_env? (lambda (x) (= 'env (idx x 0)))) + + (.hash (lambda (x) (idx x 1))) + + (.val (lambda (x) (idx x 2))) + + (.marked_array_is_val (lambda (x) (idx x 2))) + (.marked_array_is_attempted (lambda (x) (idx x 3))) + (.marked_array_needed_for_progress (lambda (x) (idx x 4))) + (.marked_array_values (lambda (x) (idx x 5))) + + (.marked_symbol_needed_for_progress (lambda (x) (idx x 2))) + (.marked_symbol_is_val (lambda (x) (= nil (.marked_symbol_needed_for_progress x)))) + (.marked_symbol_value (lambda (x) (idx x 3))) + (.comb (lambda (x) (slice x 2 -1))) + (.comb_id (lambda (x) (idx x 3))) + (.comb_des (lambda (x) (idx x 4))) + (.comb_env (lambda (x) (idx x 5))) + (.comb_body (lambda (x) (idx x 8))) + (.comb_wrap_level (lambda (x) (idx x 2))) + (.prim_comb_sym (lambda (x) (idx x 3))) + (.prim_comb_handler (lambda (x) (idx x 2))) + (.prim_comb_wrap_level (lambda (x) (idx x 4))) + (.prim_comb_val_head_ok (lambda (x) (idx x 5))) + (.prim_comb (lambda (x) (slice x 2 -1))) + + (.marked_env (lambda (x) (slice x 2 -1))) + (.marked_env_has_vals (lambda (x) (idx x 2))) + (.marked_env_needed_for_progress (lambda (x) (idx x 3))) + (.marked_env_idx (lambda (x) (idx x 4))) + (.marked_env_upper (lambda (x) (idx (idx x 5) -1))) + (.env_marked (lambda (x) (idx x 5))) + (marked_env_real? (lambda (x) (= nil (.marked_env_needed_for_progress x)))) + (.any_comb_wrap_level (lambda (x) (cond ((prim_comb? x) (.prim_comb_wrap_level x)) + ((comb? x) (.comb_wrap_level x)) + (true (error "bad .any_comb_level"))))) + + + ; The actual needed_for_progress values are either + ; #t - any eval will do something + ; nil - is a value, no eval will do anything + ; (3 4 1...) - list of env ids that would allow forward progress + ; But these are paired with another list of hashes that if you're not inside + ; of an evaluation of, then it could progress futher. These are all caused by + ; the infinite recursion stopper. + (needed_for_progress (rec-lambda needed_for_progress (x) (cond ((marked_array? x) (.marked_array_needed_for_progress x)) + ((marked_symbol? x) (array (.marked_symbol_needed_for_progress x) nil)) + ((marked_env? x) (array (.marked_env_needed_for_progress x) nil)) + ((comb? x) (dlet ((id (.comb_id x)) + (body_needed (idx (needed_for_progress (.comb_body x)) 0)) + (se_needed (idx (needed_for_progress (.comb_env x)) 0))) + (if (or (= true body_needed) (= true se_needed)) (array true nil) + (array (foldl (lambda (a xi) (if (or (= id xi) (in_array xi a)) a (cons xi a))) + (array) (concat body_needed se_needed)) nil) + ))) + ((prim_comb? x) (array nil nil)) + ((val? x) (array nil nil)) + (true (error (str "what is this? in need for progress" x)))))) + (needed_for_progress_slim (lambda (x) (idx (needed_for_progress x) 0))) + + (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 (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 (symbol->string 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 (progress_idxs dbi arrs) (combine_hash (mif dbi (hash_num dbi) 59) (let* ( + ;(_ (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 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)))))) + ; 107 109 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 ( + (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))) + ; If not is_val, then if the first entry (combiner) is not done or is a combiner and not function + ; shouldn't add the rest of them, since they'll have to be passed without eval + ; We do this by ignoring trues for non-first + ((_ sub_progress_idxs hashes) (foldl (dlambda ((f a ahs) (x xhs)) + (array false + (cond ((or (= true a) (and f (= true x))) true) + ((= true x) a) + (true (array_union a x))) + (array_union ahs xhs)) + ) (array true (array) resume_hashes) (map needed_for_progress x))) + ;(_ (print "got " sub_progress_idxs " out of " x)) + ;(_ (print "\twhich evalated to " (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) x)))) + (marked_env (lambda (has_vals progress_idxs dbi arrs) (array 'env (begin ;(true_print "marked_env ( " arrs ")") + (hash_env progress_idxs dbi arrs)) has_vals progress_idxs dbi 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"))))) + + + (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)))))) + + (str_strip (lambda args (apply str (concat (slice args 0 -2) (array (idx ((rec-lambda recurse (x done_envs) + (cond ((= nil x) (array "" done_envs)) + ((string? x) (array (str "") done_envs)) + ((val? x) (array (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 (str "[" stripped_values "]") done_envs) + (array (str "" stripped_values) done_envs)))) + ((marked_symbol? x) (mif (.marked_symbol_is_val x) (array (str "'" (.marked_symbol_value x)) done_envs) + (array (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 (str "") done_envs))) + ((prim_comb? x) (array (str "") 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 (str "{" (mif (marked_env_real? x) "real" "fake") (mif (.marked_env_has_vals x) " real vals" " fake vals") " ENV idx: " (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 (str opening "omitted}") + (if (> (len e) 30) (str "{" (len e) "env}") + (str opening middle " upper: " upper "}"))) done_envs) + )) + (true (error (str "some other str_strip? |" x "|"))) + ) + ) (idx args -1) (array)) 0)))))) + (true_str_strip str_strip) + (str_strip (lambda args 0)) + ;(true_str_strip str_strip) + (print_strip (lambda args (println (apply 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 (print_strip key " not found in env " env))) (lambda (x) x)))) + + (strip (let ((helper (rec-lambda recurse (x need_value) + (cond ((val? x) (.val x)) + ((marked_array? x) (let ((stripped_values (map (lambda (x) (recurse x need_value)) (.marked_array_values x)))) + (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) (let* ( + ;(_ (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 ( + (hash (.hash x)) + ;(result (if (or (comb? x) (marked_env? x)) (alist-ref hash memo) false)) + ;(result (if (or (marked_array? x) (marked_env? x)) (alist-ref hash memo) false)) + (result (if (marked_env? x) (my-alist-ref hash memo) false)) + ) (if (array? result) (array memo (idx result 0)) (cond + ((val? x) (array memo false)) + ((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)) + ;(memo (put memo hash result)) + ) (array memo result))) + ((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))) + ;(memo (put memo hash total)) + ) (array memo total))) + + ((prim_comb? x) (array memo false)) + ((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))) + )))) (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 ( 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 + ; ( 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 ( 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))) + (new_array (marked_array false (.marked_array_is_attempted x) nil ress)) + ((pectx err new_array) (if (or (!= nil err) (not changed)) + (array pectx err new_array) + (partial_eval_helper new_array false de env_stack pectx (+ indent 1) true))) + ) (array pectx err new_array)) + (array pectx nil x)) + ) (array pectx nil x)))) + + r))) + + ; TODO: instead of returning the later symbols, we could create a new value of a new type + ; ['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 + (make_tmp_inner_env (lambda (params de? de env_id) + (dlet ((param_entries (map (lambda (p) (array p (marked_symbol (array env_id) p))) params)) + (possible_de_entry (mif (= nil de?) (array) (array (array de? (marked_symbol (array env_id) de?))))) + (progress_idxs (cons env_id (needed_for_progress_slim de))) + ) (begin ;(true_print "in make_tmp_inner_env based on concat " param_entries " " possible_de_entry " " (array de)) + (marked_env false progress_idxs env_id (concat param_entries possible_de_entry (array de))))))) + + + (partial_eval_helper (rec-lambda partial_eval_helper (x only_head env env_stack pectx indent force) + (dlet (((for_progress for_progress_hashes) (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)) + (progress_now (or (= for_progress true) ((rec-lambda rr (i) (if (= i (len for_progress)) false + (dlet ( + ; possible if called from a value context in the compiler + ; TODO: I think this should be removed and instead the value/code compilers should + ; keep track of actual env stacks + (this_now ((rec-lambda ir (j) (cond ((= j (len env_stack)) false) + ((and (= (idx for_progress i) (.marked_env_idx (idx env_stack j))) + (.marked_env_has_vals (idx env_stack j))) (idx for_progress i)) + (true (ir (+ j 1)))) + ) 0)) + ) (if this_now this_now (rr (+ i 1)))) + )) 0))) + ) + (if (or force hashes_now progress_now) + (cond ((val? x) (array pectx nil x)) + ((marked_env? x) (let ((dbi (.marked_env_idx x))) + ; compiler calls with empty env stack + (mif dbi (let* ( (new_env ((rec-lambda rec (i) (cond ((= i (len env_stack)) nil) + ((= dbi (.marked_env_idx (idx env_stack i))) (idx env_stack i)) + (true (rec (+ i 1))))) + 0)) + (_ (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 (cons inner_env env_stack) 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")) + + (later_call_array (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 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 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_progress_idxs de_entry) (mif (!= nil de?) + (array (needed_for_progress_slim env) (array (array de? env))) + (array nil (array)))) + ; Don't need to check params, they're all values! + (inner_env_progress_idxs (concat de_progress_idxs (needed_for_progress_slim se))) + (inner_env (begin ;(true_print "Environment pre marked_env, gonna concat (zip of " params " " final_params ") " (zip params final_params) " " de_entry " " (array se)) + (marked_env true inner_env_progress_idxs env_id (concat (zip params final_params) de_entry (array se))))) + (_ (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 + (cons inner_env env_stack) + 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 (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 + (begin (print_strip (indent_str indent) "Not evaluating " x) + ;(print (indent_str indent) "comparing to env stack " env_stack) + (drop_redundent_veval partial_eval_helper x env env_stack pectx indent)))) + )) + + (needs_params_val_lambda (lambda (f_sym actual_function) (let* ( + (handler (rec-lambda recurse (only_head de env_stack pectx params indent) + (array pectx nil (mark false (apply actual_function (map strip params)))))) + ) (array f_sym (marked_prim_comb handler f_sym 1 false))))) + + (give_up_eval_params (lambda (f_sym actual_function) (let* ( + (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) (begin (print (indent_str indent) "got err " 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)) + )))) + + + (root_marked_env (marked_env true 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)) + + (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 (begin (print "skipping inner eval cuz 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 (cons inner_env env_stack) 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)) + + (array 'wrap (marked_prim_comb (dlambda (only_head de env_stack pectx (evaled) indent) + (if (comb? evaled) (array pectx nil (with_wrap_level evaled (+ (.any_comb_wrap_level evaled) 1))) + (array pectx "bad passed to wrap" nil)) + ) 'wrap 1 true)) + + (array 'unwrap (marked_prim_comb (dlambda (only_head de env_stack pectx (evaled) indent) + (if (comb? evaled) (array pectx nil (with_wrap_level evaled (- (.any_comb_wrap_level evaled) 1))) + (array pectx "bad passed to unwrap" nil)) + ) 'unwrap 1 true)) + + (array 'cond (marked_prim_comb ((rec-lambda recurse (already_stripped) (lambda (only_head de env_stack pectx params indent) + (mif (!= 0 (% (len params) 2)) (array pectx (str "partial eval cond with odd params " params) nil) + (dlet ( + ;(_ (error "This will have to evaluate the other sides? Also, if we figure out veval re-val, maybe this can collapse back into cond")) + (eval_helper (lambda (to_eval pectx) + (dlet (((ok unvald) (if already_stripped (array true to_eval) + (try_unval to_eval (lambda (_) nil))))) + (mif (not ok) + (array pectx "bad unval in cond" nil) + (partial_eval_helper unvald false de env_stack pectx (+ 1 indent) false))))) + ) + ((rec-lambda recurse_inner (i so_far pectx) + (dlet (((pectx err pred) (eval_helper (idx params i) pectx))) + (cond ((!= nil err) (array pectx err nil)) + ((later_head? pred) (dlet ( + (sliced_params (slice params (+ i 1) -1)) + (this (marked_array false true nil (concat (array (marked_prim_comb (recurse false) 'cond 0 true) + pred) + sliced_params))) + (hash (combine_hash (combine_hash 101 (.hash this)) (+ 103 (.marked_env_idx de)))) + ((env_counter memo) pectx) + (already_in (!= false (get-value-or-false memo hash))) + (_ (if already_in (print_strip "ALREADY IN " this) + (print_strip "NOT ALREADY IN, CONTINUING with " this))) + ((pectx err evaled_params later_hash) (if already_in + (array pectx nil (map (lambda (x) (dlet (((ok ux) (try_unval x (lambda (_) nil))) + (_ (if (not ok) (error "BAD cond un")))) + ux)) + sliced_params) hash) + (foldl (dlambda ((pectx err as later_hash) x) + (dlet (((pectx er a) (eval_helper x pectx))) + (array pectx (mif err err er) (concat as (array a)) later_hash)) + ) (array (array env_counter (put memo hash nil)) err (array) nil) sliced_params))) + ((env_counter omemo) pectx) + (pectx (array env_counter memo)) + ) (array pectx err (marked_array false true later_hash (concat (array (marked_prim_comb (recurse true) 'vcond -1 true) + pred) + evaled_params + ))))) + ((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)) + (true (eval_helper (idx params (+ i 1)) pectx)) + ))) 0 (array) pectx)) + ) + )) false) 'cond 0 true)) + + (needs_params_val_lambda 'symbol? symbol?) + (needs_params_val_lambda 'int? int?) + (needs_params_val_lambda 'string? string?) + + (array 'combiner? (marked_prim_comb (dlambda (only_head de env_stack pectx (evaled_param) indent) + (array pectx nil (cond + ((comb? evaled_param) (marked_val true)) + ((prim_comb? evaled_param) (marked_val true)) + (true (marked_val false)) + )) + ) 'combiner? 1 true)) + (array 'env? (marked_prim_comb (dlambda (only_head de env_stack pectx (evaled_param) indent) + (array pectx nil (cond + ((marked_env? evaled_param) (marked_val true)) + (true (marked_val false)) + )) + ) 'env? 1 true)) + (needs_params_val_lambda 'nil? nil?) + (needs_params_val_lambda 'bool? bool?) + (needs_params_val_lambda 'str-to-symbol str-to-symbol) + (needs_params_val_lambda 'get-text get-text) + + (array 'array? (marked_prim_comb (dlambda (only_head de env_stack pectx (evaled_param) indent) + (array pectx nil (cond + ((marked_array? evaled_param) (marked_val true)) + (true (marked_val false)) + )) + ) 'array? 1 true)) + + ; Look into eventually allowing some non values, perhaps, when we look at combiner non all value params + (array 'array (marked_prim_comb (lambda (only_head de env_stack pectx evaled_params indent) + (array pectx nil (marked_array true false nil evaled_params)) + ) 'array 1 false)) + (array 'len (marked_prim_comb (dlambda (only_head de env_stack pectx (evaled_param) indent) + (cond + ((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)) + ) + ) 'len 1 true)) + (array 'idx (marked_prim_comb (dlambda (only_head de env_stack pectx (evaled_array evaled_idx) indent) + (cond + ((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)) + ) + ) 'idx 1 true)) + (array 'slice (marked_prim_comb (dlambda (only_head de env_stack pectx (evaled_array evaled_begin evaled_end) indent) + (cond + ((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))))) + (true (array pectx "bad params to slice" nil)) + ) + ) 'slice 1 true)) + (array 'concat (marked_prim_comb (lambda (only_head de env_stack pectx evaled_params indent) + (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) + (.marked_array_values x)) + evaled_params))))) + (true (array pectx "bad params to concat" nil)) + ) + ) 'concat 1 true)) + + (needs_params_val_lambda '+ +) + (needs_params_val_lambda '- -) + (needs_params_val_lambda '* *) + (needs_params_val_lambda '/ /) + (needs_params_val_lambda '% %) + (needs_params_val_lambda 'band band) + (needs_params_val_lambda 'bor bor) + (needs_params_val_lambda 'bnot bnot) + (needs_params_val_lambda 'bxor bxor) + (needs_params_val_lambda '<< <<) + (needs_params_val_lambda '>> >>) + (needs_params_val_lambda '= =) + (needs_params_val_lambda '!= !=) + (needs_params_val_lambda '< <) + (needs_params_val_lambda '<= <=) + (needs_params_val_lambda '> >) + (needs_params_val_lambda '>= >=) + (needs_params_val_lambda 'str str) + ;(needs_params_val_lambda 'pr-str pr-str) + ;(needs_params_val_lambda 'prn prn) + (give_up_eval_params 'log log) + ; really do need to figure out mif we want to keep meta, and add it mif so + ;(give_up_eval_params 'meta meta) + ;(give_up_eval_params 'with-meta with-meta) + ; mif we want to get fancy, we could do error/recover too + (give_up_eval_params 'error error) + ;(give_up_eval_params 'recover recover) + (needs_params_val_lambda 'read-string read-string) + (array 'empty_env (marked_env true nil nil (array nil))) + + nil + ))) + + (partial_eval (lambda (x) (partial_eval_helper (mark true x) false root_marked_env (array) (array 0 (array)) 0 false))) + + + ;; WASM + + ; Vectors and Values + ; Bytes encode themselves + + ; Note that the shift must be arithmatic + (encode_LEB128 (rec-lambda recurse (x) + (let ((b (band #x7F x)) + (v (>> x 7))) + + (cond ((or (and (= v 0) (= (band b #x40) 0)) (and (= v -1) (!= (band b #x40) 0))) (array b)) + (true (cons (bor b #x80) (recurse v))))) + )) + (encode_vector (lambda (enc v) + (concat (encode_LEB128 (len v)) (flat_map enc v) ) + )) + (encode_floating_point (lambda (x) (error "unimplemented"))) + (encode_name (lambda (name) + (encode_vector (lambda (x) (array x)) (map char->integer (string->list name))) + )) + (hex_digit (lambda (digit) (let ((d (char->integer digit))) + (cond ((< d #x3A) (- d #x30)) + ((< d #x47) (- d #x37)) + (true (- d #x57)))))) + (encode_bytes (lambda (str) + (encode_vector (lambda (x) (array x)) ((rec-lambda recurse (s) (cond + ((= nil s) nil) + ((= #\\ (car s)) (cons (+ (* 16 (hex_digit (car (cdr s)))) + (hex_digit (car (cdr (cdr s))))) (recurse (cdr (cdr (cdr s)))))) + (true (cons (char->integer (car s)) (recurse (cdr s)))) + )) (string->list str))) + )) + + (encode_limits (lambda (x) + (cond ((= 1 (len x)) (concat (array #x00) (encode_LEB128 (idx x 0)))) + ((= 2 (len x)) (concat (array #x01) (encode_LEB128 (idx x 0)) (encode_LEB128 (idx x 1)))) + (true (error "trying to encode bad limits"))) + )) + (encode_number_type (lambda (x) + (cond ((= x 'i32) (array #x7F)) + ((= x 'i64) (array #x7E)) + ((= x 'f32) (array #x7D)) + ((= x 'f64) (array #x7C)) + (true (error (str "bad number type " x)))) + )) + (encode_valtype (lambda (x) + ; we don't handle reference types yet + (encode_number_type x) + )) + (encode_result_type (lambda (x) + (encode_vector encode_valtype x) + )) + (encode_function_type (lambda (x) + (concat (array #x60) (encode_result_type (idx x 0)) + (encode_result_type (idx x 1))) + )) + (encode_ref_type (lambda (t) (cond ((= t 'funcref) (array #x70)) + ((= t 'externref) (array #x6F)) + (true (error (str "Bad ref type " t)))))) + (encode_type_section (lambda (x) + (let ( + (encoded (encode_vector encode_function_type x)) + ) (concat (array #x01) (encode_LEB128 (len encoded)) encoded )) + )) + (encode_import (lambda (import) + (dlet ( + ((mod_name name type idx) import) + ) (concat (encode_name mod_name) + (encode_name name) + (cond ((= type 'func) (concat (array #x00) (encode_LEB128 idx))) + ((= type 'table) (concat (array #x01) (error "can't encode table type"))) + ((= type 'memory) (concat (array #x02) (error "can't encode memory type"))) + ((= type 'global) (concat (array #x03) (error "can't encode global type"))) + (true (error (str "bad import type" type))))) + ) + )) + (encode_import_section (lambda (x) + (let ( + (encoded (encode_vector encode_import x)) + ) (concat (array #x02) (encode_LEB128 (len encoded)) encoded )) + )) + + (encode_table_type (lambda (t) (concat (encode_ref_type (idx t 0)) (encode_limits (idx t 1))))) + + (encode_table_section (lambda (x) + (let ( + (encoded (encode_vector encode_table_type x)) + ) (concat (array #x04) (encode_LEB128 (len encoded)) encoded )) + )) + (encode_memory_section (lambda (x) + (let ( + (encoded (encode_vector encode_limits x)) + ) (concat (array #x05) (encode_LEB128 (len encoded)) encoded )) + )) + (encode_export (lambda (export) + (dlet ( + ((name type idx) export) + ) (concat (encode_name name) + (cond ((= type 'func) (array #x00)) + ((= type 'table) (array #x01)) + ((= type 'memory) (array #x02)) + ((= type 'global) (array #x03)) + (true (error "bad export type"))) + (encode_LEB128 idx) + )) + )) + (encode_export_section (lambda (x) + (let ( + ;(_ (print "encoding element " x)) + (encoded (encode_vector encode_export x)) + ;(_ (print "donex")) + ) (concat (array #x07) (encode_LEB128 (len encoded)) encoded )) + )) + + (encode_start_section (lambda (x) + (cond ((= 0 (len x)) (array)) + ((= 1 (len x)) (let ((encoded (encode_LEB128 (idx x 0)))) (concat (array #x08) (encode_LEB128 (len encoded)) encoded ))) + (true (error (str "bad lenbgth for start section " (len x) " was " x)))) + )) + + (encode_function_section (lambda (x) + (let* ( ; nil functions are placeholders for improted functions + ;(_ (println "encoding function section " x)) + (filtered (filter (lambda (i) (!= nil i)) x)) + ;(_ (println "post filtered " filtered)) + (encoded (encode_vector encode_LEB128 filtered)) + ) (concat (array #x03) (encode_LEB128 (len encoded)) encoded )) + )) + (encode_blocktype (lambda (type) (cond ((symbol? type) (encode_valtype type)) + ((= (array) type) (array #x40)) ; empty type + (true (encode_LEB128 type)) + ))) + + (encode_ins (rec-lambda recurse (ins) + (let ( + (op (idx ins 0)) + ) (cond ((= op 'unreachable) (array #x00)) + ((= op 'nop) (array #x01)) + ((= op 'block) (concat (array #x02) (encode_blocktype (idx ins 1)) (flat_map recurse (idx ins 2)) (array #x0B))) + ((= op 'loop) (concat (array #x03) (encode_blocktype (idx ins 1)) (flat_map recurse (idx ins 2)) (array #x0B))) + ((= op 'if) (concat (array #x04) (encode_blocktype (idx ins 1)) (flat_map recurse (idx ins 2)) (if (!= 3 (len ins)) (concat (array #x05) (flat_map recurse (idx ins 3))) + (array )) (array #x0B))) + ((= op 'br) (concat (array #x0C) (encode_LEB128 (idx ins 1)))) + ((= op 'br_if) (concat (array #x0D) (encode_LEB128 (idx ins 1)))) + ;... + ((= op 'return) (array #x0F)) + ((= op 'call) (concat (array #x10) (encode_LEB128 (idx ins 1)))) + ((= op 'call_indirect) (concat (array #x11) (encode_LEB128 (idx ins 1)) (encode_LEB128 (idx ins 2)))) + ; skipping a bunch + ; Parametric Instructions + ((= op 'drop) (array #x1A)) + ; skip + ; Variable Instructions + ((= op 'local.get) (concat (array #x20) (encode_LEB128 (idx ins 1)))) + ((= op 'local.set) (concat (array #x21) (encode_LEB128 (idx ins 1)))) + ((= op 'local.tee) (concat (array #x22) (encode_LEB128 (idx ins 1)))) + ((= op 'global.get) (concat (array #x23) (encode_LEB128 (idx ins 1)))) + ((= op 'global.set) (concat (array #x24) (encode_LEB128 (idx ins 1)))) + ; table + ; memory + ((= op 'i32.load) (concat (array #x28) (encode_LEB128 (idx ins 1)) (encode_LEB128 (idx ins 2)))) + ((= op 'i64.load) (concat (array #x29) (encode_LEB128 (idx ins 1)) (encode_LEB128 (idx ins 2)))) + ((= op 'i32.load8_s) (concat (array #x2C) (encode_LEB128 (idx ins 1)) (encode_LEB128 (idx ins 2)))) + ((= op 'i32.load8_u) (concat (array #x2D) (encode_LEB128 (idx ins 1)) (encode_LEB128 (idx ins 2)))) + ((= op 'i32.load16_s) (concat (array #x2E) (encode_LEB128 (idx ins 1)) (encode_LEB128 (idx ins 2)))) + ((= op 'i32.load16_u) (concat (array #x2F) (encode_LEB128 (idx ins 1)) (encode_LEB128 (idx ins 2)))) + ((= op 'i64.load8_s) (concat (array #x30) (encode_LEB128 (idx ins 1)) (encode_LEB128 (idx ins 2)))) + ((= op 'i64.load8_u) (concat (array #x31) (encode_LEB128 (idx ins 1)) (encode_LEB128 (idx ins 2)))) + ((= op 'i64.load16_s) (concat (array #x32) (encode_LEB128 (idx ins 1)) (encode_LEB128 (idx ins 2)))) + ((= op 'i64.load16_u) (concat (array #x33) (encode_LEB128 (idx ins 1)) (encode_LEB128 (idx ins 2)))) + ((= op 'i64.load32_s) (concat (array #x34) (encode_LEB128 (idx ins 1)) (encode_LEB128 (idx ins 2)))) + ((= op 'i64.load32_u) (concat (array #x35) (encode_LEB128 (idx ins 1)) (encode_LEB128 (idx ins 2)))) + ((= op 'i32.store) (concat (array #x36) (encode_LEB128 (idx ins 1)) (encode_LEB128 (idx ins 2)))) + ((= op 'i64.store) (concat (array #x37) (encode_LEB128 (idx ins 1)) (encode_LEB128 (idx ins 2)))) + ((= op 'i32.store8) (concat (array #x3A) (encode_LEB128 (idx ins 1)) (encode_LEB128 (idx ins 2)))) + ((= op 'i32.store16) (concat (array #x3B) (encode_LEB128 (idx ins 1)) (encode_LEB128 (idx ins 2)))) + ((= op 'i64.store8) (concat (array #x3C) (encode_LEB128 (idx ins 1)) (encode_LEB128 (idx ins 2)))) + ((= op 'i64.store16) (concat (array #x3D) (encode_LEB128 (idx ins 1)) (encode_LEB128 (idx ins 2)))) + ((= op 'memory.grow) (array #x40 #x00)) + ; Numeric Instructions + ((= op 'i32.const) (concat (array #x41) (encode_LEB128 (idx ins 1)))) + ((= op 'i64.const) (concat (array #x42) (encode_LEB128 (idx ins 1)))) + ((= op 'i32.eqz) (array #x45)) + ((= op 'i32.eq) (array #x46)) + ((= op 'i32.ne) (array #x47)) + ((= op 'i32.lt_s) (array #x48)) + ((= op 'i32.lt_u) (array #x49)) + ((= op 'i32.gt_s) (array #x4A)) + ((= op 'i32.gt_u) (array #x4B)) + ((= op 'i32.le_s) (array #x4C)) + ((= op 'i32.le_u) (array #x4D)) + ((= op 'i32.ge_s) (array #x4E)) + ((= op 'i32.ge_u) (array #x4F)) + + ((= op 'i64.eqz) (array #x50)) + ((= op 'i64.eq) (array #x51)) + ((= op 'i64.ne) (array #x52)) + ((= op 'i64.lt_s) (array #x53)) + ((= op 'i64.lt_u) (array #x54)) + ((= op 'i64.gt_s) (array #x55)) + ((= op 'i64.gt_u) (array #x56)) + ((= op 'i64.le_s) (array #x57)) + ((= op 'i64.le_u) (array #x58)) + ((= op 'i64.ge_s) (array #x59)) + ((= op 'i64.ge_u) (array #x5A)) + + ((= op 'i32.add) (array #x6A)) + ((= op 'i32.sub) (array #x6B)) + ((= op 'i32.mul) (array #x6C)) + ((= op 'i32.div_s) (array #x6D)) + ((= op 'i32.div_u) (array #x6E)) + ((= op 'i32.rem_s) (array #x6F)) + ((= op 'i32.rem_u) (array #x70)) + ((= op 'i32.and) (array #x71)) + ((= op 'i32.or) (array #x72)) + ((= op 'i32.shl) (array #x74)) + ((= op 'i32.shr_s) (array #x75)) + ((= op 'i32.shr_u) (array #x76)) + ((= op 'i64.add) (array #x7C)) + ((= op 'i64.sub) (array #x7D)) + ((= op 'i64.mul) (array #x7E)) + ((= op 'i64.div_s) (array #x7F)) + ((= op 'i64.div_u) (array #x80)) + ((= op 'i64.rem_s) (array #x81)) + ((= op 'i64.rem_u) (array #x82)) + ((= op 'i64.and) (array #x83)) + ((= op 'i64.or) (array #x84)) + ((= op 'i64.xor) (array #x85)) + ((= op 'i64.shl) (array #x86)) + ((= op 'i64.shr_s) (array #x87)) + ((= op 'i64.shr_u) (array #x88)) + + ((= op 'i32.wrap_i64) (array #xA7)) + ((= op 'i64.extend_i32_s) (array #xAC)) + ((= op 'i64.extend_i32_u) (array #xAD)) + + ((= op 'memory.copy) (array #xFC #x0A #x00 #x00)) + )) + )) + + (encode_expr (lambda (expr) (concat (flat_map encode_ins expr) (array #x0B)))) + (encode_code (lambda (x) + (dlet ( + ((locals body) x) + (enc_locals (encode_vector (lambda (loc) + (concat (encode_LEB128 (idx loc 0)) (encode_valtype (idx loc 1)))) locals)) + (enc_expr (encode_expr body)) + (code_bytes (concat enc_locals enc_expr)) + ) (concat (encode_LEB128 (len code_bytes)) code_bytes)) + )) + (encode_code_section (lambda (x) + (let ( + (encoded (encode_vector encode_code x)) + ) (concat (array #x0A) (encode_LEB128 (len encoded)) encoded )) + )) + + (encode_global_type (lambda (t) (concat (encode_valtype (idx t 0)) (cond ((= (idx t 1) 'const) (array #x00)) + ((= (idx t 1) 'mut) (array #x01)) + (true (error (str "bad mutablity " (idx t 1)))))))) + (encode_global_section (lambda (global_section) + (let ( + ;(_ (print "encoding exprs " global_section)) + (encoded (encode_vector (lambda (x) (concat (encode_global_type (idx x 0)) (encode_expr (idx x 1)))) global_section)) + ) (concat (array #x06) (encode_LEB128 (len encoded)) encoded )) + )) + + ; only supporting one type of element section for now, active funcrefs with offset + (encode_element (lambda (x) (concat (array #x00) (encode_expr (idx x 0)) (encode_vector encode_LEB128 (idx x 1))))) + (encode_element_section (lambda (x) + (let ( + ;(_ (print "encoding element " x)) + (encoded (encode_vector encode_element x)) + ;(_ (print "donex")) + ) (concat (array #x09) (encode_LEB128 (len encoded)) encoded )) + )) + + + (encode_data (lambda (data) (cond ((= 2 (len data)) (concat (array #x00) (encode_expr (idx data 0)) (encode_bytes (idx data 1)))) + ((= 1 (len data)) (concat (array #x01) (encode_bytes (idx data 0)))) + ((= 3 (len data)) (concat (array #x02) (encode_LEB128 (idx data 0)) (encode_expr (idx data 1)) (encode_bytes (idx data 2)))) + (true (error (str "bad data" data)))))) + (encode_data_section (lambda (x) + (let ( + (encoded (encode_vector encode_data x)) + ) (concat (array #x0B) (encode_LEB128 (len encoded)) encoded )) + )) + + + (wasm_to_binary (lambda (wasm_code) + (dlet ( + ((type_section import_section function_section table_section memory_section global_section export_section start_section element_section code_section data_section) wasm_code) + ;(_ (println "type_section" type_section "import_section" import_section "function_section" function_section "memory_section" memory_section "global_section" global_section "export_section" export_section "start_section" start_section "element_section" element_section "code_section" code_section "data_section" data_section)) + (magic (array #x00 #x61 #x73 #x6D )) + (version (array #x01 #x00 #x00 #x00 )) + (type (encode_type_section type_section)) + (import (encode_import_section import_section)) + (function (encode_function_section function_section)) + (table (encode_table_section table_section)) + (memory (encode_memory_section memory_section)) + (global (encode_global_section global_section)) + (export (encode_export_section export_section)) + (start (encode_start_section start_section)) + (elem (encode_element_section element_section)) + (code (encode_code_section code_section)) + (data (encode_data_section data_section)) + ;data_count (let (body (encode_LEB128 (len data_section))) (concat (array #x0C) (encode_LEB128 (len body)) body)) + (data_count (array)) + ) (concat magic version type import function table memory global export data_count start elem code data)) + )) + + (module (lambda args (let ( + (helper (rec-lambda recurse (entries i name_dict type import function table memory global export start elem code data) + (if (= i (len entries)) (array type import function table memory global export start elem code data) + (dlet ( + ((n_d t im f ta m g e s elm c d) ((idx entries i) name_dict type import function table memory global export start elem code data)) + ) (recurse entries (+ i 1) n_d t im f ta m g e s elm c d))))) + ) (helper (apply concat args) 0 empty_dict (array ) (array ) (array ) (array ) (array ) (array ) (array ) (array ) (array ) (array ) (array ))))) + + (table (lambda (idx_name . limits_type) (array (lambda (name_dict type import function table memory global export start elem code data) + (array (put name_dict idx_name (len table)) type import function (concat table (array (array (idx limits_type -1) (slice limits_type 0 -2) ))) memory global export start elem code data ))))) + + (memory (lambda (idx_name . limits) (array (lambda (name_dict type import function table memory global export start elem code data) + (array (put name_dict idx_name (len memory)) type import function table (concat memory (array limits)) global export start elem code data ))))) + + (func (lambda (name . inside) (array (lambda (name_dict type import function table memory global export start elem code data) + (dlet ( + ;(_ (print "ok, doing a func: " name " with inside " inside)) + ((params result locals body) ((rec-lambda recurse (i pe re) + (cond ((and (= false pe) (< i (len inside)) (array? (idx inside i)) (< 0 (len (idx inside i))) (= 'param (idx (idx inside i) 0))) + (recurse (+ i 1) pe re)) + ((and (= false pe) (= false re) (< i (len inside)) (array? (idx inside i)) (< 0 (len (idx inside i))) (= 'result (idx (idx inside i) 0))) + ; only one result possible + (recurse (+ i 1) i (+ i 1))) + ((and (= false re) (< i (len inside)) (array? (idx inside i)) (< 0 (len (idx inside i))) (= 'result (idx (idx inside i) 0))) + ; only one result possible + (recurse (+ i 1) pe (+ i 1))) + ((and (< i (len inside)) (array? (idx inside i)) (< 0 (len (idx inside i))) (= 'local (idx (idx inside i) 0))) + (recurse (+ i 1) (or pe i) (or re i))) + (true (array (slice inside 0 (or pe i)) (slice inside (or pe i) (or re pe i)) (slice inside (or re pe i) i) (slice inside i -1))) + ) + ) 0 false false)) + (result (if (!= 0 (len result)) (array (idx (idx result 0) 1)) + result)) + ;(_ (println "params " params " result " result " locals " locals " body " body)) + (outer_name_dict (put name_dict name (len function))) + ((num_params inner_name_dict) (foldl (lambda (a x) (array (+ (idx a 0) 1) (put (idx a 1) (idx x 1) (idx a 0)))) (array 0 outer_name_dict ) params)) + ((num_locals inner_name_dict) (foldl (lambda (a x) (array (+ (idx a 0) 1) (put (idx a 1) (idx x 1) (idx a 0)))) (array num_params inner_name_dict ) locals)) + ;(_ (println "inner name dict" inner_name_dict)) + (compressed_locals ((rec-lambda recurse (cur_list cur_typ cur_num i) + (cond ((and (= i (len locals)) (= 0 cur_num)) cur_list) + ((= i (len locals)) (concat cur_list (array (array cur_num cur_typ) ))) + ((= cur_typ (idx (idx locals i) 2)) (recurse cur_list cur_typ (+ 1 cur_num) (+ 1 i))) + ((= nil cur_typ) (recurse cur_list (idx (idx locals i) 2) 1 (+ 1 i))) + (true (recurse (concat cur_list (array (array cur_num cur_typ))) (idx (idx locals i) 2) 1 (+ 1 i)))) + ) (array) nil 0 0)) + ;(_ (println "params: " params " result: " result)) + (our_type (array (map (lambda (x) (idx x 2)) params) result)) + ;(inner_env (add-dict-to-env de (put inner_name_dict 'depth 0))) + (inner_name_dict_with_depth (put inner_name_dict 'depth 0)) + ;(_ (println "about to get our_code: " body)) + (our_code (flat_map (lambda (inss) (map (lambda (ins) (ins inner_name_dict_with_depth)) inss)) + body)) + ;(_ (println "resulting code " our_code)) + ) (array + outer_name_dict + ; type + (concat type (array our_type )) + ; import + import + ; function + (concat function (array (len function) )) + ; table + table + ; memory + memory + ; global + global + ; export + export + ; start + start + ; element + elem + ; code + (concat code (array (array compressed_locals our_code ) )) + ; data + data + )) + )))) + + + ;;;;;;;;;;;;;;; + ; Instructions + ;;;;;;;;;;;;;;; + (unreachable (lambda () (array (lambda (name_dict) (array 'unreachable))))) + (drop (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'drop)))))) + (i32.const (lambda (const) (array (lambda (name_dict) (array 'i32.const const))))) + (i64.const (lambda (const) (array (lambda (name_dict) (array 'i64.const const))))) + (local.get (lambda (const) (array (lambda (name_dict) (array 'local.get (if (int? const) const (get-value name_dict const))))))) + (local.set (lambda (const . flatten) (concat (apply concat flatten) (array (lambda (name_dict) (array 'local.set (if (int? const) const (get-value name_dict const)))))))) + (local.tee (lambda (const . flatten) (concat (apply concat flatten) (array (lambda (name_dict) (array 'local.tee (if (int? const) const (get-value name_dict const)))))))) + (global.get (lambda (const) (array (lambda (name_dict) (array 'global.get (if (int? const) const (get-value name_dict const))))))) + (global.set (lambda (const . flatten) (concat (apply concat flatten) (array (lambda (name_dict) (array 'global.set (if (int? const) const (get-value name_dict const)))))))) + (i32.add (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.add)))))) + (i32.sub (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.sub)))))) + (i32.mul (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.mul)))))) + (i32.div_s (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.div_s)))))) + (i32.div_u (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.div_u)))))) + (i32.rem_s (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.rem_s)))))) + (i32.rem_u (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.rem_u)))))) + (i32.and (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.and)))))) + (i32.or (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.or)))))) + (i64.add (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.add)))))) + (i64.sub (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.sub)))))) + (i64.mul (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.mul)))))) + (i64.div_s (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.div_s)))))) + (i64.div_u (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.div_u)))))) + (i64.rem_s (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.rem_s)))))) + (i64.rem_u (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.rem_u)))))) + (i64.and (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.and)))))) + (i64.or (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.or)))))) + (i64.xor (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.xor)))))) + + (i32.eqz (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.eqz)))))) + (i32.eq (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.eq)))))) + (i32.ne (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.ne)))))) + (i32.lt_s (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.lt_s)))))) + (i32.lt_u (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.lt_u)))))) + (i32.gt_s (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.gt_s)))))) + (i32.gt_u (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.gt_u)))))) + (i32.le_s (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.le_s)))))) + (i32.le_u (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.le_u)))))) + (i32.ge_s (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.ge_s)))))) + (i32.ge_u (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.ge_u)))))) + (i64.eqz (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.eqz)))))) + (i64.eq (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.eq)))))) + (i64.ne (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.ne)))))) + (i64.lt_s (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.lt_s)))))) + (i64.lt_u (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.lt_u)))))) + (i64.gt_s (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.gt_s)))))) + (i64.gt_u (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.gt_u)))))) + (i64.le_s (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.le_s)))))) + (i64.le_u (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.le_u)))))) + (i64.ge_s (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.ge_s)))))) + (i64.ge_u (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.ge_u)))))) + + (mem_load (lambda (op align) (lambda flatten (dlet ( + (explicit_offset (int? (idx flatten 0))) + (offset (if explicit_offset (idx flatten 0) 0)) + (flatten_rest (if explicit_offset (slice flatten 1 -1) flatten)) + ) (concat (apply concat flatten_rest) (array (lambda (name_dict) (array op align offset)))))))) + + (i32.load (mem_load 'i32.load 2)) + (i64.load (mem_load 'i64.load 3)) + (i32.store (mem_load 'i32.store 2)) + (i64.store (mem_load 'i64.store 3)) + (i32.store8 (mem_load 'i32.store8 0)) + (i32.store16 (mem_load 'i32.store16 1)) + (i64.store8 (mem_load 'i64.store8 0)) + (i64.store16 (mem_load 'i64.store16 1)) + + (i32.load8_s (mem_load 'i32.load8_s 0)) + (i32.load8_u (mem_load 'i32.load8_u 0)) + (i32.load16_s (mem_load 'i32.load16_s 1)) + (i32.load16_u (mem_load 'i32.load16_u 1)) + (i64.load8_s (mem_load 'i64.load8_s 0)) + (i64.load8_u (mem_load 'i64.load8_u 0)) + (i64.load16_s (mem_load 'i64.load16_s 1)) + (i64.load16_u (mem_load 'i64.load16_u 1)) + (i64.load32_s (mem_load 'i64.load32_s 2)) + (i64.load32_u (mem_load 'i64.load32_u 2)) + + (memory.grow (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'memory.grow)))))) + (i32.shl (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.shl)))))) + (i32.shr_u (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.shr_u)))))) + (i64.shl (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.shl)))))) + (i64.shr_s (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.shr_s)))))) + (i64.shr_u (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.shr_u)))))) + + (i32.wrap_i64 (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.wrap_i64)))))) + (i64.extend_i32_s (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.extend_i32_s)))))) + (i64.extend_i32_u (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.extend_i32_u)))))) + + (memory.copy (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'memory.copy)))))) + + (block_like_body (lambda (name_dict name inner) (let* ( + (new_depth (+ 1 (get-value name_dict 'depth))) + (inner_env (put (put name_dict name new_depth) 'depth new_depth)) + ) (flat_map (lambda (inss) (map (lambda (ins) (ins inner_env)) inss)) inner)))) + + + (block (lambda (name . inner) (array (lambda (name_dict) (array 'block (array) (block_like_body name_dict name inner)))))) + (_loop (lambda (name . inner) (array (lambda (name_dict) (array 'loop (array) (block_like_body name_dict name inner)))))) + (_if (lambda (name . inner) (dlet ( + ((end_idx else_section) (if (= 'else (idx (idx inner -1) 0)) (array -2 (slice (idx inner -1) 1 -1) ) + (array -1 nil ))) + ((end_idx then_section) (if (= 'then (idx (idx inner end_idx) 0)) (array (- end_idx 1) (slice (idx inner end_idx) 1 -1) ) + (array (- end_idx 1) (array (idx inner end_idx) ) ))) + ((start_idx result_t) (if (= 'result (idx (idx inner 0) 0)) (array 1 (idx (idx inner 0) 1)) + (array 0 (array)))) + (flattened (apply concat (slice inner start_idx end_idx))) + ;(_ (println "result_t " result_t " flattened " flattened " then_section " then_section " else_section " else_section)) + ) (concat flattened (array (lambda (name_dict) (concat (array 'if result_t (block_like_body name_dict name then_section)) + (if (!= nil else_section) (array (block_like_body name_dict name else_section)) + (array))))))))) + + (then (lambda rest (cons 'then rest))) + (else (lambda rest (cons 'else rest))) + + (br (lambda (block) (array (lambda (name_dict) (array 'br (if (int? block) block (- (get-value name_dict 'depth) (get-value name_dict block)))))))) + (br_if (lambda (block . flatten) (concat (apply concat flatten) (array (lambda (name_dict) (array 'br_if (if (int? block) block (- (get-value name_dict 'depth) (get-value name_dict block))))))))) + (call (lambda (f . flatten) (concat (apply concat flatten) (array (lambda (name_dict) (array 'call (if (int? f) f (get-value name_dict f)))))))) + (call_indirect (lambda (type_idx table_idx . flatten) (concat (apply concat flatten) (array (lambda (name_dict) (array 'call_indirect type_idx table_idx)))))) + + ;;;;;;;;;;;;;;;;;;; + ; End Instructions + ;;;;;;;;;;;;;;;;;;; + + (import (lambda (mod_name name t_idx_typ) (array (lambda (name_dict type import function table memory global export start elem code data) (dlet ( + (_ (if (!= 'func (idx t_idx_typ 0)) (error "only supporting importing functions rn"))) + ((import_type idx_name param_type result_type) t_idx_typ) + (actual_type_idx (len type)) + (actual_type (array (slice param_type 1 -1) (slice result_type 1 -1) )) + ) + (array (put name_dict idx_name (len function)) (concat type (array actual_type)) (concat import (array (array mod_name name import_type actual_type_idx) )) (concat function (array nil)) table memory global export start elem code data )) + )))) + + (global (lambda (idx_name global_type expr) (array (lambda (name_dict type import function table memory global export start elem code data) + (array (put name_dict idx_name (len global)) + type import function table memory + (concat global (array (array (if (array? global_type) (reverse global_type) (array global_type 'const)) (map (lambda (x) (x empty_dict)) expr) ))) + export start elem code data ) + )))) + + (export (lambda (name t_v) (array (lambda (name_dict type import function table memory global export start elem code data) + (array name_dict type import function table memory global + (concat export (array (array name (idx t_v 0) (get-value name_dict (idx t_v 1)) ) )) + start elem code data ) + )))) + + (start (lambda (name) (array (lambda (name_dict type import function table memory global export start elem code data) + (array name_dict type import function table memory global export (concat start (array (get-value name_dict name))) elem code data ) + )))) + + (elem (lambda (offset . entries) (array (lambda (name_dict type import function table memory global export start elem code data) + (array name_dict type import function table memory global export start (concat elem (array (array (map (lambda (x) (x empty_dict)) offset) (map (lambda (x) (if (int? x) x (get-value name_dict x))) entries)))) code data ) + )))) + + (data (lambda it (array (lambda (name_dict type import function table memory global export start elem code data) + (array name_dict type import function table memory global export start elem code + (concat data (array (map (lambda (x) (if (array? x) (map (lambda (y) (y empty_dict)) x) x)) it)))))))) + + + ; Everything is an i64, and we're on a 32 bit wasm system, so we have a good many bits to play with + + ; Int - should maximize int + ; xxxxx0 + + ; String - should be close to array, bitpacked, just different ptr rep? + ; 011 + + ; Symbol - ideally interned (but not yet) also probs small-symbol-opt (def not yet) + ; 111 + + ; Array / Nil + ; 101 / 0..0 101 + + ; Combiner - a double of func index and closure (which could just be the env, actually, even if we trim...) + ; |0001 + + ; Env + ; 0..001001 + ; Env object is + ; each being the full 64 bit objects. + ; This lets key_array exist in constant mem, and value array to come directly from passed params. + + ; True / False + ; 0..0 1 11001 / 0..0 0 11001 + + (to_hex_digit (lambda (x) (string (integer->char (if (< x 10) (+ x #x30) + (+ x #x37)))))) + (le_hexify_helper (rec-lambda recurse (x i) (if (= i 0) "" + (concat "\\" (to_hex_digit (remainder (quotient x 16) 16)) + (to_hex_digit (remainder x 16)) + (recurse (quotient x 256) (- i 1)))))) + (i64_le_hexify (lambda (x) (le_hexify_helper (bitwise-and x #xFFFFFFFFFFFFFFFF) 8))) + (i32_le_hexify (lambda (x) (le_hexify_helper (bitwise-and x #xFFFFFFFF) 4))) + + + (compile (dlambda ((pectx partial_eval_err marked_code)) (mif partial_eval_err (error partial_eval_err) (wasm_to_binary (module + (import "wasi_unstable" "path_open" + '(func $path_open (param i32 i32 i32 i32 i32 i64 i64 i32 i32) + (result i32))) + (import "wasi_unstable" "fd_read" + '(func $fd_read (param i32 i32 i32 i32) + (result i32))) + (import "wasi_unstable" "fd_write" + '(func $fd_write (param i32 i32 i32 i32) + (result i32))) + (global '$malloc_head '(mut i32) (i32.const 0)) + (global '$phs '(mut i32) (i32.const 0)) + (global '$phl '(mut i32) (i32.const 0)) + (dlet ( + (nil_val #b0101) + (true_val #b000111001) + (false_val #b000011001) + (alloc_data (dlambda (d (watermark datas)) (cond ((str? d) (let ((size (+ 8 (band (len d) -8)))) + (array (+ watermark 8) + (len d) + (array (+ watermark 8 size) + (concat datas + (data (i32.const watermark) + (concat (i32_le_hexify size) "\\00\\00\\00\\80" d))))))) + (true (error (str "can't alloc_data for anything else besides strings yet" d))) + ) + )) + ; We won't use 0 because some impls seem to consider that NULL and crash on reading/writing? + (iov_tmp 8) ; <32bit len><32bit ptr> + <32bit numwitten> + (datasi (array (+ iov_tmp 16) (array))) + ((true_loc true_length datasi) (alloc_data "true" datasi)) + ((false_loc false_length datasi) (alloc_data "false" datasi)) + + ((bad_params_number_loc bad_params_length datasi) (alloc_data "\nError: passed a bad number of parameters\n" datasi)) + (bad_params_number_msg_val (bor (<< bad_params_length 32) bad_params_number_loc #b011)) + + ((bad_params_type_loc bad_params_length datasi) (alloc_data "\nError: passed a bad type of parameters\n" datasi)) + (bad_params_type_msg_val (bor (<< bad_params_length 32) bad_params_type_loc #b011)) + + ((error_loc error_length datasi) (alloc_data "\nError: " datasi)) + (error_msg_val (bor (<< error_length 32) error_loc #b011)) + ((log_loc log_length datasi) (alloc_data "\nLog: " datasi)) + (log_msg_val (bor (<< log_length 32) log_loc #b011)) + + ((call_ok_loc call_ok_length datasi) (alloc_data "call ok!" datasi)) + (call_ok_msg_val (bor (<< call_ok_length 32) call_ok_loc #b011)) + + ((newline_loc newline_length datasi) (alloc_data "\n" datasi)) + (newline_msg_val (bor (<< newline_length 32) newline_loc #b011)) + + ((space_loc space_length datasi) (alloc_data " " datasi)) + (space_msg_val (bor (<< space_length 32) space_loc #b011)) + + ((remaining_eval_loc remaining_eval_length datasi) (alloc_data "\nError: trying to call remainin eval\n" datasi)) + (remaining_eval_msg_val (bor (<< remaining_eval_length 32) remaining_eval_loc #b011)) + + ((remaining_vau_loc remaining_vau_length datasi) (alloc_data "\nError: trying to call remainin vau (primitive)\n" datasi)) + (remaining_vau_msg_val (bor (<< remaining_vau_length 32) remaining_vau_loc #b011)) + + ((remaining_cond_loc remaining_cond_length datasi) (alloc_data "\nError: trying to call remainin cond\n" datasi)) + (remaining_cond_msg_val (bor (<< remaining_cond_length 32) remaining_cond_loc #b011)) + + ((weird_wrap_loc weird_wrap_length datasi) (alloc_data "\nError: trying to call a combiner with a weird wrap (not 0 or 1)\n" datasi)) + (weird_wrap_msg_val (bor (<< weird_wrap_length 32) weird_wrap_loc #b011)) + + ((bad_not_vau_loc bad_not_vau_length datasi) (alloc_data "\nError: Trying to call a function (not vau) but the parameters caused a compile error\n" datasi)) + (bad_not_vau_msg_val (bor (<< bad_not_vau_length 32) bad_not_vau_loc #b011)) + + ((going_up_loc going_up_length datasi) (alloc_data "going up" datasi)) + (going_up_msg_val (bor (<< going_up_length 32) going_up_loc #b011)) + + ((starting_from_loc starting_from_length datasi) (alloc_data "starting from " datasi)) + (starting_from_msg_val (bor (<< starting_from_length 32) starting_from_loc #b011)) + + ((got_it_loc got_it_length datasi) (alloc_data "got it" datasi)) + (got_it_msg_val (bor (<< got_it_length 32) got_it_loc #b011)) + + ((couldnt_parse_1_loc couldnt_parse_1_length datasi) (alloc_data "\nError: Couldn't parse:\n" datasi)) + ( couldnt_parse_1_msg_val (bor (<< couldnt_parse_1_length 32) couldnt_parse_1_loc #b011)) + ((couldnt_parse_2_loc couldnt_parse_2_length datasi) (alloc_data "\nAt character:\n" datasi)) + ( couldnt_parse_2_msg_val (bor (<< couldnt_parse_2_length 32) couldnt_parse_2_loc #b011)) + ((parse_remaining_loc parse_remaining_length datasi) (alloc_data "\nLeft over after parsing, starting at byte offset:\n" datasi)) + ( parse_remaining_msg_val (bor (<< parse_remaining_length 32) parse_remaining_loc #b011)) + + ((quote_sym_loc quote_sym_length datasi) (alloc_data "quote" datasi)) + (quote_sym_val (bor (<< quote_sym_length 32) quote_sym_loc #b111)) + + ; 0 is path_open, 1 is fd_read, 2 is fd_write + ;(num_pre_functions 2) + (num_pre_functions 3) + ((func_idx funcs) (array num_pre_functions (array))) + + ; malloc allocates with size and refcount in header + ((k_malloc func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$malloc '(param $bytes i32) '(result i32) '(local $result i32) '(local $ptr i32) '(local $last i32) '(local $pages i32) + (local.set '$bytes (i32.add (i32.const 8) (local.get '$bytes))) + (local.set '$result (i32.const 0)) + (_if '$has_head + (i32.ne (i32.const 0) (global.get '$malloc_head)) + (then + (local.set '$ptr (global.get '$malloc_head)) + (local.set '$last (i32.const 0)) + (_loop '$l + (_if '$fits + (i32.ge_u (i32.load 0 (local.get '$ptr)) (local.get '$bytes)) + (then + (local.set '$result (local.get '$ptr)) + (_if '$head + (i32.eq (local.get '$result) (global.get '$malloc_head)) + (then + (global.set '$malloc_head (i32.load 4 (global.get '$malloc_head))) + ) + (else + (i32.store 4 (local.get '$last) (i32.load 4 (local.get '$result))) + ) + ) + ) + (else + (local.set '$last (local.get '$ptr)) + (local.set '$ptr (i32.load 4 (local.get '$ptr))) + (br_if '$l (i32.ne (i32.const 0) (local.get '$ptr))) + ) + ) + ) + ) + ) + (_if '$result_0 + (i32.eqz (local.get '$result)) + (then + (local.set '$pages (i32.add (i32.const 1) (i32.shr_u (local.get '$bytes) (i32.const 16)))) + (local.set '$result (i32.shl (memory.grow (local.get '$pages)) (i32.const 16))) + (i32.store 0 (local.get '$result) (i32.shl (local.get '$pages) (i32.const 16))) + ) + ) + (i32.store 4 (local.get '$result) (i32.const 1)) + (i32.add (local.get '$result) (i32.const 8)) + )))) + + ((k_free func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$free '(param $bytes i32) + ;(local.set '$bytes (i32.sub (local.get '$bytes) (i32.const 8))) + ;(i32.store 4 (local.get '$bytes) (global.get '$malloc_head)) + ;(global.set '$malloc_head (local.get '$bytes)) + )))) + + ((k_get_ptr func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$get_ptr '(param $bytes i64) '(result i32) + (_if '$is_not_string_symbol_array_int '(result i32) + (i64.eq (i64.const #b001) (i64.and (i64.const #b111) (local.get '$bytes))) + (then + (_if '$is_true_false '(result i32) + (i64.eq (i64.const #b11001) (i64.and (i64.const #b11111) (local.get '$bytes))) + (then (i32.const 0)) + (else + (_if '$is_env '(result i32) + (i64.eq (i64.const #b01001) (i64.and (i64.const #b11111) (local.get '$bytes))) + (then (i32.wrap_i64 (i64.shr_u (local.get '$bytes) (i64.const 5)))) + (else (i32.wrap_i64 (i64.and (i64.const #xFFFFFFF8) (i64.shr_u (local.get '$bytes) (i64.const 3))))) ; is comb + ) + ) + ) + ) + (else + (_if '$is_int '(result i32) + (i64.eq (i64.const #b0) (i64.and (i64.const #b1) (local.get '$bytes))) + (then (i32.const 0)) + (else (i32.wrap_i64 (i64.and (i64.const -8) (local.get '$bytes)))) ; str symbol and array all get ptrs just masking FFFFFFF8 + ) + ) + ) + )))) + ((k_dup func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$dup '(param $bytes i64) '(result i64) '(local $ptr i32) '(local $old_val i32) + (local.set '$ptr (call '$get_ptr (local.get '$bytes))) + (_if '$not_null + (i32.ne (i32.const 0) (local.get '$ptr)) + (then + (local.set '$ptr (i32.sub (local.get '$ptr) (i32.const 8))) + (_if '$not_max_neg + ;(i32.ne (i32.const (- #x80000000)) (local.tee '$old_val (i32.load 4 (local.get '$ptr)))) + (i32.gt_s (local.tee '$old_val (i32.load 4 (local.get '$ptr))) (i32.const 0)) + (then + (i32.store 4 (local.get '$ptr) (i32.add (local.get '$old_val) (i32.const 1))) + ) + ) + ) + ) + (local.get '$bytes) + )))) + ((k_drop func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$drop '(param $it i64) '(local $ptr i32) '(local $old_val i32) '(local $new_val i32) '(local $i i32) + (local.set '$ptr (call '$get_ptr (local.get '$it))) + (_if '$not_null + (i32.ne (i32.const 0) (local.get '$ptr)) + (then + (_if '$not_max_neg + ;(i32.ne (i32.const (- #x80000000)) (local.tee '$old_val (i32.load (i32.add (i32.const -4) (local.get '$ptr))))) + (i32.gt_s (local.tee '$old_val (i32.load (i32.add (i32.const -4) (local.get '$ptr)))) (i32.const 0)) + (then + (_if '$zero + (i32.eqz (local.tee '$new_val (i32.sub (local.get '$old_val) (i32.const 1)))) + (then + (_if '$needs_inner_drop + (i64.eq (i64.const #b01) (i64.and (i64.const #b11) (local.get '$it))) + (then + (_if '$is_array + (i64.eq (i64.const #b101) (i64.and (i64.const #b111) (local.get '$it))) + (then + (local.set '$i (i32.wrap_i64 (i64.shr_u (local.get '$it) (i64.const 32)))) + (_loop '$l + (call '$drop (i64.load (local.get '$ptr))) + (local.set '$ptr (i32.add (local.get '$ptr) (i32.const 8))) + (local.set '$i (i32.sub (local.get '$i) (i32.const 1))) + (br_if '$l (i32.ne (i32.const 0) (local.get '$i))) + ) + ) + (else + (call '$drop (i64.load 0 (local.get '$ptr))) + (call '$drop (i64.load 8 (local.get '$ptr))) + (call '$drop (i64.load 16 (local.get '$ptr))) + ) + ) + ) + ) + (call '$free (local.get '$ptr)) + ) + (else (i32.store (i32.add (i32.const -4) (local.get '$ptr)) (local.get '$new_val))) + ) + ) + ) + ) + ) + )))) + + ; 0..001001 + ((k_env_alloc func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$env_alloc '(param $keys i64) '(param $vals i64) '(param $upper i64) '(result i64) '(local $tmp i32) + (local.set '$tmp (call '$malloc (i32.const (* 8 3)))) + (i64.store 0 (local.get '$tmp) (local.get '$keys)) + (i64.store 8 (local.get '$tmp) (local.get '$vals)) + (i64.store 16 (local.get '$tmp) (local.get '$upper)) + (i64.or (i64.shl (i64.extend_i32_u (local.get '$tmp)) (i64.const 5)) (i64.const #b01001)) + )))) + + ; 101 / 0..0 101 + ((k_array1_alloc func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$array1_alloc '(param $item i64) '(result i64) '(local $tmp i32) + (local.set '$tmp (call '$malloc (i32.const 8))) + (i64.store 0 (local.get '$tmp) (local.get '$item)) + (i64.or (i64.extend_i32_u (local.get '$tmp)) (i64.const #x0000000100000005)) + )))) + ((k_array2_alloc func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$array2_alloc '(param $a i64) '(param $b i64) '(result i64) '(local $tmp i32) + (local.set '$tmp (call '$malloc (i32.const 16))) + (i64.store 0 (local.get '$tmp) (local.get '$a)) + (i64.store 8 (local.get '$tmp) (local.get '$b)) + (i64.or (i64.extend_i32_u (local.get '$tmp)) (i64.const #x0000000200000005)) + )))) + + ; Not called with actual objects, not subject to refcounting + ((k_int_digits func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$int_digits '(param $int i64) '(result i32) '(local $tmp i32) + (_if '$is_neg + (i64.lt_s (local.get '$int) (i64.const 0)) + (then + (local.set '$int (i64.sub (i64.const 0) (local.get '$int))) + (local.set '$tmp (i32.const 2)) + ) + (else + (local.set '$tmp (i32.const 1)) + ) + ) + (block '$b + (_loop '$l + (br_if '$b (i64.le_u (local.get '$int) (i64.const 9))) + (local.set '$tmp (i32.add (i32.const 1) (local.get '$tmp))) + (local.set '$int (i64.div_u (local.get '$int) (i64.const 10))) + (br '$l) + ) + ) + (local.get '$tmp) + )))) + ; Utility method, not subject to refcounting + ((k_str_len func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$str_len '(param $to_str_len i64) '(result i32) '(local $running_len_tmp i32) '(local $i_tmp i32) '(local $x_tmp i32) '(local $y_tmp i32) '(local $ptr_tmp i32) '(local $item i64) + (_if '$is_true '(result i32) + (i64.eq (i64.const true_val) (local.get '$to_str_len)) + (then (i32.const true_length)) + (else + (_if '$is_false '(result i32) + (i64.eq (i64.const false_val) (local.get '$to_str_len)) + (then (i32.const false_length)) + (else + (_if '$is_str_or_symbol '(result i32) + (i64.eq (i64.const #b11) (i64.and (i64.const #b11) (local.get '$to_str_len))) + (then (_if '$is_str '(result i32) + (i64.eq (i64.const #b000) (i64.and (i64.const #b100) (local.get '$to_str_len))) + (then (i32.add (i32.const 2) (i32.wrap_i64 (i64.shr_u (local.get '$to_str_len) (i64.const 32))))) + (else (i32.add (i32.const 1) (i32.wrap_i64 (i64.shr_u (local.get '$to_str_len) (i64.const 32))))) + )) + (else + (_if '$is_array '(result i32) + (i64.eq (i64.const #b101) (i64.and (i64.const #b111) (local.get '$to_str_len))) + (then + (local.set '$running_len_tmp (i32.const 1)) + (local.set '$i_tmp (i32.wrap_i64 (i64.shr_u (local.get '$to_str_len) (i64.const 32)))) + (local.set '$x_tmp (i32.wrap_i64 (i64.and (local.get '$to_str_len) (i64.const -8)))) + (block '$b + (_loop '$l + (local.set '$running_len_tmp (i32.add (local.get '$running_len_tmp) (i32.const 1))) + (br_if '$b (i32.eq (local.get '$i_tmp) (i32.const 0))) + (local.set '$running_len_tmp (i32.add (local.get '$running_len_tmp) (call '$str_len (i64.load (local.get '$x_tmp))))) + (local.set '$x_tmp (i32.add (local.get '$x_tmp) (i32.const 8))) + (local.set '$i_tmp (i32.sub (local.get '$i_tmp) (i32.const 1))) + (br '$l) + ) + ) + (local.get '$running_len_tmp) + ) + (else + (_if '$is_env '(result i32) + (i64.eq (i64.const #b01001) (i64.and (i64.const #b11111) (local.get '$to_str_len))) + (then + (local.set '$running_len_tmp (i32.const 0)) + + ; ptr to env + (local.set '$ptr_tmp (i32.wrap_i64 (i64.shr_u (local.get '$to_str_len) (i64.const 5)))) + ; ptr to start of array of symbols + (local.set '$x_tmp (i32.wrap_i64 (i64.and (i64.load (local.get '$ptr_tmp)) (i64.const -8)))) + ; ptr to start of array of values + (local.set '$y_tmp (i32.wrap_i64 (i64.and (i64.load 8 (local.get '$ptr_tmp)) (i64.const -8)))) + ; lenght of both arrays, pulled from array encoding of x + (local.set '$i_tmp (i32.wrap_i64 (i64.shr_u (i64.load (local.get '$ptr_tmp)) (i64.const 32)))) + + (block '$b + (_loop '$l + (local.set '$running_len_tmp (i32.add (local.get '$running_len_tmp) (i32.const 2))) + ; break if 0 length left + (br_if '$b (i32.eq (local.get '$i_tmp) (i32.const 0))) + + (local.set '$running_len_tmp (i32.add (local.get '$running_len_tmp) + (call '$str_len (i64.load (local.get '$x_tmp))))) + (local.set '$running_len_tmp (i32.add (local.get '$running_len_tmp) + (call '$str_len (i64.load (local.get '$y_tmp))))) + (local.set '$running_len_tmp (i32.add (local.get '$running_len_tmp) (i32.const 2))) + + (local.set '$x_tmp (i32.add (local.get '$x_tmp) (i32.const 8))) + (local.set '$y_tmp (i32.add (local.get '$y_tmp) (i32.const 8))) + (local.set '$i_tmp (i32.sub (local.get '$i_tmp) (i32.const 1))) + (br '$l) + ) + ) + ;; deal with upper + (local.set '$item (i64.load 16 (local.get '$ptr_tmp))) + (_if '$is_upper_env + (i64.eq (i64.const #b01001) (i64.and (i64.const #b11111) (local.get '$item))) + (then + (local.set '$running_len_tmp (i32.add (local.get '$running_len_tmp) (i32.const 1))) + (local.set '$running_len_tmp (i32.add (local.get '$running_len_tmp) (call '$str_len (local.get '$item)))) + ) + ) + + (local.get '$running_len_tmp) + ) + (else + (_if '$is_comb '(result i32) + (i64.eq (i64.const #b0001) (i64.and (i64.const #b1111) (local.get '$to_str_len))) + (then + (i32.const 5) + ) + (else + ;; must be int + (call '$int_digits (i64.shr_s (local.get '$to_str_len) (i64.const 1))) + ) + ) + ) + ) + ) + ) + ) + ) + ) + ) + ) + ) + )))) + ; Utility method, not subject to refcounting + ((k_str_helper func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$str_helper '(param $to_str i64) '(param $buf i32) '(result i32) '(local $len_tmp i32) '(local $buf_tmp i32) '(local $ptr_tmp i32) '(local $x_tmp i32) '(local $y_tmp i32) '(local $i_tmp i32) '(local $item i64) + (_if '$is_true '(result i32) + (i64.eq (i64.const true_val) (local.get '$to_str)) + (then (memory.copy (local.get '$buf) + (i32.const true_loc) + (i32.const true_length)) + (i32.const true_length)) + (else + (_if '$is_false '(result i32) + (i64.eq (i64.const false_val) (local.get '$to_str)) + (then (memory.copy (local.get '$buf) + (i32.const false_loc) + (i32.const false_length)) + (i32.const false_length)) + (else + (_if '$is_str_or_symbol '(result i32) + (i64.eq (i64.const #b11) (i64.and (i64.const #b11) (local.get '$to_str))) + (then (_if '$is_str '(result i32) + (i64.eq (i64.const #b000) (i64.and (i64.const #b100) (local.get '$to_str))) + (then + (i32.store8 (local.get '$buf) (i32.const #x22)) + (memory.copy (i32.add (i32.const 1) (local.get '$buf)) + (i32.wrap_i64 (i64.and (i64.const -8) (local.get '$to_str))) + (local.tee '$len_tmp (i32.wrap_i64 (i64.shr_u (local.get '$to_str) (i64.const 32))))) + (i32.store8 1 (i32.add (local.get '$buf) (local.get '$len_tmp)) (i32.const #x22)) + (i32.add (i32.const 2) (local.get '$len_tmp)) + ) + (else + (i32.store8 (local.get '$buf) (i32.const #x27)) + (memory.copy (i32.add (i32.const 1) (local.get '$buf)) + (i32.wrap_i64 (i64.and (i64.const -8) (local.get '$to_str))) + (local.tee '$len_tmp (i32.wrap_i64 (i64.shr_u (local.get '$to_str) (i64.const 32))))) + (i32.add (i32.const 1) (local.get '$len_tmp)) + ) + )) + (else + (_if '$is_array '(result i32) + (i64.eq (i64.const #b101) (i64.and (i64.const #b101) (local.get '$to_str))) + (then + (local.set '$len_tmp (i32.const 0)) + (local.set '$i_tmp (i32.wrap_i64 (i64.shr_u (local.get '$to_str) (i64.const 32)))) + (local.set '$ptr_tmp (i32.wrap_i64 (i64.and (local.get '$to_str) (i64.const -8)))) + (block '$b + (_loop '$l + (i32.store8 (i32.add (local.get '$buf) (local.get '$len_tmp)) (i32.const #x20)) + (local.set '$len_tmp (i32.add (local.get '$len_tmp) (i32.const 1))) + (br_if '$b (i32.eq (local.get '$i_tmp) (i32.const 0))) + (local.set '$len_tmp (i32.add (local.get '$len_tmp) (call '$str_helper (i64.load (local.get '$ptr_tmp)) (i32.add (local.get '$buf) (local.get '$len_tmp))))) + (local.set '$ptr_tmp (i32.add (local.get '$ptr_tmp) (i32.const 8))) + (local.set '$i_tmp (i32.sub (local.get '$i_tmp) (i32.const 1))) + (br '$l) + ) + ) + (i32.store8 (local.get '$buf) (i32.const #x28)) + (i32.store8 (i32.add (local.get '$buf) (local.get '$len_tmp)) (i32.const #x29)) + (i32.add (local.get '$len_tmp) (i32.const 1)) + ) + (else + (_if '$is_env '(result i32) + (i64.eq (i64.const #b01001) (i64.and (i64.const #b11111) (local.get '$to_str))) + (then + (local.set '$len_tmp (i32.const 0)) + + ; ptr to env + (local.set '$ptr_tmp (i32.wrap_i64 (i64.shr_u (local.get '$to_str) (i64.const 5)))) + ; ptr to start of array of symbols + (local.set '$x_tmp (i32.wrap_i64 (i64.and (i64.load (local.get '$ptr_tmp)) (i64.const -8)))) + ; ptr to start of array of values + (local.set '$y_tmp (i32.wrap_i64 (i64.and (i64.load 8 (local.get '$ptr_tmp)) (i64.const -8)))) + ; lenght of both arrays, pulled from array encoding of x + (local.set '$i_tmp (i32.wrap_i64 (i64.shr_u (i64.load (local.get '$ptr_tmp)) (i64.const 32)))) + + (block '$b + (_loop '$l + (i32.store8 (i32.add (local.get '$buf) (local.get '$len_tmp)) (i32.const #x20)) + (local.set '$len_tmp (i32.add (local.get '$len_tmp) (i32.const 1))) + ; break if 0 length left + (br_if '$b (i32.eq (local.get '$i_tmp) (i32.const 0))) + + (local.set '$len_tmp (i32.add (local.get '$len_tmp) (call '$str_helper (i64.load (local.get '$x_tmp)) (i32.add (local.get '$buf) (local.get '$len_tmp))))) + (i32.store8 (i32.add (local.get '$len_tmp) (local.get '$buf)) (i32.const #x3A)) + (local.set '$len_tmp (i32.add (local.get '$len_tmp) (i32.const 1))) + (i32.store8 (i32.add (local.get '$len_tmp) (local.get '$buf)) (i32.const #x20)) + (local.set '$len_tmp (i32.add (local.get '$len_tmp) (i32.const 1))) + (local.set '$len_tmp (i32.add (local.get '$len_tmp) (call '$str_helper (i64.load (local.get '$y_tmp)) (i32.add (local.get '$buf) (local.get '$len_tmp))))) + (i32.store8 (i32.add (local.get '$len_tmp) (local.get '$buf)) (i32.const #x2C)) + (local.set '$len_tmp (i32.add (local.get '$len_tmp) (i32.const 1))) + + (local.set '$x_tmp (i32.add (local.get '$x_tmp) (i32.const 8))) + (local.set '$y_tmp (i32.add (local.get '$y_tmp) (i32.const 8))) + (local.set '$i_tmp (i32.sub (local.get '$i_tmp) (i32.const 1))) + (br '$l) + ) + ) + ;; deal with upper + (local.set '$item (i64.load 16 (local.get '$ptr_tmp))) + (_if '$is_upper_env + (i64.eq (i64.const #b01001) (i64.and (i64.const #b11111) (local.get '$item))) + (then + (i32.store8 -2 (i32.add (local.get '$buf) (local.get '$len_tmp)) (i32.const #x20)) + (i32.store8 -1 (i32.add (local.get '$buf) (local.get '$len_tmp)) (i32.const #x7C)) + (i32.store8 (i32.add (local.get '$len_tmp) (local.get '$buf)) (i32.const #x20)) + (local.set '$len_tmp (i32.add (local.get '$len_tmp) (i32.const 1))) + (local.set '$len_tmp (i32.add (local.get '$len_tmp) (call '$str_helper (local.get '$item) (i32.add (local.get '$buf) (local.get '$len_tmp))))) + ) + ) + (i32.store8 (local.get '$buf) (i32.const #x7B)) + (i32.store8 (i32.add (local.get '$buf) (local.get '$len_tmp)) (i32.const #x7D)) + (local.set '$len_tmp (i32.add (local.get '$len_tmp) (i32.const 1))) + (local.get '$len_tmp) + ) + (else + (_if '$is_comb '(result i32) + (i64.eq (i64.const #b0001) (i64.and (i64.const #b1111) (local.get '$to_str))) + (then + (i32.store (local.get '$buf) (i32.const #x626D6F63)) + (i32.store8 4 (local.get '$buf) + (i32.add (i32.const #x30) + (i32.and (i32.const #b11) + (i32.wrap_i64 (i64.shr_u (local.get '$to_str) (i64.const 4)))))) + (i32.const 5) + ) + (else + ;; must be int + (local.set '$to_str (i64.shr_s (local.get '$to_str) (i64.const 1))) + (local.set '$len_tmp (call '$int_digits (local.get '$to_str))) + (local.set '$buf_tmp (i32.add (local.get '$buf) (local.get '$len_tmp))) + + (_if '$is_neg + (i64.lt_s (local.get '$to_str) (i64.const 0)) + (then + (local.set '$to_str (i64.sub (i64.const 0) (local.get '$to_str))) + (i64.store8 (local.get '$buf) (i64.const #x2D)) + ) + ) + + (block '$b + (_loop '$l + (local.set '$buf_tmp (i32.sub (local.get '$buf_tmp) (i32.const 1))) + (i64.store8 (local.get '$buf_tmp) (i64.add (i64.const #x30) (i64.rem_u (local.get '$to_str) (i64.const 10)))) + (local.set '$to_str (i64.div_u (local.get '$to_str) (i64.const 10))) + (br_if '$b (i64.eq (local.get '$to_str) (i64.const 0))) + (br '$l) + ) + ) + + (local.get '$len_tmp) + ) + ) + ) + ) + ) + ) + ) + ) + ) + ) + ) + ) + )))) + ; Utility method, not subject to refcounting + ((k_print func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$print '(param $to_print i64) '(local $iov i32) '(local $data_size i32) + (local.set '$iov (call '$malloc (i32.add (i32.const 8) + (local.tee '$data_size (call '$str_len (local.get '$to_print)))))) + (drop (call '$str_helper (local.get '$to_print) (i32.add (i32.const 8) (local.get '$iov)))) + (i32.store (local.get '$iov) (i32.add (i32.const 8) (local.get '$iov))) ;; adder of data + (i32.store 4 (local.get '$iov) (local.get '$data_size)) ;; len of data + (drop (call '$fd_write + (i32.const 1) ;; file descriptor + (local.get '$iov) ;; *iovs + (i32.const 1) ;; iovs_len + (local.get '$iov) ;; nwritten + )) + (call '$free (local.get '$iov)) + )))) + + ; Utility method, but does refcount + ((k_slice_impl func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$slice_impl '(param $array i64) '(param $s i32) '(param $e i32) '(result i64) '(local $size i32) '(local $new_size i32) '(local $i i32) '(local $ptr i32) '(local $new_ptr i32) + (local.set '$size (i32.wrap_i64 (i64.shr_u (local.get '$array) (i64.const 32)))) + (local.set '$ptr (i32.wrap_i64 (i64.and (local.get '$array) (i64.const -8)))) + (_if '$s_lt_0 + (i32.lt_s (local.get '$s) (i32.const 0)) + (then + (local.set '$s (i32.add (i32.const 1) (i32.add (local.get '$s) (local.get '$size)))) + ) + ) + (_if '$e_lt_0 + (i32.lt_s (local.get '$e) (i32.const 0)) + (then + (local.set '$e (i32.add (i32.const 1) (i32.add (local.get '$e) (local.get '$size)))) + ) + ) + + (_if '$s_lt_0 (i32.lt_s (local.get '$s) (i32.const 0)) (then (unreachable))) + (_if '$e_lt_s (i32.lt_s (local.get '$e) (local.get '$s)) (then (unreachable))) + (_if '$e_gt_size (i32.gt_s (local.get '$e) (local.get '$size)) (then (unreachable))) + + (local.set '$new_size (i32.sub (local.get '$e) (local.get '$s))) + (_if '$new_size_0 '(result i64) + (i32.eqz (local.get '$new_size)) + (then + (i64.const nil_val) + ) + (else + (local.set '$new_ptr (call '$malloc (i32.shl (local.get '$new_size) (i32.const 3)))) ; malloc(size*8) + + (local.set '$i (i32.const 0)) + (block '$exit_loop + (_loop '$l + (br_if '$exit_loop (i32.eq (local.get '$i) (local.get '$new_size))) + (i64.store (i32.add (i32.shl (local.get '$i) (i32.const 3)) (local.get '$new_ptr)) + (call '$dup (i64.load (i32.add (i32.shl (i32.add (local.get '$s) (local.get '$i)) (i32.const 3)) (local.get '$ptr))))) ; n[i] = dup(o[i+s]) + (local.set '$i (i32.add (i32.const 1) (local.get '$i))) + (br '$l) + ) + ) + (call '$drop (local.get '$array)) + + (i64.or (i64.or (i64.extend_i32_u (local.get '$new_ptr)) (i64.const #x5)) + (i64.shl (i64.extend_i32_u (local.get '$new_size)) (i64.const 32))) + ) + ) + )))) + + ; chose k_slice_impl because it will never be called, so that + ; no function will have a 0 func index and count as falsy + (dyn_start (+ 0 k_slice_impl)) + + + ; This and is 1111100011 + ; The end ensuring 01 makes only + ; array comb env and bool apply + ; catching only 0array and false + ; and a comb with func idx 0 + ; and null env. If we prevent + ; this from happening, it's + ; exactly what we want + (truthy_test (lambda (x) (i64.ne (i64.const #b01) (i64.and (i64.const -29) x)))) + (falsey_test (lambda (x) (i64.eq (i64.const #b01) (i64.and (i64.const -29) x)))) + + (set_len_ptr (concat (local.set '$len (i32.wrap_i64 (i64.shr_u (local.get '$p) (i64.const 32)))) + (local.set '$ptr (i32.wrap_i64 (i64.and (local.get '$p) (i64.const -8)))) + )) + (ensure_not_op_n_params_set_ptr_len (lambda (op n) (concat set_len_ptr + (_if '$is_2_params + (op (local.get '$len) (i32.const n)) + (then + (call '$print (i64.const bad_params_number_msg_val)) + (unreachable) + ) + ) + ))) + (drop_p_d (concat + (call '$drop (local.get '$p)) + (call '$drop (local.get '$d)))) + + + + ((bad_not_vau_loc bad_not_vau_length datasi) (alloc_data "\nError: Trying to call a function (not vau) but the parameters caused a compile error\n" datasi)) + (bad_not_vau_msg_val (bor (<< bad_not_vau_length 32) bad_not_vau_loc #b011)) + + ((k_log_loc k_log_length datasi) (alloc_data "k_log" datasi)) + (k_log_msg_val (bor (<< k_log_length 32) k_log_loc #b011)) + ((k_log func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$log '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) + (call '$print (i64.const log_msg_val)) + (call '$print (local.get '$p)) + (call '$print (i64.const newline_msg_val)) + drop_p_d + (i64.const nil_val) + )))) + ((k_error_loc k_error_length datasi) (alloc_data "k_error" datasi)) + (k_error_msg_val (bor (<< k_error_length 32) k_error_loc #b011)) + ((k_error func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$error '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) + (call '$print (i64.const error_msg_val)) + (call '$print (local.get '$p)) + (call '$print (i64.const newline_msg_val)) + drop_p_d + (unreachable) + )))) + ((k_str_loc k_str_length datasi) (alloc_data "k_str" datasi)) + (k_str_msg_val (bor (<< k_str_length 32) k_str_loc #b011)) + ((k_str func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$str '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $buf i32) '(local $size i32) + (local.set '$buf (call '$malloc (local.tee '$size (call '$str_len (local.get '$p))))) + (drop (call '$str_helper (local.get '$p) (local.get '$buf))) + drop_p_d + (i64.or (i64.or (i64.shl (i64.extend_i32_u (local.get '$size)) (i64.const 32)) + (i64.extend_i32_u (local.get '$buf))) + (i64.const #b011)) + )))) + + (typecheck (dlambda (idx result_type op (mask value) then_branch else_branch) + (apply _if (concat (array '$matches) result_type + (array (op (i64.const value) (i64.and (i64.const mask) (i64.load (* 8 idx) (local.get '$ptr))))) + then_branch + else_branch + )) + )) + + (pred_func (lambda (name type_check) (func name '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $ptr i32) '(local $len i32) + (ensure_not_op_n_params_set_ptr_len i32.ne 1) + (typecheck 0 (array '(result i64)) + i64.eq type_check + (array (then (i64.const true_val))) + (array (else (i64.const false_val))) + ) + drop_p_d + ))) + + (type_assert (lambda (i type_check name_msg_val) + (typecheck i (array) + i64.ne type_check + (array (then + (call '$print (i64.const bad_params_type_msg_val)) + (call '$print (i64.const (<< i 1))) + (call '$print (i64.const space_msg_val)) + (call '$print (i64.const name_msg_val)) + (call '$print (i64.const space_msg_val)) + (call '$print (i64.load (* 8 i) (local.get '$ptr))) + (unreachable) + )) + nil + ) + )) + + (type_int (array #b1 #b0)) + (type_string (array #b111 #b011)) + (type_symbol (array #b111 #b111)) + (type_array (array #b111 #b101)) + (type_combiner (array #b1111 #b0001)) + (type_env (array #b11111 #b01001)) + (type_bool (array #b11111 #b11001)) + + ((k_nil_loc k_nil_length datasi) (alloc_data "k_nil" datasi)) + (k_nil_msg_val (bor (<< k_nil_length 32) k_nil_loc #b011)) + ((k_nil? func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (pred_func '$nil? (array -1 #x0000000000000005))))) + ((k_array_loc k_array_length datasi) (alloc_data "k_array" datasi)) + (k_array_msg_val (bor (<< k_array_length 32) k_array_loc #b011)) + ((k_array? func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (pred_func '$array? type_array)))) + ((k_bool_loc k_bool_length datasi) (alloc_data "k_bool" datasi)) + (k_bool_msg_val (bor (<< k_bool_length 32) k_bool_loc #b011)) + ((k_bool? func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (pred_func '$bool? type_bool)))) + ((k_env_loc k_env_length datasi) (alloc_data "k_env" datasi)) + (k_env_msg_val (bor (<< k_env_length 32) k_env_loc #b011)) + ((k_env? func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (pred_func '$env? type_env)))) + ((k_combiner_loc k_combiner_length datasi) (alloc_data "k_combiner" datasi)) + (k_combiner_msg_val (bor (<< k_combiner_length 32) k_combiner_loc #b011)) + ((k_combiner? func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (pred_func '$combiner type_combiner)))) + ((k_string_loc k_string_length datasi) (alloc_data "k_string" datasi)) + (k_string_msg_val (bor (<< k_string_length 32) k_string_loc #b011)) + ((k_string? func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (pred_func '$string? type_string)))) + ((k_int_loc k_int_length datasi) (alloc_data "k_int" datasi)) + (k_int_msg_val (bor (<< k_int_length 32) k_int_loc #b011)) + ((k_int? func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (pred_func '$int? type_int)))) + ((k_symbol_loc k_symbol_length datasi) (alloc_data "k_symbol" datasi)) + (k_symbol_msg_val (bor (<< k_symbol_length 32) k_symbol_loc #b011)) + ((k_symbol? func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (pred_func '$symbol? type_symbol)))) + + ((k_str_sym_comp func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$str_sym_comp '(param $a i64) '(param $b i64) '(param $lt_val i64) '(param $eq_val i64) '(param $gt_val i64) '(result i64) '(local $result i64) '(local $a_len i32) '(local $b_len i32) '(local $a_ptr i32) '(local $b_ptr i32) + (local.set '$result (local.get '$eq_val)) + (local.set '$a_len (i32.wrap_i64 (i64.shr_u (local.get '$a) (i64.const 32)))) + (local.set '$b_len (i32.wrap_i64 (i64.shr_u (local.get '$b) (i64.const 32)))) + (local.set '$a_ptr (i32.wrap_i64 (i64.and (local.get '$a) (i64.const #xFFFFFFF8)))) + (local.set '$b_ptr (i32.wrap_i64 (i64.and (local.get '$b) (i64.const #xFFFFFFF8)))) + (block '$b + (_if '$a_len_lt_b_len + (i32.lt_s (local.get '$a_len) (local.get '$b_len)) + (then (local.set '$result (local.get '$lt_val)) + (br '$b))) + (_if '$a_len_gt_b_len + (i32.gt_s (local.get '$a_len) (local.get '$b_len)) + (then (local.set '$result (local.get '$gt_val)) + (br '$b))) + + (_loop '$l + (br_if '$b (i32.eqz (local.get '$a_len))) + + (local.set '$a (i64.load8_u (local.get '$a_ptr))) + (local.set '$b (i64.load8_u (local.get '$b_ptr))) + + (_if '$a_lt_b + (i64.lt_s (local.get '$a) (local.get '$b)) + (then (local.set '$result (local.get '$lt_val)) + (br '$b))) + (_if '$a_gt_b + (i64.gt_s (local.get '$a) (local.get '$b)) + (then (local.set '$result (local.get '$gt_val)) + (br '$b))) + + (local.set '$a_len (i32.sub (local.get '$a_len) (i32.const 1))) + (local.set '$a_ptr (i32.add (local.get '$a_ptr) (i32.const 1))) + (local.set '$b_ptr (i32.add (local.get '$b_ptr) (i32.const 1))) + (br '$l) + ) + ) + (local.get '$result) + )))) + + ((k_comp_helper_helper func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$comp_helper_helper '(param $a i64) '(param $b i64) '(param $lt_val i64) '(param $eq_val i64) '(param $gt_val i64) '(result i64) '(local $result i64) '(local $a_tmp i32) '(local $b_tmp i32) '(local $a_ptr i32) '(local $b_ptr i32) '(local $result_tmp i64) + (block '$b + ;; INT + (_if '$a_int + (i64.eqz (i64.and (i64.const 1) (local.get '$a))) + (then + (_if '$b_int + (i64.eqz (i64.and (i64.const 1) (local.get '$b))) + (then + (_if '$a_lt_b + (i64.lt_s (local.get '$a) (local.get '$b)) + (then (local.set '$result (local.get '$lt_val)) + (br '$b))) + (_if '$a_gt_b + (i64.gt_s (local.get '$a) (local.get '$b)) + (then (local.set '$result (local.get '$gt_val)) + (br '$b))) + (local.set '$result (local.get '$eq_val)) + (br '$b) + ) + ) + ; Else, b is not an int, so a < b + (local.set '$result (local.get '$lt_val)) + (br '$b) + ) + ) + (_if '$b_int + (i64.eqz (i64.and (i64.const 1) (local.get '$b))) + (then + (local.set '$result (local.get '$gt_val)) + (br '$b)) + ) + ;; STRING + (_if '$a_string + (i64.eq (i64.const #b011) (i64.and (i64.const #b111) (local.get '$a))) + (then + (_if '$b_string + (i64.eq (i64.const #b011) (i64.and (i64.const #b111) (local.get '$b))) + (then + (local.set '$result (call '$str_sym_comp (local.get '$a) (local.get '$b) (local.get '$lt_val) (local.get '$eq_val) (local.get '$gt_val))) + (br '$b)) + ) + ; else b is not an int or string, so bigger + (local.set '$result (local.get '$lt_val)) + (br '$b) + ) + ) + (_if '$b_string + (i64.eq (i64.const #b011) (i64.and (i64.const #b111) (local.get '$b))) + (then + (local.set '$result (local.get '$gt_val)) + (br '$b)) + ) + ;; SYMBOL + (_if '$a_symbol + (i64.eq (i64.const #b111) (i64.and (i64.const #b111) (local.get '$a))) + (then + (_if '$b_symbol + (i64.eq (i64.const #b111) (i64.and (i64.const #b111) (local.get '$b))) + (then + (local.set '$result (call '$str_sym_comp (local.get '$a) (local.get '$b) (local.get '$lt_val) (local.get '$eq_val) (local.get '$gt_val))) + (br '$b)) + ) + ; else b is not an int or string or symbol, so bigger + (local.set '$result (local.get '$lt_val)) + (br '$b) + ) + ) + (_if '$b_symbol + (i64.eq (i64.const #b111) (i64.and (i64.const #b111) (local.get '$b))) + (then + (local.set '$result (local.get '$gt_val)) + (br '$b)) + ) + ;; ARRAY + (_if '$a_array + (i64.eq (i64.const #b101) (i64.and (i64.const #b111) (local.get '$a))) + (then + (_if '$b_array + (i64.eq (i64.const #b101) (i64.and (i64.const #b111) (local.get '$b))) + (then + (local.set '$a_tmp (i32.wrap_i64 (i64.shr_u (local.get '$a) (i64.const 32)))) + (local.set '$b_tmp (i32.wrap_i64 (i64.shr_u (local.get '$b) (i64.const 32)))) + + (_if '$a_len_lt_b_len + (i32.lt_s (local.get '$a_tmp) (local.get '$b_tmp)) + (then (local.set '$result (local.get '$lt_val)) + (br '$b))) + (_if '$a_len_gt_b_len + (i32.gt_s (local.get '$a_tmp) (local.get '$b_tmp)) + (then (local.set '$result (local.get '$gt_val)) + (br '$b))) + + (local.set '$a_ptr (i32.wrap_i64 (i64.and (local.get '$a) (i64.const #xFFFFFFF8)))) + (local.set '$b_ptr (i32.wrap_i64 (i64.and (local.get '$b) (i64.const #xFFFFFFF8)))) + + (_loop '$l + (br_if '$b (i32.eqz (local.get '$a_tmp))) + + (local.set '$result_tmp (call '$comp_helper_helper (i64.load (local.get '$a_ptr)) + (i64.load (local.get '$b_ptr)) + (i64.const -1) (i64.const 0) (i64.const 1))) + + (_if '$a_lt_b + (i64.eq (local.get '$result_tmp) (i64.const -1)) + (then (local.set '$result (local.get '$lt_val)) + (br '$b))) + (_if '$a_gt_b + (i64.eq (local.get '$result_tmp) (i64.const 1)) + (then (local.set '$result (local.get '$gt_val)) + (br '$b))) + + (local.set '$a_tmp (i32.sub (local.get '$a_tmp) (i32.const 1))) + (local.set '$a_ptr (i32.add (local.get '$a_ptr) (i32.const 8))) + (local.set '$b_ptr (i32.add (local.get '$b_ptr) (i32.const 8))) + (br '$l) + ) + (br '$b)) + ) + ; else b is not an int or string or symbol or array, so bigger + (local.set '$result (local.get '$lt_val)) + (br '$b) + ) + ) + (_if '$b_array + (i64.eq (i64.const #b111) (i64.and (i64.const #b111) (local.get '$b))) + (then + (local.set '$result (local.get '$gt_val)) + (br '$b)) + ) + ;; COMBINER + (_if '$a_comb + (i64.eq (i64.const #b0001) (i64.and (i64.const #b1111) (local.get '$a))) + (then + (_if '$b_comb + (i64.eq (i64.const #b0001) (i64.and (i64.const #b1111) (local.get '$b))) + (then + ; compare func indicies first + (local.set '$a_tmp (i32.wrap_i64 (i64.shr_u (local.get '$a) (i64.const 35)))) + (local.set '$b_tmp (i32.wrap_i64 (i64.shr_u (local.get '$b) (i64.const 35)))) + (_if '$a_tmp_lt_b_tmp + (i32.lt_s (local.get '$a_tmp) (local.get '$b_tmp)) + (then + (local.set '$result (local.get '$lt_val)) + (br '$b)) + ) + (_if '$a_tmp_eq_b_tmp + (i32.gt_s (local.get '$a_tmp) (local.get '$b_tmp)) + (then + (local.set '$result (local.get '$gt_val)) + (br '$b)) + ) + ; Idx was the same, so recursively comp envs + (local.set '$result (call '$comp_helper_helper (i64.or (i64.shl (i64.extend_i32_u (local.get '$a_tmp)) (i64.const 5)) (i64.const #b01001)) + (i64.or (i64.shl (i64.extend_i32_u (local.get '$b_tmp)) (i64.const 5)) (i64.const #b01001)) + (local.get '$lt_val) (local.get '$eq_val) (local.get '$gt_val))) + (br '$b)) + ) + ; else b is not an int or string or symbol or array or combiner, so bigger + (local.set '$result (local.get '$lt_val)) + (br '$b) + ) + ) + (_if '$b_comb + (i64.eq (i64.const #b0001) (i64.and (i64.const #b1111) (local.get '$b))) + (then + (local.set '$result (local.get '$gt_val)) + (br '$b)) + ) + ;; ENV + (_if '$a_env + (i64.eq (i64.const #b01001) (i64.and (i64.const #b11111) (local.get '$a))) + (then + (_if '$b_comb + (i64.eq (i64.const #b01001) (i64.and (i64.const #b11111) (local.get '$b))) + (then + (local.set '$a_ptr (i32.wrap_i64 (i64.shr_u (local.get '$a) (i64.const 5)))) + (local.set '$b_ptr (i32.wrap_i64 (i64.shr_u (local.get '$b) (i64.const 5)))) + + ; First, compare their symbol arrays + (local.set '$result_tmp (call '$comp_helper_helper (i64.load 0 (local.get '$a_ptr)) + (i64.load 0 (local.get '$b_ptr)) + (i64.const -1) (i64.const 0) (i64.const 1))) + (_if '$a_lt_b + (i64.eq (local.get '$result_tmp) (i64.const -1)) + (then (local.set '$result (local.get '$lt_val)) + (br '$b))) + (_if '$a_gt_b + (i64.eq (local.get '$result_tmp) (i64.const 1)) + (then (local.set '$result (local.get '$gt_val)) + (br '$b))) + + ; Second, compare their value arrays + (local.set '$result_tmp (call '$comp_helper_helper (i64.load 8 (local.get '$a_ptr)) + (i64.load 8 (local.get '$b_ptr)) + (i64.const -1) (i64.const 0) (i64.const 1))) + (_if '$a_lt_b + (i64.eq (local.get '$result_tmp) (i64.const -1)) + (then (local.set '$result (local.get '$lt_val)) + (br '$b))) + (_if '$a_gt_b + (i64.eq (local.get '$result_tmp) (i64.const 1)) + (then (local.set '$result (local.get '$gt_val)) + (br '$b))) + + ; Finally, just accept the result of recursion + (local.set '$result (call '$comp_helper_helper (i64.load 16 (local.get '$a_ptr)) + (i64.load 16 (local.get '$b_ptr)) + (local.get '$lt_val) (local.get '$eq_val) (local.get '$gt_val))) + + (br '$b)) + ) + ; else b is bool, so bigger + (local.set '$result (local.get '$lt_val)) + (br '$b) + ) + ) + (_if '$b_env + (i64.eq (i64.const #b01001) (i64.and (i64.const #b11111) (local.get '$b))) + (then + (local.set '$result (local.get '$gt_val)) + (br '$b)) + ) + ;; BOOL hehe + (_if '$a_lt_b + (i64.lt_s (local.get '$a) (local.get '$b)) + (then + (local.set '$result (local.get '$lt_val)) + (br '$b)) + ) + (_if '$a_eq_b + (i64.eq (local.get '$a) (local.get '$b)) + (then + (local.set '$result (local.get '$eq_val)) + (br '$b)) + ) + (local.set '$result (local.get '$gt_val)) + (br '$b) + ) + (local.get '$result) + )))) + + ((k_comp_helper func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$comp_helper '(param $p i64) '(param $d i64) '(param $s i64) '(param $lt_val i64) '(param $eq_val i64) '(param $gt_val i64) '(result i64) '(local $ptr i32) '(local $len i32) '(local $result i64) '(local $a i64) '(local $b i64) + set_len_ptr + (local.set '$result (i64.const true_val)) + (block '$b + (_loop '$l + (br_if '$b (i32.le_u (local.get '$len) (i32.const 1))) + (local.set '$a (i64.load (local.get '$ptr))) + (local.set '$ptr (i32.add (local.get '$ptr) (i32.const 8))) + (local.set '$b (i64.load (local.get '$ptr))) + (_if '$was_false + (i64.eq (i64.const false_val) (call '$comp_helper_helper (local.get '$a) (local.get '$b) (local.get '$lt_val) (local.get '$eq_val) (local.get '$gt_val))) + (then + (local.set '$result (i64.const false_val)) + (br '$b) + ) + ) + (local.set '$len (i32.sub (local.get '$len) (i32.const 1))) + (br '$l) + ) + ) + (local.get '$result) + drop_p_d + )))) + + ((k_eq_loc k_eq_length datasi) (alloc_data "k_eq" datasi)) + (k_eq_msg_val (bor (<< k_eq_length 32) k_eq_loc #b011)) + ((k_eq func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$eq '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) + (call '$comp_helper (local.get '$p) (local.get '$d) (local.get '$s) (i64.const false_val) (i64.const true_val) (i64.const false_val)) + )))) + ((k_neq_loc k_neq_length datasi) (alloc_data "k_neq" datasi)) + (k_neq_msg_val (bor (<< k_neq_length 32) k_neq_loc #b011)) + ((k_neq func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$neq '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) + (call '$comp_helper (local.get '$p) (local.get '$d) (local.get '$s) (i64.const true_val) (i64.const false_val) (i64.const true_val)) + )))) + ((k_geq_loc k_geq_length datasi) (alloc_data "k_geq" datasi)) + (k_geq_msg_val (bor (<< k_geq_length 32) k_geq_loc #b011)) + ((k_geq func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$geq '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) + (call '$comp_helper (local.get '$p) (local.get '$d) (local.get '$s) (i64.const false_val) (i64.const true_val) (i64.const true_val)) + )))) + ((k_gt_loc k_gt_length datasi) (alloc_data "k_gt" datasi)) + (k_gt_msg_val (bor (<< k_gt_length 32) k_gt_loc #b011)) + ((k_gt func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$gt '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) + (call '$comp_helper (local.get '$p) (local.get '$d) (local.get '$s) (i64.const false_val) (i64.const false_val) (i64.const true_val)) + )))) + ((k_leq_loc k_leq_length datasi) (alloc_data "k_leq" datasi)) + (k_leq_msg_val (bor (<< k_leq_length 32) k_leq_loc #b011)) + ((k_leq func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$leq '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) + (call '$comp_helper (local.get '$p) (local.get '$d) (local.get '$s) (i64.const true_val) (i64.const true_val) (i64.const false_val)) + )))) + ((k_lt_loc k_lt_length datasi) (alloc_data "k_lt" datasi)) + (k_lt_msg_val (bor (<< k_lt_length 32) k_lt_loc #b011)) + ((k_lt func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$lt '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) + (call '$comp_helper (local.get '$p) (local.get '$d) (local.get '$s) (i64.const true_val) (i64.const false_val) (i64.const false_val)) + )))) + + (math_function (lambda (name sensitive op) + (func name '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $ptr i32) '(local $len i32) '(local $i i32) '(local $cur i64) '(local $next i64) + (ensure_not_op_n_params_set_ptr_len i32.eq 0) + (local.set '$i (i32.const 1)) + (local.set '$cur (i64.load (local.get '$ptr))) + (_if '$not_num (i64.ne (i64.const 0) (i64.and (i64.const 1) (local.get '$cur))) + (then (unreachable)) + ) + (block '$b + (_loop '$l + (br_if '$b (i32.eq (local.get '$len) (local.get '$i))) + (local.set '$ptr (i32.add (i32.const 8) (local.get '$ptr))) + (local.set '$next (i64.load (local.get '$ptr))) + (_if '$not_num (i64.ne (i64.const 0) (i64.and (i64.const 1) (local.get '$next))) + (then (unreachable)) + ) + (local.set '$cur (if sensitive (i64.shl (op (i64.shr_s (local.get '$cur) (i64.const 1)) (i64.shr_s (local.get '$next) (i64.const 1))) (i64.const 1)) + (op (local.get '$cur) (local.get '$next)))) + (local.set '$i (i32.add (local.get '$i) (i32.const 1))) + (br '$l) + ) + ) + (local.get '$cur) + ) + )) + + ((k_mod_loc k_mod_length datasi) (alloc_data "k_mod" datasi)) + (k_mod_msg_val (bor (<< k_mod_length 32) k_mod_loc #b011)) + ((k_mod func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (math_function '$mod true i64.rem_s)))) + ((k_div_loc k_div_length datasi) (alloc_data "k_div" datasi)) + (k_div_msg_val (bor (<< k_div_length 32) k_div_loc #b011)) + ((k_div func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (math_function '$div true i64.div_s)))) + ((k_mul_loc k_mul_length datasi) (alloc_data "k_mul" datasi)) + (k_mul_msg_val (bor (<< k_mul_length 32) k_mul_loc #b011)) + ((k_mul func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (math_function '$mul true i64.mul)))) + ((k_sub_loc k_sub_length datasi) (alloc_data "k_sub" datasi)) + (k_sub_msg_val (bor (<< k_sub_length 32) k_sub_loc #b011)) + ((k_sub func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (math_function '$sub true i64.sub)))) + ((k_add_loc k_add_length datasi) (alloc_data "k_add" datasi)) + (k_add_msg_val (bor (<< k_add_length 32) k_add_loc #b011)) + ((k_add func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (math_function '$add false i64.add)))) + ((k_band_loc k_band_length datasi) (alloc_data "k_band" datasi)) + (k_band_msg_val (bor (<< k_band_length 32) k_band_loc #b011)) + ((k_band func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (math_function '$band false i64.and)))) + ((k_bor_loc k_bor_length datasi) (alloc_data "k_bor" datasi)) + (k_bor_msg_val (bor (<< k_bor_length 32) k_bor_loc #b011)) + ((k_bor func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (math_function '$bor false i64.or)))) + ((k_bxor_loc k_bxor_length datasi) (alloc_data "k_bxor" datasi)) + (k_bxor_msg_val (bor (<< k_bxor_length 32) k_bxor_loc #b011)) + ((k_bxor func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (math_function '$bxor false i64.xor)))) + + ((k_bnot_loc k_bnot_length datasi) (alloc_data "k_bnot" datasi)) + (k_bnot_msg_val (bor (<< k_bnot_length 32) k_bnot_loc #b011)) + ((k_bnot func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$bnot '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $ptr i32) '(local $len i32) + (ensure_not_op_n_params_set_ptr_len i32.ne 1) + (type_assert 0 type_int k_bnot_msg_val) + (i64.xor (i64.const -2) (i64.load (local.get '$ptr))) + drop_p_d + )))) + + ((k_ls_loc k_ls_length datasi) (alloc_data "k_ls" datasi)) + (k_ls_msg_val (bor (<< k_ls_length 32) k_ls_loc #b011)) + ((k_ls func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$ls '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $ptr i32) '(local $len i32) + (ensure_not_op_n_params_set_ptr_len i32.ne 2) + (type_assert 0 type_int k_ls_msg_val) + (type_assert 1 type_int k_ls_msg_val) + (i64.shl (i64.load 0 (local.get '$ptr)) (i64.shr_s (i64.load 8 (local.get '$ptr)) (i64.const 1))) + drop_p_d + )))) + ((k_rs_loc k_rs_length datasi) (alloc_data "k_rs" datasi)) + (k_rs_msg_val (bor (<< k_rs_length 32) k_rs_loc #b011)) + ((k_rs func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$rs '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $ptr i32) '(local $len i32) + (ensure_not_op_n_params_set_ptr_len i32.ne 2) + (type_assert 0 type_int k_rs_msg_val) + (type_assert 1 type_int k_rs_msg_val) + (i64.and (i64.const -2) (i64.shr_s (i64.load 0 (local.get '$ptr)) (i64.shr_s (i64.load 8 (local.get '$ptr)) (i64.const 1)))) + drop_p_d + )))) + + ((k_concat_loc k_concat_length datasi) (alloc_data "k_concat" datasi)) + (k_concat_msg_val (bor (<< k_concat_length 32) k_concat_loc #b011)) + ((k_concat func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$concat '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $ptr i32) '(local $len i32) '(local $size i32) '(local $i i32) '(local $it i64) '(local $new_ptr i32) '(local $inner_ptr i32) '(local $inner_size i32) '(local $new_ptr_traverse i32) + set_len_ptr + (local.set '$size (i32.const 0)) + (local.set '$i (i32.const 0)) + (block '$b + (_loop '$l + (br_if '$b (i32.eq (local.get '$len) (local.get '$i))) + (local.set '$it (i64.load (i32.add (i32.shl (local.get '$i) (i32.const 3)) (local.get '$ptr)))) + (_if '$not_array (i64.ne (i64.const #b101) (i64.and (i64.const #b111) (local.get '$it))) + (then (unreachable)) + ) + (local.set '$size (i32.add (local.get '$size) (i32.wrap_i64 (i64.shr_u (local.get '$it) (i64.const 32))))) + (local.set '$i (i32.add (local.get '$i) (i32.const 1))) + (br '$l) + ) + ) + (_if '$size_0 '(result i64) + (i32.eqz (local.get '$size)) + (then (i64.const nil_val)) + (else + (local.set '$new_ptr (call '$malloc (i32.shl (local.get '$size) (i32.const 3)))) ; malloc(size*8) + (local.set '$new_ptr_traverse (local.get '$new_ptr)) + + (local.set '$i (i32.const 0)) + (block '$exit_outer_loop + (_loop '$outer_loop + (br_if '$exit_outer_loop (i32.eq (local.get '$len) (local.get '$i))) + (local.set '$it (i64.load (i32.add (i32.shl (local.get '$i) (i32.const 3)) (local.get '$ptr)))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ; There's some serious optimization we could do here + ; Moving the items from the sub arrays to this one without + ; going through all the dup/drop + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (local.set '$inner_ptr (i32.wrap_i64 (i64.and (local.get '$it) (i64.const -8)))) + (local.set '$inner_size (i32.wrap_i64 (i64.shr_u (local.get '$it) (i64.const 32)))) + + (block '$exit_inner_loop + (_loop '$inner_loop + (br_if '$exit_inner_loop (i32.eqz (local.get '$inner_size))) + (i64.store (local.get '$new_ptr_traverse) + (call '$dup (i64.load (local.get '$inner_ptr)))) + (local.set '$inner_ptr (i32.add (local.get '$inner_ptr) (i32.const 8))) + (local.set '$new_ptr_traverse (i32.add (local.get '$new_ptr_traverse) (i32.const 8))) + (local.set '$inner_size (i32.sub (local.get '$inner_size) (i32.const 1))) + (br '$inner_loop) + ) + ) + (local.set '$i (i32.add (local.get '$i) (i32.const 1))) + (br '$outer_loop) + ) + ) + + (i64.or (i64.or (i64.extend_i32_u (local.get '$new_ptr)) (i64.const #x5)) + (i64.shl (i64.extend_i32_u (local.get '$size)) (i64.const 32))) + ) + ) + drop_p_d + )))) + ((k_slice_loc k_slice_length datasi) (alloc_data "k_slice" datasi)) + (k_slice_msg_val (bor (<< k_slice_length 32) k_slice_loc #b011)) + ((k_slice func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$slice '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $ptr i32) '(local $len i32) + (ensure_not_op_n_params_set_ptr_len i32.ne 3) + (type_assert 0 type_array k_slice_msg_val) + (type_assert 1 type_int k_slice_msg_val) + (type_assert 2 type_int k_slice_msg_val) + (call '$slice_impl (call '$dup (i64.load 0 (local.get '$ptr))) + (i32.wrap_i64 (i64.shr_s (i64.load 8 (local.get '$ptr)) (i64.const 1))) + (i32.wrap_i64 (i64.shr_s (i64.load 16 (local.get '$ptr)) (i64.const 1)))) + drop_p_d + )))) + ((k_idx_loc k_idx_length datasi) (alloc_data "k_idx" datasi)) + (k_idx_msg_val (bor (<< k_idx_length 32) k_idx_loc #b011)) + ((k_idx func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$idx '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $ptr i32) '(local $len i32) '(local $array i64) '(local $idx i32) '(local $size i32) + (ensure_not_op_n_params_set_ptr_len i32.ne 2) + (type_assert 0 type_array k_idx_msg_val) + (type_assert 1 type_int k_idx_msg_val) + (local.set '$array (i64.load 0 (local.get '$ptr))) + (local.set '$idx (i32.wrap_i64 (i64.shr_s (i64.load 8 (local.get '$ptr)) (i64.const 1)))) + (local.set '$size (i32.wrap_i64 (i64.shr_u (local.get '$array) (i64.const 32)))) + + (_if '$i_lt_0 (i32.lt_s (local.get '$idx) (i32.const 0)) (then (unreachable))) + (_if '$i_ge_s (i32.ge_s (local.get '$idx) (local.get '$size)) (then (unreachable))) + + (call '$dup (i64.load (i32.add (i32.wrap_i64 (i64.and (local.get '$array) (i64.const -8))) + (i32.shl (local.get '$idx) (i32.const 3))))) + drop_p_d + )))) + ((k_len_loc k_len_length datasi) (alloc_data "k_len" datasi)) + (k_len_msg_val (bor (<< k_len_length 32) k_len_loc #b011)) + ((k_len func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$len '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $ptr i32) '(local $len i32) + (ensure_not_op_n_params_set_ptr_len i32.ne 1) + (type_assert 0 type_array k_len_msg_val) + (i64.and (i64.shr_u (i64.load 0 (local.get '$ptr)) (i64.const 31)) (i64.const -2)) + drop_p_d + )))) + ((k_array_loc k_array_length datasi) (alloc_data "k_array" datasi)) + (k_array_msg_val (bor (<< k_array_length 32) k_array_loc #b011)) + ((k_array func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$array '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) + (local.get '$p) + (call '$drop (local.get '$d)) + ; s is 0 + )))) + + ((k_get_loc k_get_length datasi) (alloc_data "k_get" datasi)) + (k_get_msg_val (bor (<< k_get_length 32) k_get_loc #b011)) + ((k_get-text func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$get-text '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $ptr i32) '(local $len i32) + (ensure_not_op_n_params_set_ptr_len i32.ne 1) + (type_assert 0 type_symbol k_get_msg_val) + (call '$dup (i64.and (i64.const -5) (i64.load (local.get '$ptr)))) + drop_p_d + )))) + ((k_str_loc k_str_length datasi) (alloc_data "k_str" datasi)) + (k_str_msg_val (bor (<< k_str_length 32) k_str_loc #b011)) + ((k_str-to-symbol func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$str-to-symbol '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $ptr i32) '(local $len i32) + (ensure_not_op_n_params_set_ptr_len i32.ne 1) + (type_assert 0 type_string k_str_msg_val) + (call '$dup (i64.or (i64.const #b100) (i64.load (local.get '$ptr)))) + drop_p_d + )))) + + ((k_unwrap_loc k_unwrap_length datasi) (alloc_data "k_unwrap" datasi)) + (k_unwrap_msg_val (bor (<< k_unwrap_length 32) k_unwrap_loc #b011)) + ((k_unwrap func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$unwrap '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $ptr i32) '(local $len i32) '(local $comb i64) '(local $wrap_level i64) + (ensure_not_op_n_params_set_ptr_len i32.ne 1) + (type_assert 0 type_combiner k_unwrap_msg_val) + (local.set '$comb (i64.load (local.get '$ptr))) + (local.set '$wrap_level (i64.and (i64.shr_u (local.get '$comb) (i64.const 4)) (i64.const #b11))) + (_if '$wrap_level_0 + (i64.eqz (local.get '$wrap_level)) + (then (unreachable)) + ) + (call '$dup (i64.or (i64.and (local.get '$comb) (i64.const -49)) + (i64.shl (i64.sub (local.get '$wrap_level) (i64.const 1)) (i64.const 4)))) + drop_p_d + )))) + ((k_wrap_loc k_wrap_length datasi) (alloc_data "k_wrap" datasi)) + (k_wrap_msg_val (bor (<< k_wrap_length 32) k_wrap_loc #b011)) + ((k_wrap func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$wrap '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $ptr i32) '(local $len i32) '(local $comb i64) '(local $wrap_level i64) + (ensure_not_op_n_params_set_ptr_len i32.ne 1) + (type_assert 0 type_combiner k_wrap_msg_val) + (local.set '$comb (i64.load (local.get '$ptr))) + (local.set '$wrap_level (i64.and (i64.shr_u (local.get '$comb) (i64.const 4)) (i64.const #b11))) + (_if '$wrap_level_3 + (i64.eq (i64.const 3) (local.get '$wrap_level)) + (then (unreachable)) + ) + (call '$dup (i64.or (i64.and (local.get '$comb) (i64.const -49)) + (i64.shl (i64.add (local.get '$wrap_level) (i64.const 1)) (i64.const 4)))) + drop_p_d + )))) + + ((k_lapply_loc k_lapply_length datasi) (alloc_data "k_lapply" datasi)) + (k_lapply_msg_val (bor (<< k_lapply_length 32) k_lapply_loc #b011)) + ((k_lapply func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$lapply '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $ptr i32) '(local $len i32) '(local $comb i64) '(local $params i64) '(local $wrap_level i64) + (ensure_not_op_n_params_set_ptr_len i32.ne 2) + (type_assert 0 type_combiner k_lapply_msg_val) + (type_assert 1 type_array k_lapply_msg_val) + (local.set '$comb (call '$dup (i64.load 0 (local.get '$ptr)))) + (local.set '$params (call '$dup (i64.load 8 (local.get '$ptr)))) + (call '$drop (local.get '$d)) + (local.set '$wrap_level (i64.and (i64.shr_u (local.get '$comb) (i64.const 4)) (i64.const #b11))) + (_if '$wrap_level_ne_1 + (i64.ne (i64.const 1) (local.get '$wrap_level)) + (then (unreachable)) + ) + + (call_indirect + ;type + k_wrap + ;table + 0 + ;params + (local.get '$params) + ; pass through d env + (local.get '$d) + ; static env + (i64.or (i64.shl (i64.and (local.get '$comb) (i64.const #x3FFFFFFC0)) + (i64.const 2)) (i64.const #b01001)) + ;func_idx + (i32.wrap_i64 (i64.shr_u (local.get '$comb) (i64.const 35))) + ) + )))) + + ((k_vapply_loc k_vapply_length datasi) (alloc_data "k_vapply" datasi)) + (k_vapply_msg_val (bor (<< k_vapply_length 32) k_vapply_loc #b011)) + ((k_vapply func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$vapply '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $ptr i32) '(local $len i32) '(local $comb i64) '(local $params i64) '(local $wrap_level i64) '(local $denv i64) + (ensure_not_op_n_params_set_ptr_len i32.ne 3) + (type_assert 0 type_combiner k_vapply_msg_val) + (type_assert 1 type_array k_vapply_msg_val) + (type_assert 2 type_env k_vapply_msg_val) + (local.set '$comb (call '$dup (i64.load 0 (local.get '$ptr)))) + (local.set '$params (call '$dup (i64.load 8 (local.get '$ptr)))) + (local.set '$denv (call '$dup (i64.load 16 (local.get '$ptr)))) + drop_p_d + (local.set '$wrap_level (i64.and (i64.shr_u (local.get '$comb) (i64.const 4)) (i64.const #b11))) + (_if '$wrap_level_ne_0 + (i64.ne (i64.const 0) (local.get '$wrap_level)) + (then (unreachable)) + ) + + (call_indirect + ;type + k_wrap + ;table + 0 + ;params + (local.get '$params) + ; passed in denv, not our $d env + (local.get '$denv) + ; static env + (i64.or (i64.shl (i64.and (local.get '$comb) (i64.const #x3FFFFFFC0)) + (i64.const 2)) (i64.const #b01001)) + ;func_idx + (i32.wrap_i64 (i64.shr_u (local.get '$comb) (i64.const 35))) + ) + )))) + + ;true_val #b000111001 + ;false_val #b00001100) + (empty_parse_value #b00101100) + (close_peren_value #b01001100) + (error_parse_value #b01101100) + ; *GLOBAL ALERT* + ((k_parse_helper func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$parse_helper '(result i64) '(local $result i64) '(local $tmp i32) '(local $sub_result i64) '(local $asiz i32) '(local $acap i32) '(local $aptr i32) '(local $bptr i32) '(local $bcap i32) '(local $neg_multiplier i64) '(local $radix i64) + (block '$b1 + (block '$b2 + (_loop '$l + (br_if '$b2 (i32.eqz (global.get '$phl))) + (local.set '$tmp (i32.load8_u (global.get '$phs))) + (call '$print (i64.shl (i64.extend_i32_u (local.get '$tmp)) (i64.const 1))) + (_if '$whitespace (i32.or (i32.or (i32.eq (i32.const #x9) (local.get '$tmp)) ; tab + (i32.eq (i32.const #xA) (local.get '$tmp))) ; newline + (i32.or (i32.eq (i32.const #xD) (local.get '$tmp)) ; carrige return + (i32.eq (i32.const #x20) (local.get '$tmp)))) ; space + (then + (global.set '$phs (i32.add (global.get '$phs) (i32.const 1))) + (global.set '$phl (i32.sub (global.get '$phl) (i32.const 1))) + (br '$l) + ) + ) + (_if '$comment (i32.eq (i32.const #x3B) (local.get '$tmp)) + (then + (_loop '$li + (global.set '$phs (i32.add (global.get '$phs) (i32.const 1))) + (global.set '$phl (i32.sub (global.get '$phl) (i32.const 1))) + (br_if '$b2 (i32.eqz (global.get '$phl))) + (local.set '$tmp (i32.load8_u (global.get '$phs))) + (br_if '$li (i32.ne (i32.const #xA) (local.get '$tmp))) + ) + (br '$l) + ) + ) + ) + ) + (local.set '$result (i64.const empty_parse_value)) + (_if '$at_least1 + (i32.ge_u (global.get '$phl) (i32.const 1)) + (then + (local.set '$tmp (i32.load8_u (global.get '$phs))) + ; string + (_if '$is_open + (i32.eq (local.get '$tmp) (i32.const #x22)) + (then + (global.set '$phs (i32.add (global.get '$phs) (i32.const 1))) + (global.set '$phl (i32.sub (global.get '$phl) (i32.const 1))) + (local.set '$asiz (i32.const 0)) + (local.set '$bptr (global.get '$phs)) + + ; Count size + (block '$b2 + (_loop '$il + (_if '$doesnt_have_next + (i32.eqz (global.get '$phl)) + (then + (local.set '$result (i64.const error_parse_value)) + (br '$b1) + ) + ) + + (br_if '$b2 (i32.eq (i32.load8_u (global.get '$phs)) (i32.const #x22))) + + (_if '$an_escape + (i32.eq (i32.load8_u (global.get '$phs)) (i32.const #x5C)) + (then + (global.set '$phs (i32.add (global.get '$phs) (i32.const 1))) + (global.set '$phl (i32.sub (global.get '$phl) (i32.const 1))) + (_if '$doesnt_have_next + (i32.eqz (global.get '$phl)) + (then + (local.set '$result (i64.const error_parse_value)) + (br '$b1) + ) + ) + ) + ) + (local.set '$asiz (i32.add (local.get '$asiz) (i32.const 1))) + + (global.set '$phs (i32.add (global.get '$phs) (i32.const 1))) + (global.set '$phl (i32.sub (global.get '$phl) (i32.const 1))) + (br '$il) + ) + ) + + (global.set '$phs (i32.add (global.get '$phs) (i32.const 1))) + (global.set '$phl (i32.sub (global.get '$phl) (i32.const 1))) + + (local.set '$bcap (local.get '$asiz)) + (local.set '$aptr (call '$malloc (local.get '$asiz))) + + ; copy the bytes, implementing the escapes + (block '$b2 + (_loop '$il + (br_if '$b2 (i32.eqz (local.get '$bcap))) + + (_if '$an_escape + (i32.eq (i32.load8_u (local.get '$bptr)) (i32.const #x5C)) + (then + (_if '$escaped_slash + (i32.eq (i32.load8_u 1 (local.get '$bptr)) (i32.const #x5C)) + (then + (i32.store8 (local.get '$aptr) (i32.const #x5C)) + ) + (else + (_if '$escaped_quote + (i32.eq (i32.load8_u 1 (local.get '$bptr)) (i32.const #x22)) + (then + (i32.store8 (local.get '$aptr) (i32.const #x22)) + ) + (else + (_if '$escaped_newline + (i32.eq (i32.load8_u 1 (local.get '$bptr)) (i32.const #x6E)) + (then + (i32.store8 (local.get '$aptr) (i32.const #x0A)) + ) + (else + (_if '$escaped_tab + (i32.eq (i32.load8_u 1 (local.get '$bptr)) (i32.const #x74)) + (then + (i32.store8 (local.get '$aptr) (i32.const #x09)) + ) + (else + (global.set '$phl (i32.add (global.get '$phl) (i32.sub (global.get '$phs) (local.get '$bptr)))) + (global.set '$phs (local.get '$bptr)) + (local.set '$result (i64.const error_parse_value)) + (br '$b1) + ) + ) + ) + ) + ) + ) + ) + ) + (local.set '$bptr (i32.add (local.get '$bptr) (i32.const 2))) + ) + (else + (i32.store8 (local.get '$aptr) (i32.load8_u (local.get '$bptr))) + (local.set '$bptr (i32.add (local.get '$bptr) (i32.const 1))) + ) + ) + (local.set '$bcap (i32.sub (local.get '$bcap) (i32.const 1))) + (local.set '$aptr (i32.add (local.get '$aptr) (i32.const 1))) + (br '$il) + ) + ) + (local.set '$aptr (i32.sub (local.get '$aptr) (local.get '$asiz))) + (local.set '$result (i64.or (i64.or (i64.extend_i32_u (local.get '$aptr)) (i64.const #x3)) + (i64.shl (i64.extend_i32_u (local.get '$asiz)) (i64.const 32)))) + (br '$b1) + ) + ) + + ; negative int + (local.set '$neg_multiplier (i64.const 1)) + (_if '$is_dash_and_more + (i32.and (i32.eq (local.get '$tmp) (i32.const #x2D)) (i32.ge_u (global.get '$phl) (i32.const 2))) + (then + (_if '$next_is_letter + (i32.and (i32.ge_u (i32.load8_u 1 (global.get '$phs)) (i32.const #x30)) (i32.le_u (i32.load8_u 1 (global.get '$phs)) (i32.const #x39))) + (then + (global.set '$phs (i32.add (global.get '$phs) (i32.const 1))) + (global.set '$phl (i32.sub (global.get '$phl) (i32.const 1))) + (local.set '$tmp (i32.load8_u (global.get '$phs))) + (local.set '$neg_multiplier (i64.const -1)) + ) + ) + ) + ) + ; int + (local.set '$radix (i64.const 10)) + (_if '$is_zero_through_nine + (i32.and (i32.ge_u (local.get '$tmp) (i32.const #x30)) (i32.le_u (local.get '$tmp) (i32.const #x39))) + (then + (local.set '$result (i64.const 0)) + (_loop '$il + (_if '$is_zero_through_nine_inner + (i32.and (i32.ge_u (local.get '$tmp) (i32.const #x30)) (i32.le_u (local.get '$tmp) (i32.const #x39))) + (then + (local.set '$tmp (i32.sub (local.get '$tmp) (i32.const #x30))) + ) + (else + (local.set '$tmp (i32.sub (local.get '$tmp) (i32.const #x37))) + ) + ) + (local.set '$result (i64.add (i64.mul (local.get '$radix) (local.get '$result)) (i64.extend_i32_u (local.get '$tmp)))) + (global.set '$phs (i32.add (global.get '$phs) (i32.const 1))) + (global.set '$phl (i32.sub (global.get '$phl) (i32.const 1))) + (_if '$at_least1 + (i32.ge_u (global.get '$phl) (i32.const 1)) + (then + (local.set '$tmp (i32.load8_u (global.get '$phs))) + (_if '$is_hex_and_more + (i32.and (i32.eq (local.get '$tmp) (i32.const #x78)) (i32.ge_u (global.get '$phl) (i32.const 2))) + (then + (global.set '$phs (i32.add (global.get '$phs) (i32.const 1))) + (global.set '$phl (i32.sub (global.get '$phl) (i32.const 1))) + (local.set '$tmp (i32.load8_u (global.get '$phs))) + (local.set '$radix (i64.const 16)) + ) + (else + (_if '$is_hex_and_more + (i32.and (i32.eq (local.get '$tmp) (i32.const #x62)) (i32.ge_u (global.get '$phl) (i32.const 2))) + (then + (global.set '$phs (i32.add (global.get '$phs) (i32.const 1))) + (global.set '$phl (i32.sub (global.get '$phl) (i32.const 1))) + (local.set '$tmp (i32.load8_u (global.get '$phs))) + (local.set '$radix (i64.const 2)) + ) + ) + ) + ) + (br_if '$il (i32.or (i32.and (i32.ge_u (local.get '$tmp) (i32.const #x30)) (i32.le_u (local.get '$tmp) (i32.const #x39))) + (i32.and (i32.ge_u (local.get '$tmp) (i32.const #x41)) (i32.le_u (local.get '$tmp) (i32.const #x46))))) + ) + ) + ) + (local.set '$result (i64.shl (i64.mul (local.get '$neg_multiplier) (local.get '$result)) (i64.const 1))) + (br '$b1) + ) + ) + + ; []? + ; ' + (_if '$is_quote + (i32.eq (local.get '$tmp) (i32.const #x27)) + (then + (global.set '$phs (i32.add (global.get '$phs) (i32.const 1))) + (global.set '$phl (i32.sub (global.get '$phl) (i32.const 1))) + (local.set '$sub_result (call '$parse_helper)) + (_if '$ended + (i64.eq (i64.const close_peren_value) (local.get '$sub_result)) + (then + (local.set '$result (i64.const error_parse_value)) + (br '$b1) + ) + ) + (_if '$error + (i32.or (i64.eq (i64.const error_parse_value) (local.get '$sub_result)) + (i64.eq (i64.const empty_parse_value) (local.get '$sub_result))) + (then + (local.set '$result (local.get '$sub_result)) + (br '$b1) + ) + ) + (local.set '$result (call '$array2_alloc (i64.const quote_sym_val) (local.get '$sub_result))) + (br '$b1) + ) + ) + + ; symbol + (_if '$is_dash_and_more + ; 21 ! + ; 22 " X + ; 23-26 #-& + ; 27 ' X + ; 28-29 (-) X + ; 2A-2F *-/ + ; 30-39 0-9 / + ; 3A : + ; 3B ; + ; 3C-40 <-@ + ; 41-5A A-Z + ; 5B-60 [-` + ; 61-7A a-z + ; 7B-7E {-~ + (i32.or (i32.or (i32.eq (local.get '$tmp) (i32.const #x21)) + (i32.and (i32.ge_u (local.get '$tmp) (i32.const #x23)) (i32.le_u (local.get '$tmp) (i32.const #x26)))) + (i32.or (i32.and (i32.ge_u (local.get '$tmp) (i32.const #x2A)) (i32.le_u (local.get '$tmp) (i32.const #x2F))) + (i32.or (i32.eq (local.get '$tmp) (i32.const #x3A)) + (i32.and (i32.ge_u (local.get '$tmp) (i32.const #x3C)) (i32.le_u (local.get '$tmp) (i32.const #x7E)))))) + (then + (local.set '$asiz (i32.const 0)) + (local.set '$bptr (global.get '$phs)) + (block '$loop_break + (_loop '$il + (global.set '$phs (i32.add (global.get '$phs) (i32.const 1))) + (global.set '$phl (i32.sub (global.get '$phl) (i32.const 1))) + (local.set '$asiz (i32.add (local.get '$asiz) (i32.const 1))) + (_if '$doesnt_have_next + (i32.eqz (global.get '$phl)) + (then (br '$loop_break)) + ) + (local.set '$tmp (i32.load8_u (global.get '$phs))) + (br_if '$il (i32.or (i32.or (i32.eq (local.get '$tmp) (i32.const #x21)) + (i32.and (i32.ge_u (local.get '$tmp) (i32.const #x23)) (i32.le_u (local.get '$tmp) (i32.const #x26)))) + (i32.or (i32.and (i32.ge_u (local.get '$tmp) (i32.const #x2A)) (i32.le_u (local.get '$tmp) (i32.const #x3A))) + (i32.and (i32.ge_u (local.get '$tmp) (i32.const #x3C)) (i32.le_u (local.get '$tmp) (i32.const #x7E)))))) + ) + ) + (_if '$is_true1 + (i32.eq (local.get '$asiz) (i32.const 4)) + (then + (_if '$is_true2 + (i32.eq (i32.load (local.get '$bptr)) (i32.const #x65757274)) + (then + (local.set '$result (i64.const true_val)) + (br '$b1) + ) + ) + ) + ) + (_if '$is_false1 + (i32.eq (local.get '$asiz) (i32.const 5)) + (then + (_if '$is_false2 + (i32.and (i32.eq (i32.load (local.get '$bptr)) (i32.const #x736C6166)) (i32.eq (i32.load8_u 4 (local.get '$bptr)) (i32.const #x65))) + (then + (local.set '$result (i64.const false_val)) + (br '$b1) + ) + ) + ) + ) + (local.set '$aptr (call '$malloc (local.get '$asiz))) + (memory.copy (local.get '$aptr) + (local.get '$bptr) + (local.get '$asiz)) + (local.set '$result (i64.or (i64.or (i64.extend_i32_u (local.get '$aptr)) (i64.const #x7)) + (i64.shl (i64.extend_i32_u (local.get '$asiz)) (i64.const 32)))) + (br '$b1) + ) + ) + + ; lists (arrays)! + (_if '$is_open + (i32.eq (local.get '$tmp) (i32.const #x28)) + (then + (global.set '$phs (i32.add (global.get '$phs) (i32.const 1))) + (global.set '$phl (i32.sub (global.get '$phl) (i32.const 1))) + (local.set '$asiz (i32.const 0)) + (local.set '$acap (i32.const 4)) + (local.set '$aptr (call '$malloc (i32.const (* 4 8)))) + (_loop '$il + (local.set '$sub_result (call '$parse_helper)) + (_if '$ended + (i64.eq (i64.const close_peren_value) (local.get '$sub_result)) + (then + (_if '$nil + (i32.eqz (local.get '$asiz)) + (then + (call '$free (local.get '$aptr)) + (local.set '$result (i64.const nil_val)) + ) + (else + (local.set '$result (i64.or (i64.or (i64.extend_i32_u (local.get '$aptr)) (i64.const #x5)) + (i64.shl (i64.extend_i32_u (local.get '$asiz)) (i64.const 32)))) + ) + ) + (br '$b1) + ) + ) + (_if '$error + (i32.or (i64.eq (i64.const error_parse_value) (local.get '$sub_result)) + (i64.eq (i64.const empty_parse_value) (local.get '$sub_result))) + (then + (local.set '$result (local.get '$sub_result)) + (br '$b1) + ) + ) + (_if '$need_to_grow + (i32.eq (local.get '$asiz) (local.get '$acap)) + (then + (local.set '$bcap (i32.shl (local.get '$acap) (i32.const 1))) + (local.set '$bptr (call '$malloc (i32.shl (local.get '$bcap) (i32.const 3)))) + (local.set '$asiz (i32.const 0)) + (_loop '$iil + (i64.store (i32.add (local.get '$bptr) (i32.shl (local.get '$asiz) (i32.const 3))) + (i64.load (i32.add (local.get '$aptr) (i32.shl (local.get '$asiz) (i32.const 3))))) + (local.set '$asiz (i32.add (local.get '$asiz) (i32.const 1))) + (br_if '$iil (i32.lt_u (local.get '$asiz) (local.get '$acap))) + ) + (local.set '$acap (local.get '$bcap)) + (call '$free (local.get '$aptr)) + (local.set '$aptr (local.get '$bptr)) + ) + ) + (i64.store (i32.add (local.get '$aptr) (i32.shl (local.get '$asiz) (i32.const 3))) + (local.get '$sub_result)) + (local.set '$asiz (i32.add (local.get '$asiz) (i32.const 1))) + (br '$il) + ) + ) + ) + (_if '$is_close + (i32.eq (local.get '$tmp) (i32.const #x29)) + (then + (local.set '$result (i64.const close_peren_value)) + (global.set '$phs (i32.add (global.get '$phs) (i32.const 1))) + (global.set '$phl (i32.sub (global.get '$phl) (i32.const 1))) + (br '$b1) + ) + ) + ) + ) + ) + (local.get '$result) + )))) + ((k_read_loc k_read_length datasi) (alloc_data "k_read" datasi)) + (k_read_msg_val (bor (<< k_read_length 32) k_read_loc #b011)) + ((k_read-string func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$read-string '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $ptr i32) '(local $len i32) '(local $str i64) '(local $result i64) '(local $tmp_result i64) '(local $tmp_offset i32) + (ensure_not_op_n_params_set_ptr_len i32.ne 1) + (type_assert 0 type_string k_read_msg_val) + (local.set '$str (i64.load (local.get '$ptr))) + (call '$print (local.get '$str)) + (global.set '$phl (i32.wrap_i64 (i64.shr_u (local.get '$str) (i64.const 32)))) + (global.set '$phs (i32.wrap_i64 (i64.and (local.get '$str) (i64.const #xFFFFFFF8)))) + (local.set '$result (call '$parse_helper)) + (_if '$was_empty_parse + (i32.or (i64.eq (i64.const error_parse_value) (local.get '$result)) + (i32.or (i64.eq (i64.const empty_parse_value) (local.get '$result)) + (i64.eq (i64.const close_peren_value) (local.get '$result)))) + (then + (call '$print (i64.const couldnt_parse_1_msg_val)) + (call '$print (local.get '$str)) + (call '$print (i64.const couldnt_parse_2_msg_val)) + (call '$print (i64.shl (i64.add (i64.const 1) (i64.sub (i64.shr_u (local.get '$str) (i64.const 32)) (i64.extend_i32_u (global.get '$phl)))) (i64.const 1))) + (call '$print (i64.const newline_msg_val)) + (unreachable) + ) + ) + (_if '$remaining + (i32.ne (i32.const 0) (global.get '$phl)) + (then + (local.set '$tmp_offset (global.get '$phl)) + (local.set '$tmp_result (call '$parse_helper)) + (_if '$wasnt_empty_parse + (i64.ne (i64.const empty_parse_value) (local.get '$tmp_result)) + (then + (call '$print (i64.const parse_remaining_msg_val)) + (call '$print (i64.shl (i64.sub (i64.shr_u (local.get '$str) (i64.const 32)) (i64.extend_i32_u (local.get '$tmp_offset))) (i64.const 1))) + (call '$print (i64.const newline_msg_val)) + (unreachable) + ) + ) + ) + ) + (local.get '$result) + drop_p_d + )))) + ((k_eval_loc k_eval_length datasi) (alloc_data "k_eval" datasi)) + (k_eval_msg_val (bor (<< k_eval_length 32) k_eval_loc #b011)) + ((k_eval func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$eval '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) + + (call '$print (i64.const remaining_eval_msg_val)) + (unreachable) + )))) + ((k_vau_loc k_vau_length datasi) (alloc_data "k_vau" datasi)) + (k_vau_msg_val (bor (<< k_vau_length 32) k_vau_loc #b011)) + ((k_vau func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$vau '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) + (call '$print (i64.const remaining_vau_msg_val)) + (unreachable) + )))) + ((k_cond_loc k_cond_length datasi) (alloc_data "k_cond" datasi)) + (k_cond_msg_val (bor (<< k_cond_length 32) k_cond_loc #b011)) + ((k_cond func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$cond '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) + (call '$print (i64.const remaining_cond_msg_val)) + (unreachable) + )))) + + (get_passthrough (dlambda (hash (datasi funcs memo env pectx)) (let ((r (get-value-or-false memo hash))) + (if r (array r nil nil (array datasi funcs memo env pectx)) #f)))) + + ; This is the second run at this, and is a little interesting + ; It can return a value OR code OR an error string. An error string should be propegated, + ; unless it was expected as a possiblity, which can happen when compling a call that may or + ; may not be a Vau. When it recurses, if the thing you're currently compiling could be a value + ; but your recursive calls return code, you will likely have to swap back to code. + + ; ctx is (datasi funcs memo env pectx) + ; return is (value? code? error? (datasi funcs memo env pectx)) + (compile-inner (rec-lambda compile-inner (ctx c need_value) (cond + ((val? c) (let ((v (.val c))) + (cond ((int? v) (array (<< v 1) nil nil ctx)) + ((= true v) (array true_val nil nil ctx)) + ((= false v) (array false_val nil nil ctx)) + ((str? v) (or (get_passthrough (.hash c) ctx) + (dlet ( ((datasi funcs memo env pectx) ctx) + ((c_loc c_len datasi) (alloc_data v datasi)) + (a (bor (<< c_len 32) c_loc #b011)) + (memo (put memo (.hash c) a)) + ) (array a nil nil (array datasi funcs memo env pectx))))) + (true (error (str "Can't compile impossible value " v)))))) + ((marked_symbol? c) (cond ((.marked_symbol_is_val c) (or ;(begin (print "pre get_passthrough " (.hash c) "ctx is " ctx ) + (get_passthrough (.hash c) ctx) + ;) + (dlet ( ((datasi funcs memo env pectx) ctx) + ((c_loc c_len datasi) (alloc_data (symbol->string (.marked_symbol_value c)) datasi)) + (result (bor (<< c_len 32) c_loc #b111)) + (memo (put memo (.hash c) result)) + ) (array result nil nil (array datasi funcs memo env pectx))))) + + + + (true (dlet ( ((datasi funcs memo env pectx) ctx) + ; not a recoverable error, so just do here + (_ (if (= nil env) (error "nil env when trying to compile a non-value symbol"))) + (lookup_helper (rec-lambda lookup-recurse (dict key i code) (cond + ((and (= i (- (len dict) 1)) (= nil (idx dict i))) (array nil (str "for code-symbol lookup, couldn't find " key))) + ((= i (- (len dict) 1)) (lookup-recurse (.env_marked (idx dict i)) key 0 (i64.load 16 (i32.wrap_i64 (i64.shr_u code (call '$print (i64.const going_up_msg_val)) (i64.const 5)))))) + ((= key (idx (idx dict i) 0)) (array (i64.load (* 8 i) ; offset in array to value + (i32.wrap_i64 (i64.and (i64.const -8) ; get ptr from array value + (i64.load 8 (i32.wrap_i64 (i64.shr_u code + (i64.const 5)) (call '$print (i64.const got_it_msg_val)) ))))) nil)) + (true (lookup-recurse dict key (+ i 1) code))))) + + + ((val err) (lookup_helper (.env_marked env) (.marked_symbol_value c) 0 (concat + (call '$print (i64.const starting_from_msg_val)) + (call '$print (local.get '$s_env)) + (local.get '$s_env)))) + (err (mif err (str "got " err ", started searching in " (str_strip env)) (if need_value (str "needed value, but non val symbol " (.marked_symbol_value c)) nil))) + (result (mif val (call '$dup val))) + ) (array nil result err (array datasi funcs memo env pectx)))))) + ((marked_array? c) (if (.marked_array_is_val c) (or (get_passthrough (.hash c) ctx) + (let ((actual_len (len (.marked_array_values c)))) + (if (= 0 actual_len) (array nil_val nil nil ctx) + (dlet (((comp_values err ctx) (foldr (dlambda (x (a err ctx)) (dlet (((v c e ctx) (compile-inner ctx x need_value))) + (array (cons v a) (or (mif err err false) (mif e e false) (mif c (str "got code " c) false)) ctx))) (array (array) nil ctx) (.marked_array_values c))) + ) (mif err (array nil nil (str err ", from an array value compile " (str_strip c)) ctx) (dlet ( + ((datasi funcs memo env pectx) ctx) + ((c_loc c_len datasi) (alloc_data (apply concat (map i64_le_hexify comp_values)) datasi)) + (result (bor (<< actual_len 32) c_loc #b101)) + (memo (put memo (.hash c) result)) + ) (array result nil nil (array datasi funcs memo env pectx)))))))) + + (if need_value (array nil nil (str "errr, needed value and was call " (str_strip c)) ctx) + (if (= 0 (len (.marked_array_values c))) (array nil nil (str "errr, empty call array" (str_strip c)) ctx) + (dlet ( + + ; This can weirdly cause infinate recursion on the compile side, if partial_eval + ; returns something that, when compiled, will cause partial eval to return that thing again. + ; Partial eval won't recurse infinately, since it has memo, but it can return something of that + ; shape in that case which will cause compile to keep stepping. + + ((datasi funcs memo env pectx) ctx) + (hit_recursion (= 'RECURSE_FAIL (get-value-or-false memo (.hash c)))) + + (compile_params (lambda (unval_and_eval ctx params) + (foldr (dlambda (x (a err ctx)) (dlet ( + + ((datasi funcs memo env pectx) ctx) + ((x err ctx) (mif err (array nil err ctx) + (if (not unval_and_eval) (array x err ctx) + (dlet ( + ((ok x) (try_unval x (lambda (_) nil))) + (err (if (not ok) "couldn't unval in compile" err)) + + ; TODO: This might fail because we don't have the real env stack, which we *should*! + ; In the mean time, if it does, just fall back to the non-more-evaled ones. + ((pectx e pex) (if (or (!= nil err) hit_recursion) + (array pectx err nil) + (partial_eval_helper x false env (array) pectx 1 false))) + + (ctx (array datasi funcs memo env pectx)) + + ) (array (mif e x pex) err ctx))))) + ((datasi funcs memo env pectx) ctx) + (memo (put memo (.hash c) 'RECURSE_FAIL)) + (ctx (array datasi funcs memo env pectx)) + ((val code err ctx) (mif err (array nil nil err ctx) + (compile-inner ctx x false))) + ((datasi funcs memo env pectx) ctx) + (memo (put memo (.hash c) 'RECURSE_OK)) + (ctx (array datasi funcs memo env pectx)) + ) (array (cons (mif val (i64.const val) code) a) err ctx))) + + (array (array) nil ctx) params))) + + (func_param_values (.marked_array_values c)) + (num_params (- (len func_param_values) 1)) + (params (slice func_param_values 1 -1)) + (func_value (idx func_param_values 0)) + ((param_codes err ctx) (compile_params false ctx params)) + + (wrap_level (if (or (comb? func_value) (prim_comb? func_value)) (.any_comb_wrap_level func_value) nil)) + ; I don't think it makes any sense for a function literal to have wrap > 0 + (_ (if (and (!= nil wrap_level) (> wrap_level 0)) (error "call to function literal has wrap >0"))) + + ;; Insert test for the function being a constant to inline + ;; Namely, vcond + ) (cond + ((!= nil err) (array nil nil (str err " from function params (non-unval-evaled) in call " (str_strip c)) ctx)) + ((and (prim_comb? func_value) (= (.prim_comb_sym func_value) 'vcond)) + (mif err (array nil nil (str err " from function params in call to comb " (str_strip c)) ctx) + (dlet ( + ((datasi funcs memo env pectx) ctx) + ) (array nil ((rec-lambda recurse (codes i) (cond + ((< i (- (len codes) 1)) (_if '_cond_flat '(result i64) + (truthy_test (idx codes i)) + (then (idx codes (+ i 1))) + (else (recurse codes (+ i 2))) + )) + ((= i (- (len codes) 1)) (error "compiling bad length comb")) + (true (unreachable)) + )) param_codes 0) err ctx)))) + (true (dlet ( + ((func_val func_code func_err ctx) (compile-inner ctx func_value false)) + ;(_ (print_strip "func val " func_val " func code " func_code " func err " func_err " param_codes " param_codes " err " err " from " func_value)) + (func_code (mif func_val (i64.const func_val) func_code)) + ((unval_param_codes err ctx) (compile_params true ctx params)) + ((bad_unval_params_msg_val _ _ ctx) (compile-inner ctx (marked_val (str "error was with unval-evaling parameters of " (str_strip c))) true)) + (result_code (concat + func_code + (local.set '$tmp) + (_if '$is_wrap_0 + (i64.eq (i64.const #x00) (i64.and (local.get '$tmp) (i64.const #x30))) + (then + (local.get '$tmp) ; saving ito restore it + (apply concat param_codes) + (local.set '$param_ptr (call '$malloc (i32.const (* 8 num_params)))) + (flat_map (lambda (i) (i64.store (* i 8) (local.set '$tmp) (local.get '$param_ptr) (local.get '$tmp))) + (range (- num_params 1) -1)) + (local.set '$tmp) ; restoring tmp + ) + (else + (_if '$is_wrap_1 + (i64.eq (i64.const #x10) (i64.and (local.get '$tmp) (i64.const #x30))) + (then + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ; Since we're not sure if it's going to be a vau or not, + ; this code might not be compilable, so we gracefully handle + ; compiler errors and instead emit code that throws the error if this + ; spot is ever reached at runtime. + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (mif err (concat (call '$print (i64.const bad_not_vau_msg_val)) + (call '$print (i64.const bad_unval_params_msg_val)) + (unreachable)) + (concat + (local.get '$tmp) ; saving ito restore it + (apply concat unval_param_codes) + (local.set '$param_ptr (call '$malloc (i32.const (* 8 num_params)))) + (flat_map (lambda (i) (i64.store (* i 8) (local.set '$tmp) (local.get '$param_ptr) (local.get '$tmp))) + (range (- num_params 1) -1)) + (local.set '$tmp) ; restoring tmp + )) + ) + (else + ; TODO: Handle other wrap levels + (call '$print (i64.const weird_wrap_msg_val)) + (unreachable) + ) + ) + ) + ) + (call_indirect + ;type + k_vau + ;table + 0 + ;params + (i64.or (i64.extend_i32_u (local.get '$param_ptr)) + (i64.const (bor (<< num_params 32) #x5))) + ;dynamic env (is caller's static env) + (call '$dup (local.get '$s_env)) + ; static env + (i64.or (i64.shl (i64.and (local.get '$tmp) (i64.const #x3FFFFFFC0)) + (i64.const 2)) (i64.const #b01001)) + ;func_idx + (i32.wrap_i64 (i64.shr_u (local.get '$tmp) (i64.const 35))) + ))) + ) (array nil result_code func_err ctx))) + )))))) + + ((marked_env? c) (or (get_passthrough (.hash c) ctx) (dlet ((e (.env_marked c)) + + (generate_env_access (dlambda ((datasi funcs memo env pectx) env_id reason) ((rec-lambda recurse (code this_env) + (cond + ((= env_id (.marked_env_idx this_env)) (array nil (call '$dup code) nil (array datasi funcs memo env pectx))) + ((= nil (.marked_env_upper this_env)) (array nil nil (str "bad env, upper is nil and we haven't found " env_id ", (this is *possiblely* because we're not recreating val/notval chains?) maxing out at " (str_strip this_env) ", having started at " (str_strip env) ", we're generating because " reason) (array datasi funcs memo env pectx))) + (true (recurse (i64.load 16 (i32.wrap_i64 (i64.shr_u code (i64.const 5)))) + (.marked_env_upper this_env))) + ) + ) (local.get '$s_env) env))) + + ) (if (not (marked_env_real? c)) (begin (print_strip "env wasn't real: " (marked_env_real? c) ", so generating access (env was) " c) (if need_value (array nil nil (str "marked env not real, though we need_value: " (str_strip c)) ctx) (generate_env_access ctx (.marked_env_idx c) "it wasn't real: " (str_strip c)))) + (dlet ( + + + ((kvs vvs ctx) (foldr (dlambda ((k v) (ka va ctx)) (dlet (((kv _ _ ctx) (compile-inner ctx (marked_symbol nil k) true)) + ((vv code err ctx) (compile-inner ctx v need_value)) + ;(_ (print_strip "result of (kv is " kv ") v compile-inner vv " vv " code " code " err " err ", based on " v)) + ;(_ (if (= nil vv) (print_strip "VAL NIL CODE IN ENV B/C " k " = " v) nil)) + ;(_ (if (!= nil err) (print_strip "ERRR IN ENV B/C " err " " k " = " v) nil)) + ) + (if (= false ka) (array false va ctx) + (if (or (= nil vv) (!= nil err)) (array false (str "vv was " vv " err is " err " and we needed_value? " need_value " based on v " (str_strip v)) ctx) + (array (cons kv ka) (cons vv va) ctx))))) + (array (array) (array) ctx) + (slice e 0 -2))) + + ((uv ucode err ctx) (mif (idx e -1) (compile-inner ctx (idx e -1) need_value) + (array nil_val nil nil ctx))) + ) (mif (or (= false kvs) (= nil uv) (!= nil err)) (begin (print_strip "kvs " kvs " vvs " vvs " uv " uv " or err " err " based off of " c) (if need_value (array nil nil (str "had to generate env access (course " need_value ") for " (str_strip c) "vvs is " vvs " err was " err) ctx) (generate_env_access ctx (.marked_env_idx c) (str " vvs " vvs " uv " uv " or err " err " based off of " (str_strip c))))) + (dlet ( + ((datasi funcs memo env pectx) ctx) + ((kvs_array datasi) (if (= 0 (len kvs)) (array nil_val datasi) + (dlet (((kvs_loc kvs_len datasi) (alloc_data (apply concat (map i64_le_hexify kvs)) datasi))) + (array (bor (<< (len kvs) 32) kvs_loc #b101) datasi)))) + ((vvs_array datasi) (if (= 0 (len vvs)) (array nil_val datasi) + (dlet (((vvs_loc vvs_len datasi) (alloc_data (apply concat (map i64_le_hexify vvs)) datasi))) + (array (bor (<< (len vvs) 32) vvs_loc #b101) datasi)))) + (all_hex (map i64_le_hexify (array kvs_array vvs_array uv))) + ((c_loc c_len datasi) (alloc_data (apply concat all_hex) datasi)) + (result (bor (<< c_loc 5) #b01001)) + (memo (put memo (.hash c) result)) + ) (array result nil nil (array datasi funcs memo env pectx))))))))) + + ((prim_comb? c) (cond ((= 'vau (.prim_comb_sym c)) (array (bor (<< (- k_vau dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) + ((= 'cond (.prim_comb_sym c)) (array (bor (<< (- k_cond dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) + ((= 'eval (.prim_comb_sym c)) (array (bor (<< (- k_eval dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) + ((= 'read-string (.prim_comb_sym c)) (array (bor (<< (- k_read-string dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) + ((= 'log (.prim_comb_sym c)) (array (bor (<< (- k_log dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) + ((= 'error (.prim_comb_sym c)) (array (bor (<< (- k_error dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) + ((= 'str (.prim_comb_sym c)) (array (bor (<< (- k_str dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) + ((= '>= (.prim_comb_sym c)) (array (bor (<< (- k_geq dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) + ((= '> (.prim_comb_sym c)) (array (bor (<< (- k_gt dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) + ((= '<= (.prim_comb_sym c)) (array (bor (<< (- k_leq dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) + ((= '< (.prim_comb_sym c)) (array (bor (<< (- k_lt dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) + ((= '!= (.prim_comb_sym c)) (array (bor (<< (- k_neq dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) + ((= '= (.prim_comb_sym c)) (array (bor (<< (- k_eq dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) + ((= '% (.prim_comb_sym c)) (array (bor (<< (- k_mod dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) + ((= '/ (.prim_comb_sym c)) (array (bor (<< (- k_div dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) + ((= '* (.prim_comb_sym c)) (array (bor (<< (- k_mul dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) + ((= '+ (.prim_comb_sym c)) (array (bor (<< (- k_add dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) + ((= '- (.prim_comb_sym c)) (array (bor (<< (- k_sub dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) + ((= 'band (.prim_comb_sym c)) (array (bor (<< (- k_band dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) + ((= 'bor (.prim_comb_sym c)) (array (bor (<< (- k_bor dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) + ((= 'bxor (.prim_comb_sym c)) (array (bor (<< (- k_bxor dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) + ((= 'bnot (.prim_comb_sym c)) (array (bor (<< (- k_bnot dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) + ((= '<< (.prim_comb_sym c)) (array (bor (<< (- k_ls dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) + ((= '>> (.prim_comb_sym c)) (array (bor (<< (- k_rs dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) + ((= 'array (.prim_comb_sym c)) (array (bor (<< (- k_array dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) + ((= 'concat (.prim_comb_sym c)) (array (bor (<< (- k_concat dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) + ((= 'slice (.prim_comb_sym c)) (array (bor (<< (- k_slice dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) + ((= 'idx (.prim_comb_sym c)) (array (bor (<< (- k_idx dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) + ((= 'len (.prim_comb_sym c)) (array (bor (<< (- k_len dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) + ((= 'array? (.prim_comb_sym c)) (array (bor (<< (- k_array? dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) + ((= 'get-text (.prim_comb_sym c)) (array (bor (<< (- k_get-text dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) + ((= 'str-to-symbol (.prim_comb_sym c)) (array (bor (<< (- k_str-to-symbol dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) + ((= 'bool? (.prim_comb_sym c)) (array (bor (<< (- k_bool? dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) + ((= 'nil? (.prim_comb_sym c)) (array (bor (<< (- k_nil? dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) + ((= 'env? (.prim_comb_sym c)) (array (bor (<< (- k_env? dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) + ((= 'combiner? (.prim_comb_sym c)) (array (bor (<< (- k_combiner? dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) + ((= 'string? (.prim_comb_sym c)) (array (bor (<< (- k_string? dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) + ((= 'int? (.prim_comb_sym c)) (array (bor (<< (- k_int? dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) + ((= 'symbol? (.prim_comb_sym c)) (array (bor (<< (- k_symbol? dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) + ((= 'unwrap (.prim_comb_sym c)) (array (bor (<< (- k_unwrap dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) + ((= 'vapply (.prim_comb_sym c)) (array (bor (<< (- k_vapply dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) + ((= 'lapply (.prim_comb_sym c)) (array (bor (<< (- k_lapply dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) + ((= 'wrap (.prim_comb_sym c)) (array (bor (<< (- k_wrap dyn_start) 35) (<< (.prim_comb_wrap_level c) 4) #b0001) nil nil ctx)) + (true (error (str "Can't compile prim comb " (.prim_comb_sym c) " right now"))))) + + + + + ((comb? c) (dlet ( + (maybe_func (get_passthrough (.hash c) ctx)) + ((func_value _ func_err ctx) (mif maybe_func maybe_func + (dlet ( + ((wrap_level env_id de? se variadic params body) (.comb c)) + ((name_msg_value _ _ ctx) (compile-inner ctx (marked_val (str "\n\ncalling function " (true_str_strip c) " with: ")) true)) + + ; This can be optimized for common cases, esp with no de? and varidaic to make it much faster + ; But not prematurely, I just had to redo it after doing that the first time, we'll get there when we get there + (inner_env (make_tmp_inner_env params de? se env_id)) + (full_params (concat params (mif de? (array de?) (array)))) + (normal_params_length (if variadic (- (len params) 1) (len params))) + ((params_vec _ _ ctx) (compile-inner ctx (marked_array true false nil (map (lambda (k) (marked_symbol nil k)) full_params)) true)) + (env_setup_code (concat + + (local.set '$s_env (call '$env_alloc (i64.const params_vec) + + (local.set '$param_ptr (i32.wrap_i64 (i64.and (i64.const -8) (local.get '$params)))) + (local.set '$tmp_ptr (call '$malloc (i32.const (* 8 (len full_params))))) + (flat_map (lambda (i) (i64.store (* i 8) (local.get '$tmp_ptr) (call '$dup (i64.load (* i 8) (local.get '$param_ptr))))) + (range 0 normal_params_length)) + (if variadic + (i64.store (* 8 normal_params_length) (local.get '$tmp_ptr) + (call '$slice_impl (local.get '$params) (i32.const (- (len params) 1)) (i32.const -1))) + (call '$drop (local.get '$params))) + (mif de? + (i64.store (* 8 (- (len full_params) 1)) (local.get '$tmp_ptr) (local.get '$d_env)) + (call '$drop (local.get '$d_env))) + (i64.or (i64.extend_i32_u (local.get '$tmp_ptr)) + (i64.const (bor (<< (len full_params) 32) #x5))) + + (local.get '$s_env))) + + )) + + (setup_code (concat + (call '$print (i64.const name_msg_value)) + (call '$print (local.get '$params)) + (call '$print (i64.const space_msg_val)) + (call '$print (i64.shl (i64.shr_u (local.get '$params) (i64.const 32)) (i64.const 1))) + (call '$print (i64.const space_msg_val)) + (call '$print (i64.const (<< (len params) 1))) + (call '$print (i64.const newline_msg_val)) + (call '$print (i64.const newline_msg_val)) + (_if '$params_len_good + (if variadic (i64.lt_u (i64.shr_u (local.get '$params) (i64.const 32)) (i64.const (- (len params) 1))) + (i64.ne (i64.shr_u (local.get '$params) (i64.const 32)) (i64.const (len params)))) + (then + (call '$drop (local.get '$params)) + (call '$drop (local.get '$s_env)) + (call '$drop (local.get '$d_env)) + (call '$print (i64.const bad_params_number_msg_val)) + (unreachable) + ) + (else + (call '$print (i64.const call_ok_msg_val)) + (call '$print (i64.const newline_msg_val)) + ;(call '$print (local.get '$s_env)) + (call '$print (i64.const newline_msg_val)) + ) + ) env_setup_code + )) + + ((datasi funcs memo env pectx) ctx) + ((inner_value inner_code err ctx) (compile-inner (array datasi funcs memo inner_env pectx) body false)) + ; Don't overwrite env with what was our inner env! Env is returned as part of context to our caller! + ((datasi funcs memo _was_inner_env pectx) ctx) + ;(_ (print_strip "inner_value for maybe const is " inner_value " inner_code is " inner_code " err is " err " this was for " body)) + (inner_code (mif inner_value (i64.const inner_value) inner_code)) + (end_code (call '$drop (local.get '$s_env))) + (our_func (func '$len '(param $params i64) '(param $d_env i64) '(param $s_env i64) '(result i64) '(local $param_ptr i32) '(local $tmp_ptr i32) '(local $tmp i64) + (concat setup_code inner_code end_code) + )) + (funcs (concat funcs our_func)) + (our_func_idx (+ (- (len funcs) dyn_start) (- num_pre_functions 1))) + (func_value (bor (<< our_func_idx 35) (<< wrap_level 4) #b0001)) + (memo (put memo (.hash c) func_value)) + (_ (print_strip "the hash " (.hash c) " with value " func_value " corresponds to " c)) + + ) (array func_value nil err (array datasi funcs memo env pectx))) + )) + (_ (print_strip "returning " func_value " for " c)) + (_ (if (not (int? func_value)) (error "BADBADBADfunc"))) + + ((wrap_level env_id de? se variadic params body) (.comb c)) + ; I belive this env_code should actually re-create the actual env chain (IN THE ENV COMPILING CODE, NOT HERE) + ; It might not just be s_env, because we might have been partially-evaled and returned + ; from a deeper call and have some real env frames before we run into what is currently + ; s_env. Additionally, this changes depending on where this value currently is, though + ; I think as of right now you can only have an incomplete-chain-closure once, since it + ; would never count as a value it could never be moved into another function etc. + ; ON THE OTHER HAND - perhaps two (textually) identical lambdas could? + ; Also, if we go for value lambda than we should't be compiling with the + ; current actual stack... (we really need to change the compile-time stacks to be + ; identical / mostly get rid of them all together) + ((env_val env_code env_err ctx) (if (and need_value (not (marked_env_real? se))) + (array nil nil "Env wasn't real when compiling comb, but need value" ctx) + (compile-inner ctx se need_value))) + (_ (print_strip "result of compiling env for comb is val " env_val " code " env_code " err " env_err " and it was real? " (marked_env_real? se) " based off of env " se)) + (_ (if (not (or (= nil env_val) (int? env_val))) (error "BADBADBADenv_val"))) + ; |0001 + ; e29><2><4> = 6 + ; 0..0<3 bits>01001 + ; e29><3><5> = 8 + ; 0..001001 + ; x+2+4 = y + 3 + 5 + ; x + 6 = y + 8 + ; x - 2 = y + ) (mif env_val (array (bor (band #x7FFFFFFC0 (>> env_val 2)) func_value) nil (mif func_err (str func_err ", from compiling comb body") (mif env_err (str env_err ", from compiling comb env") nil)) ctx) + (array nil (i64.or (i64.const func_value) (i64.and (i64.const #x7FFFFFFC0) (i64.shr_u env_code (i64.const 2)))) (mif func_err (str func_err ", from compiling comb body (env as code)") (mif env_err (str env_err ", from compiling comb env (as code)") nil)) ctx)) + )) + + (true (error (str "Can't compile-inner impossible " c))) + ))) + + ;(_ (println "compiling partial evaled " (str_strip marked_code))) + (_ (true_print "compiling partial evaled " (true_str_strip marked_code))) + (memo empty_dict) + (ctx (array datasi funcs memo root_marked_env pectx)) + + ((exit_val _ _ ctx) (compile-inner ctx (marked_symbol nil 'exit) true)) + ((read_val _ _ ctx) (compile-inner ctx (marked_symbol nil 'read) true)) + ((write_val _ _ ctx) (compile-inner ctx (marked_symbol nil 'write) true)) + ((open_val _ _ ctx) (compile-inner ctx (marked_symbol nil 'open) true)) + ((monad_error_msg_val _ _ ctx) (compile-inner ctx (marked_val "Not a legal monad ( ['read fd len ] / ['write fd data ] / ['open fd path ] /['exit exit_code])") true)) + ((bad_read_val _ _ ctx) (compile-inner ctx (marked_val "") true)) + ((exit_msg_val _ _ ctx) (compile-inner ctx (marked_val "Exiting with code:") true)) + ((root_marked_env_val _ _ ctx) (compile-inner ctx root_marked_env true)) + + + ((compiled_value_ptr compiled_value_code compiled_value_error ctx) (compile-inner ctx marked_code true)) + ((datasi funcs memo root_marked_env pectx) ctx) + + ; Swap for when need to profile what would be an error + ;(compiled_value_ptr (mif compiled_value_error 0 compiled_value_ptr)) + (_ (mif compiled_value_error (error compiled_value_error))) + + (_ (if (= nil compiled_value_ptr) (error (str "compiled top-level to code for some reason!? have code " compiled_value_code)))) + + ; Ok, so the outer loop handles the IO monads + ; ('exit code) + ; ('read fd len ) + ; ('write fd "data" ) + ; ('open fd path ) + ; Could add some to open like lookup flags, o flags, base rights + ; ineriting rights, fdflags + + (start (func '$start '(local $it i64) '(local $tmp i64) '(local $ptr i32) '(local $monad_name i64) '(local $len i32) '(local $buf i32) '(local $code i32) '(local $str i64) '(local $result i64) + (local.set '$it (i64.const compiled_value_ptr)) + (block '$exit_block + (block '$error_block + (_loop '$l + ; Not array -> out + (br_if '$error_block (i64.ne (i64.const #b101) (i64.and (i64.const #b101) (local.get '$it)))) + ; less than len 2 -> out + (br_if '$error_block (i64.lt_u (i64.shr_u (local.get '$it) (i64.const 32)) (i64.const 2))) + (local.set '$ptr (i32.wrap_i64 (i64.and (local.get '$it) (i64.const -8)))) + ; second entry isn't an int -> out + (br_if '$error_block (i64.ne (i64.and (i64.load 8 (local.get '$ptr)) (i64.const #b1)) (i64.const #b0))) + (local.set '$monad_name (i64.load (local.get '$ptr))) + + ; ('exit code) + (_if '$is_exit + (i64.eq (i64.const exit_val) (local.get '$monad_name)) + (then + ; len != 2 + (br_if '$error_block (i64.ne (i64.shr_u (local.get '$it) (i64.const 32)) (i64.const 2))) + (call '$print (i64.const exit_msg_val)) + (call '$print (i64.load 8 (local.get '$ptr))) + (br '$exit_block) + ) + ) + + ; if len != 4 + (br_if '$error_block (i64.ne (i64.shr_u (local.get '$it) (i64.const 32)) (i64.const 4))) + + ; ('read fd len ) + (_if '$is_read + (i64.eq (i64.const read_val) (local.get '$monad_name)) + (then + ; third entry isn't an int -> out + (br_if '$error_block (i64.ne (i64.and (i64.load 16 (local.get '$ptr)) (i64.const #b1)) (i64.const #b0))) + ; fourth entry isn't a comb -> out + (br_if '$error_block (i64.ne (i64.and (i64.load 24 (local.get '$ptr)) (i64.const #b1111)) (i64.const #b0001))) + ; iov <32bit len><32bit addr> + <32bit num written> + (i32.store 0 (i32.const iov_tmp) (local.tee '$buf (call '$malloc (local.get '$len)))) + (i32.store 4 (i32.const iov_tmp) (local.tee '$len (i32.wrap_i64 (i64.shr_u (i64.load 16 (local.get '$ptr)) (i64.const 1))))) + (local.set '$code (call '$fd_read + (i32.wrap_i64 (i64.shr_u (i64.load 8 (local.get '$ptr)) (i64.const 1))) ;; file descriptor + (i32.const iov_tmp) ;; *iovs + (i32.const 1) ;; iovs_len + (i32.const (+ 8 iov_tmp)) ;; nwritten + )) + ; 011 + (local.set '$str (i64.or (i64.shl (i64.extend_i32_u (i32.load 8 (i32.const iov_tmp))) (i64.const 32)) + (i64.extend_i32_u (i32.or (local.get '$buf) (i32.const #b011))))) + (_if '$is_error + (i32.eqz (local.get '$code)) + (then + (local.set '$result (call '$array2_alloc (local.get '$str) + (i64.const 0))) + ) + (else + (call '$drop (local.get '$str)) + (local.set '$result (call '$array2_alloc (i64.const bad_read_val) + (i64.shl (i64.extend_i32_u (local.get '$code)) (i64.const 1)))) + ) + ) + + (local.set '$tmp (call '$dup (i64.load 24 (local.get '$ptr)))) + (call '$drop (local.get '$it)) + (local.set '$it (call_indirect + ;type + k_vau + ;table + 0 + ;params + (local.get '$result) + ;top_env + (i64.const root_marked_env_val) + ; static env + (i64.or (i64.shl (i64.and (local.get '$tmp) (i64.const #x3FFFFFFC0)) (i64.const 2)) (i64.const #b01001)) + ;func_idx + (i32.wrap_i64 (i64.shr_u (local.get '$tmp) (i64.const 35))) + )) + (br '$l) + ) + ) + + ; ('write fd "data" ) + (_if '$is_write + (i64.eq (i64.const write_val) (local.get '$monad_name)) + (then + ; third entry isn't a string -> out + (br_if '$error_block (i64.ne (i64.and (i64.load 16 (local.get '$ptr)) (i64.const #b111)) (i64.const #b011))) + ; fourth entry isn't a comb -> out + (br_if '$error_block (i64.ne (i64.and (i64.load 24 (local.get '$ptr)) (i64.const #b1111)) (i64.const #b0001))) + ; 011 + (local.set '$str (i64.load 16 (local.get '$ptr))) + + ; iov <32bit addr><32bit len> + <32bit num written> + (i32.store 0 (i32.const iov_tmp) (i32.wrap_i64 (i64.and (local.get '$str) (i64.const #xFFFFFFF8)))) + (i32.store 4 (i32.const iov_tmp) (i32.wrap_i64 (i64.shr_u (local.get '$str) (i64.const 32)))) + (local.set '$code (call '$fd_write + (i32.wrap_i64 (i64.shr_u (i64.load 8 (local.get '$ptr)) (i64.const 1))) ;; file descriptor + (i32.const iov_tmp) ;; *iovs + (i32.const 1) ;; iovs_len + (i32.const (+ 8 iov_tmp)) ;; nwritten + )) + (local.set '$result (call '$array2_alloc (i64.shl (i64.extend_i32_u (i32.load (i32.const (+ 8 iov_tmp)))) (i64.const 1)) + (i64.shl (i64.extend_i32_u (local.get '$code)) (i64.const 1)))) + + (local.set '$tmp (call '$dup (i64.load 24 (local.get '$ptr)))) + (call '$drop (local.get '$it)) + (local.set '$it (call_indirect + ;type + k_vau + ;table + 0 + ;params + (local.get '$result) + ;top_env + (i64.const root_marked_env_val) + ; static env + (i64.or (i64.shl (i64.and (local.get '$tmp) (i64.const #x3FFFFFFC0)) (i64.const 2)) (i64.const #b01001)) + ;func_idx + (i32.wrap_i64 (i64.shr_u (local.get '$tmp) (i64.const 35))) + )) + (br '$l) + ) + ) + ; ('open fd path ) + (_if '$is_open + (i64.eq (i64.const open_val) (local.get '$monad_name)) + (then + ; third entry isn't a string -> out + (br_if '$error_block (i64.ne (i64.and (i64.load 16 (local.get '$ptr)) (i64.const #b111)) (i64.const #b011))) + ; fourth entry isn't a comb -> out + (br_if '$error_block (i64.ne (i64.and (i64.load 24 (local.get '$ptr)) (i64.const #b1111)) (i64.const #b0001))) + ; 011 + (local.set '$str (i64.load 16 (local.get '$ptr))) + + (local.set'$code (call '$path_open + (i32.wrap_i64 (i64.shr_u (i64.load 8 (local.get '$ptr)) (i64.const 1))) ;; file descriptor + (i32.const 0) ;; lookup flags + (i32.wrap_i64 (i64.and (local.get '$str) (i64.const #xFFFFFFF8))) ;; path string * + (i32.wrap_i64 (i64.shr_u (local.get '$str) (i64.const 32))) ;; path string len + (i32.const 1) ;; o flags + (i64.const 66) ;; base rights + (i64.const 66) ;; inheriting rights + (i32.const 0) ;; fdflags + (i32.const iov_tmp) ;; opened fd out ptr + )) + + (local.set '$result (call '$array2_alloc (i64.shl (i64.extend_i32_u (i32.load (i32.const iov_tmp))) (i64.const 1)) + (i64.shl (i64.extend_i32_u (local.get '$code)) (i64.const 1)))) + + (local.set '$tmp (call '$dup (i64.load 24 (local.get '$ptr)))) + (call '$drop (local.get '$it)) + (local.set '$it (call_indirect + ;type + k_vau + ;table + 0 + ;params + (local.get '$result) + ;top_env + (i64.const root_marked_env_val) + ; static env + (i64.or (i64.shl (i64.and (local.get '$tmp) (i64.const #x3FFFFFFC0)) (i64.const 2)) (i64.const #b01001)) + ;func_idx + (i32.wrap_i64 (i64.shr_u (local.get '$tmp) (i64.const 35))) + )) + (br '$l) + ) + ) + ) + ) + ; print error + (call '$print (i64.const monad_error_msg_val)) + (call '$print (local.get '$it)) + ) + (call '$drop (local.get '$it)) + )) + ((watermark datas) datasi) + ) (concat + (global '$data_end '(mut i32) (i32.const watermark)) + datas funcs start + (table '$tab (len funcs) 'funcref) + (apply elem (cons (i32.const 0) (range dyn_start (+ num_pre_functions (len funcs))))) + (memory '$mem (+ 2 (>> watermark 16))) + )) + (export "memory" '(memory $mem)) + (export "_start" '(func $start)) + ))))) + + + (run_partial_eval_test (lambda (s) (dlet ( + (_ (print "\n\ngoing to partial eval " s)) + ((pectx err result) (partial_eval (read-string s))) + (_ (print "result of test \"" s "\" => " (str_strip result) " and err " err)) + (_ (print "with a hash of " (.hash result))) + ) nil))) + + + (test-most (lambda () (begin + (print (val? '(val))) + (print "take 3" (take '(1 2 3 4 5 6 7 8 9 10) 3)) + ; shadowed by wasm + ;(print "drop 3" (drop '(1 2 3 4 5 6 7 8 9 10) 3)) + (print (slice '(1 2 3) 1 2)) + (print (slice '(1 2 3) 1 -1)) + (print (slice '(1 2 3) -1 -1)) + (print (slice '(1 2 3) -2 -1)) + + (print "ASWDF") + (print (str-to-symbol (str '(a b)))) + (print (symbol? (str-to-symbol (str '(a b))))) + (print ( (dlambda ((a b)) a) '(1337 1338))) + (print ( (dlambda ((a b)) b) '(1337 1338))) + + (print (str 1 2 3 (array 1 23 4) "a" "B")) + + (print (dlet ( (x 2) ((a b) '(1 2)) (((i i2) i3) '((5 6) 7)) ) (+ x a b i i2 i3))) + + (print (array 1 2 3)) + (print (command-line-arguments)) + + ;(print (call-with-input-string "'(1 2)" (lambda (p) (read p)))) + (print (read (open-input-string "'(3 4)"))) + + (print "if tests") + (print (if true 1 2)) + (print (if false 1 2)) + (print (if true 1)) + (print (if false 1)) + (print "if tests end") + + (print "mif tests") + (print (mif true 1 2)) + (print (mif false 1 2)) + (print (mif true 1)) + (print (mif false 1)) + (print "2 nils") + (print (mif nil 1 2)) + (print (mif nil 1)) + (print "2 1s") + (print (mif 1 1 2)) + (print (mif 1 1)) + (print "mif tests end") + + (print (get-value (put (put empty_dict 3 4) 1 2) 3)) + (print (get-value (put (put empty_dict 3 4) 1 2) 1)) + + (print (get-value-or-false (put (put empty_dict 3 4) 1 2) 3)) + (print (get-value-or-false (put (put empty_dict 3 4) 1 2) 1)) + (print (get-value-or-false (put (put empty_dict 3 4) 1 2) 5)) + + (print "zip " (zip '(1 2 3) '(4 5 6) '(7 8 9))) + + (print (run_partial_eval_test "(+ 1 2)")) + (print) (print) + (print (run_partial_eval_test "(cond false 1 true 2)")) + (print (run_partial_eval_test "(log 1)")) + (print (run_partial_eval_test "((vau (x) (+ x 1)) 2)")) + + + (print (run_partial_eval_test "(+ 1 2)")) + (print (run_partial_eval_test "(vau (y) (+ 1 2))")) + (print (run_partial_eval_test "((vau (y) (+ 1 2)) 4)")) + (print (run_partial_eval_test "((vau (y) y) 4)")) + (print (run_partial_eval_test "((vau (y) (+ 13 2 y)) 4)")) + (print (run_partial_eval_test "((wrap (vau (y) (+ 13 2 y))) (+ 3 4))")) + (print (run_partial_eval_test "(vau de (y) (+ (eval y de) (+ 1 2)))")) + (print (run_partial_eval_test "((vau de (y) ((vau dde (z) (+ 1 (eval z dde))) y)) 17)")) + + (print (run_partial_eval_test "(cond false 1 false 2 (+ 1 2) 3 true 1337)")) + (print (run_partial_eval_test "(vau de (x) (cond false 1 false 2 x 3 true 42))")) + (print (run_partial_eval_test "(vau de (x) (cond false 1 false 2 3 x true 42))")) + + (print (run_partial_eval_test "(combiner? true)")) + (print (run_partial_eval_test "(combiner? (vau de (x) x))")) + (print (run_partial_eval_test "(vau de (x) (combiner? x))")) + + (print (run_partial_eval_test "((vau (x) x) a)")) + + (print (run_partial_eval_test "(env? true)")) + ; this doesn't partially eval, but it could with a more percise if the marked values were more percise + (print (run_partial_eval_test "(vau de (x) (env? de))")) + (print (run_partial_eval_test "(vau de (x) (env? x))")) + (print (run_partial_eval_test "((vau de (x) (env? de)) 1)")) + + (print (run_partial_eval_test "((wrap (vau (let1) (let1 a 12 (+ a 1)))) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de)))")) + (print (run_partial_eval_test "((wrap (vau (let1) (let1 a 12 (vau (x) (+ a 1))))) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de)))")) + (print (run_partial_eval_test "((wrap (vau (let1) (let1 a 12 (wrap (vau (x) (+ x a 1)))))) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de)))")) + (print (run_partial_eval_test "((wrap (vau (let1) (let1 a 12 (wrap (vau (x) (let1 y (+ a 1) (+ y x a))))))) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de)))")) + + ;(print "\n\nnil test\n") + ;(print (run_partial_eval_test "nil")) + ;(print (run_partial_eval_test "(nil? 1)")) + ;(print (run_partial_eval_test "(nil? nil)")) + + (print "\n\nlet 4.3\n\n") + (print (run_partial_eval_test "((wrap (vau (let1) + (let1 a 12 (wrap (vau (x) (let1 y (+ a 1) (+ y x a)))) + ))) (vau de (s v b) (eval (array (array wrap (array vau (array s) b)) v) de)))")) + (print "\n\nlet 4.7\n\n") + (print (run_partial_eval_test "((wrap (vau (let1) + (let1 a 12 (wrap (vau (x) (let1 y (+ x a 1) (+ y x a)))) + ))) (vau de (s v b) (eval (array (array wrap (array vau (array s) b)) v) de)))")) + + (print "\n\nlet 5\n\n") + (print (run_partial_eval_test "((wrap (vau (let1) + (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)))")) + + (print "\n\nlambda 1\n\n") + (print (run_partial_eval_test "((wrap (vau (let1) + (let1 lambda (vau se (p b) (wrap (eval (array vau p b) se))) + (lambda (x) x) + ))) (vau de (s v b) (eval (array (array wrap (array vau (array s) b)) v) de)))")) + (print "\n\nlambda 2\n\n") + (print (run_partial_eval_test "((wrap (vau (let1) + (let1 lambda (vau se (p b) (wrap (eval (array vau p b) se))) + (let1 a 12 + (lambda (x) (+ a x))) + ))) (vau de (s v b) (eval (array (array wrap (array vau (array s) b)) v) de)))")) + (print "\n\nlambda 3\n\n") + (print (run_partial_eval_test "((wrap (vau (let1) + (let1 lambda (vau se (p b) (wrap (eval (array vau p b) se))) + (let1 a 12 + (lambda (x) (let1 b (+ a x) + (+ a x b)))) + ))) (vau de (s v b) (eval (array (array wrap (array vau (array s) b)) v) de)))")) + + (print (run_partial_eval_test "(array 1 2 3 4 5)")) + (print (run_partial_eval_test "((wrap (vau (a & rest) rest)) 1 2 3 4 5)")) + + (print "\n\nrecursion test\n\n") + (print (run_partial_eval_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 (!= 0 n) (* n (recurse recurse (- n 1))) + true 1 )) 5) + ))) (vau de (s v b) (eval (array (array wrap (array vau (array s) b)) v) de)))")) + + (print "\n\nlambda recursion test\n\n") + (print (run_partial_eval_test "((wrap (vau (let1) + (let1 lambda (vau se (p b) (wrap (eval (array vau p b) se))) + (lambda (n) ((lambda (x n) (x x n)) (lambda (recurse n) (cond (!= 0 n) (* n (recurse recurse (- n 1))) + true 1 )) n)) + ))) (vau de (s v b) (eval (array (array wrap (array vau (array s) b)) v) de)))")) + + ; The issue with this one is that (x2 x2) trips the infinate recursion protector, but then + ; that array gets marked as attempted & needing no more evaluation, and is frozen forever. + ; Then, when the recursion is actually being used, it won't keep going and you only get + ; the first level. + (print "\n\nlambda recursion Y combiner test\n\n") + (print (run_partial_eval_test "((wrap (vau (let1) + (let1 lambda (vau se (p b) (wrap (eval (array vau p b) se))) + (let1 lapply (lambda (f1 p) (eval (concat (array (unwrap f1)) p))) + (let1 Y (lambda (f3) + ((lambda (x1) (x1 x1)) + (lambda (x2) (f3 (lambda (& y) (lapply (x2 x2) y)))))) + ((Y (lambda (recurse) (lambda (n) (cond (!= 0 n) (* n (recurse (- n 1))) + true 1)))) + 5) + ))))) (vau de (s v b) (eval (array (array wrap (array vau (array s) b)) v) de)))")) + + + + (print "ok, hex of 0 is " (hex_digit #\0)) + (print "ok, hex of 1 is " (hex_digit #\1)) + (print "ok, hex of a is " (hex_digit #\a)) + (print "ok, hex of A is " (hex_digit #\A)) + (print "ok, hexify of 1337 is " (i64_le_hexify 1337)) + (print "ok, hexify of 10 is " (i64_le_hexify 10)) + (print "ok, hexify of 15 is " (i64_le_hexify 15)) + (print "ok, hexfy of 15 << 60 is " (i64_le_hexify (<< 15 60))) + (let* ( + ;(output1 (wasm_to_binary (module))) + ;(output2 (wasm_to_binary (module + ; (import "wasi_unstable" "path_open" + ; '(func $path_open (param i32 i32 i32 i32 i32 i64 i64 i32 i32) + ; (result i32))) + ; (import "wasi_unstable" "fd_prestat_dir_name" + ; '(func $fd_prestat_dir_name (param i32 i32 i32) + ; (result i32))) + ; (import "wasi_unstable" "fd_read" + ; '(func $fd_read (param i32 i32 i32 i32) + ; (result i32))) + ; (import "wasi_unstable" "fd_write" + ; '(func $fd_write (param i32 i32 i32 i32) + ; (result i32))) + ; (memory '$mem 1) + ; (global '$gi 'i32 (i32.const 8)) + ; (global '$gb '(mut i64) (i64.const 9)) + ; (table '$tab 2 'funcref) + ; (data (i32.const 16) "HellH") ;; adder to put, then data + + + ; (func '$start + ; (i32.store (i32.const 8) (i32.const 16)) ;; adder of data + ; (i32.store (i32.const 12) (i32.const 5)) ;; len of data + ; ;; open file + ; (call 0 ;$path_open + ; (i32.const 3) ;; file descriptor + ; (i32.const 0) ;; lookup flags + ; (i32.const 16) ;; path string * + ; (i32.load (i32.const 12)) ;; path string len + ; (i32.const 1) ;; o flags + ; (i64.const 66) ;; base rights + ; (i64.const 66) ;; inheriting rights + ; (i32.const 0) ;; fdflags + ; (i32.const 4) ;; opened fd out ptr + ; ) + ; (drop) + ; (block '$a + ; (block '$b + ; (br '$a) + ; (br_if '$b + ; (i32.const 3)) + ; (_loop '$l + ; (br '$a) + ; (br '$l) + ; ) + ; (_if '$myif + ; (i32.const 1) + ; (then + ; (i32.const 1) + ; (drop) + ; (br '$b) + ; ) + ; (else + ; (br '$myif) + ; ) + ; ) + ; (_if '$another + ; (i32.const 1) + ; (br '$b)) + ; (i32.const 1) + ; (_if '$third + ; (br '$b)) + ; (_if '$fourth + ; (br '$fourth)) + ; ) + ; ) + ; (call '$fd_read + ; (i32.const 0) ;; file descriptor + ; (i32.const 8) ;; *iovs + ; (i32.const 1) ;; iovs_len + ; (i32.const 12) ;; nwritten, overwrite buf len with it + ; ) + ; (drop) + + ; ;; print name + ; (call '$fd_write + ; (i32.load (i32.const 4)) ;; file descriptor + ; (i32.const 8) ;; *iovs + ; (i32.const 1) ;; iovs_len + ; (i32.const 4) ;; nwritten + ; ) + ; (drop) + ; ) + + ; (elem (i32.const 0) '$start '$start) + ; (export "memory" '(memory $mem)) + ; (export "_start" '(func $start)) + ;))) + (output3 (compile (partial_eval (read-string "(array 1 (array ((vau (x) x) a) (array \"asdf\")) 2)")))) + (output3 (compile (partial_eval (read-string "(array 1 (array 1 2 3 4) 2 (array 1 2 3 4))")))) + (output3 (compile (partial_eval (read-string "empty_env")))) + (output3 (compile (partial_eval (read-string "(eval (array (array vau ((vau (x) x) (a b)) (array (array vau ((vau (x) x) x) (array) ((vau (x) x) x)))) 1 2) empty_env)")))) + (output3 (compile (partial_eval (read-string "(eval (array (array vau ((vau (x) x) (a b)) (array (array vau ((vau (x) x) x) (array) ((vau (x) x) x)))) empty_env 2) empty_env)")))) + (output3 (compile (partial_eval (read-string "(eval (array (array vau ((vau (x) x) x) (array) ((vau (x) x) x))))")))) + (output3 (compile (partial_eval (read-string "(vau (x) x)")))) + (output3 (compile (partial_eval (read-string "(vau (x) 1)")))) + + (output3 (compile (partial_eval (read-string "(array ((vau (x) x) exit) 1)")))) + + (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (array ((vau (x) x) exit) 1)))")))) + + (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (array ((vau (x) x) exit) written)))")))) + + (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) written))")))) + (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) code))")))) + (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (array 1337 written 1338 code 1339)))")))) + + (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (cond (= 0 code) written true code)))")))) + (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (str (= 0 code) written true (array) code)))")))) + (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (log (= 0 code) written true (array) code)))")))) + (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (error (= 0 code) written true code)))")))) + ;(output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (or (= 0 code) written true code)))")))) + + (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (+ written code 1337)))")))) + (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (- written code 1337)))")))) + (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (* written 1337)))")))) + (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (/ 1337 written)))")))) + (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (% 1337 written)))")))) + (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (band 1337 written)))")))) + (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (bor 1337 written)))")))) + (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (bnot written)))")))) + (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (bxor 1337 written)))")))) + (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (<< 1337 written)))")))) + (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (>> 1337 written)))")))) + + (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (<= (array written) (array 1337))))")))) + + (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (read-string (cond written \"true\" true 3))))")))) + (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (read-string (cond written \" true\" true 3))))")))) + (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (read-string (cond written \" true \" true 3))))")))) + (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (read-string (cond written \" false\" true 3))))")))) + (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (read-string (cond written \"(false (true () true) true)\" true 3))))")))) + (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (read-string (cond written \"(false (true () true) true) true\" true 3))))")))) + + (output3 (compile (partial_eval (read-string "(array ((vau (x) x) open) 3 \"test_out\" (vau (fd code) (array ((vau (x) x) write) fd \"waa\" (vau (written code) (array written code)))))")))) + (output3 (compile (partial_eval (read-string "(array ((vau (x) x) open) 3 \"test_out\" (vau (fd code) (array ((vau (x) x) read) fd 10 (vau (data code) (array data code)))))")))) + + ;(_ (print (slurp "test_parse_in"))) + (output3 (compile (partial_eval (read-string "(array ((vau (x) x) open) 3 \"test_parse_in\" (vau (fd code) (array ((vau (x) x) read) fd 1000 (vau (data code) (read-string data)))))")))) + (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"test_parse_in\" (vau (written code) (array (array written))))")))) + + + (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (& args) (slice args 1 -1)))")))) + (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (& args) (len args)))")))) + (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (& args) (idx args 0)))")))) + (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (& args) (slice (concat args (array 1 2 3 4) args) 1 -2)))")))) + + (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (& args) (str-to-symbol (str args))))")))) + (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (& args) (get-text (str-to-symbol (str args)))))")))) + (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (& args) (wrap (cond args idx true 0))))")))) + (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (& args) (wrap (wrap (cond args idx true 0)))))")))) + (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (& args) (wrap (wrap (wrap (cond args idx true 0))))))")))) + (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (& args) (unwrap (cond args idx true 0))))")))) + (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (& args) (unwrap (cond args vau true 0))))")))) + + (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (array (nil? written) (array? written) (bool? written) (env? written) (combiner? written) (string? written) (int? written) (symbol? written))))")))) + (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau de (written code) (array (nil? (cond written (array) true 4)) (array? (cond written (array 1 2) true 4)) (bool? (= 3 written)) (env? de) (combiner? (cond written (vau () 1) true 43)) (string? (cond written \"a\" 3 3)) (int? (cond written \"a\" 3 3)) (symbol? (cond written ((vau (x) x) x) 3 3)) written)))")))) + + (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (& args) args))")))) + (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (a & args) a))")))) + (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (a & args) args))")))) + + (output3 (compile (partial_eval (read-string "(array ((vau (x) x) read) 0 10 (vau (data code) data))")))) + (output3 (compile (partial_eval (read-string "(array ((vau (x) x) read) 0 10 (vau (data code) (array ((vau (x) x) write) 1 data (vau (written code) (array written code)))))")))) + + (output3 (compile (partial_eval (read-string "(wrap (vau (x) x))")))) + (output3 (compile (partial_eval (read-string "len")))) + (output3 (compile (partial_eval (read-string "vau")))) + (output3 (compile (partial_eval (read-string "(array len 3 len)")))) + (output3 (compile (partial_eval (read-string "(+ 1 1337 (+ 1 2))")))) + (output3 (compile (partial_eval (read-string "\"hello world\"")))) + (output3 (compile (partial_eval (read-string "((vau (x) x) asdf)")))) + (output3 (compile (partial_eval (read-string "((wrap (vau (let1) + (let1 lambda (vau se (p b) (wrap (eval (array vau p b) se))) + (array ((vau (x) x) write) 1 \"hahah\" (vau (written code) ((lambda (x n) (x x n)) (lambda (recurse n) (cond (!= 0 n) (* n (recurse recurse (- n 1))) + true 1)) written))) + ))) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de)))")))) + (_ (write_file "./csc_out.wasm" output3)) + (output3 (compile (partial_eval (read-string "(nil? 1)")))) + ;(output3 (compile (partial_eval (read-string "(nil? nil)")))) + ) (void)) + ))) + + (single-test (lambda () (dlet ( + ;(output3 (compile (partial_eval (read-string "1337")))) + ;(output3 (compile (partial_eval (read-string "\"This is a longish sring to make sure alloc data is working properly\"")))) + ;(output3 (compile (partial_eval (read-string "((vau (x) x) write)")))) + ;(output3 (compile (partial_eval (read-string "(wrap (vau (x) x))")))) + ;(output3 (compile (partial_eval (read-string "(wrap (vau (x) (log 1337)))")))) + ;(output3 (compile (partial_eval (read-string "(wrap (vau (x) (+ x 1337)))")))) + ;(output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"w\" (vau (written code) (+ written code 1337)))")))) + ;(output3 (compile (partial_eval (read-string "((wrap (vau (let1) + ; (let1 lambda (vau se (p b) (wrap (eval (array vau p b) se))) + ; (array ((vau (x) x) write) 1 \"hahah\" (vau (written code) ((lambda (x n) (x x n)) (lambda (recurse n) (cond (!= 0 n) (* n (recurse recurse (- n 1))) + ; true 1)) written))) + ; ))) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de)))")))) + + + (output3 (compile (partial_eval (read-string + "((wrap (vau root_env (quote) + ((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)) + ) void))) + + (run-compiler (lambda () + (write_file "./csc_out.wasm" (compile (partial_eval (read-string (slurp "to_compile.kp"))))) + )) + +) (begin - (print "take 3" (take '(1 2 3 4 5 6 7 8 9 10) 3)) - ; shadowed by wasm - ;(print "drop 3" (drop '(1 2 3 4 5 6 7 8 9 10) 3)) - (print (slice '(1 2 3) 1 2)) - (print (slice '(1 2 3) 1 -1)) - (print (slice '(1 2 3) -1 -1)) - (print (slice '(1 2 3) -2 -1)) - - (print "ASWDF") - (print (str-to-symbol (str '(a b)))) - (print (symbol? (str-to-symbol (str '(a b))))) - (print "first dlambda test") - (print ( (dlambda ((a b)) a) '(1337 1338))) - (print ( (dlambda ((a b)) b) '(1337 1338))) - - (print (str 1 2 3 (array 1 23 4) "a" "B")) - - (print "first destructure test") - (print (dlet ( (x 2) ((a b) '(1 2)) (((i i2) i3) '((5 6) 7)) ) (+ x a b i i2 i3))) - (print (dlet () 1)) - (print (dlet ((x 1)) x)) - (print (dlet (((x) '(1))) x)) - (print (dlet (((x y) (list 1 2))) x)) - (print (dlet (((x y) (list 1 2))) y)) - (print (dlet (((x y) (list 1 2))) (+ x y))) - (print (dlet (((x y) (list 1 2)) ((e f g) (list 4 5 6))) (+ x y e f g))) - - (print (array 1 2 3)) - (print (command-line-arguments)) - - ;(print (call-with-input-string "'(1 2)" (lambda (p) (read p)))) - (print (read (open-input-string "'(3 4)"))) - - (print "if tests") - (print (if true 1 2)) - (print (if false 1 2)) - (print (if true 1)) - (print (if false 1)) - (print "if tests end") - - (print "zip " (zip '(1 2 3) '(4 5 6) '(7 8 9))) + ; (test-most) + ; (single-test) + (run-compiler) ) ) + +;;;;;;;;;;;;;; +; Known TODOs +;;;;;;;;;;;;;; +; +; * ARRAY FUNCTIONS FOR STRINGS, in both PARTIAL_EVAL *AND* COMPILED +; * eval vau other missing builtins +; * NON NAIVE REFCOUNTING +; EVENTUALLY: Support some hard core partial_eval that an fully make (foldl or stuff) short circut effeciencly with double-inlining, finally +; addressing the strict-languages-don't-compose thing