From f1d2e0dce26b5df593d7b54283f9b7e0da8f03ec Mon Sep 17 00:00:00 2001 From: Nathan Braswell Date: Fri, 31 Dec 2021 01:28:31 -0500 Subject: [PATCH] Add rough version of log, error, str, ptr-equality-rough versions of = and !=, and actual versions for + - * / % & | --- partial_eval.csc | 341 ++++++++++++++++++++++++++++++++--------------- 1 file changed, 234 insertions(+), 107 deletions(-) diff --git a/partial_eval.csc b/partial_eval.csc index d208169..9b44099 100644 --- a/partial_eval.csc +++ b/partial_eval.csc @@ -1249,8 +1249,9 @@ (memory '$mem 1) (global '$malloc_head '(mut i32) (i32.const 0)) (dlet ( - (true_val #b00111101) - (false_val #b00011101) + (nil_val #b0101) + (true_val #b000111001) + (false_val #b000011001) (alloc_data (dlambda (d (watermark datas)) (cond ((str? d) (let ((size (+ 8 (& (len d) -8)))) (array (+ watermark 8) (len d) @@ -1268,6 +1269,12 @@ ((false_loc false_length datasi) (alloc_data "false" datasi)) ((bad_params_loc bad_params_length datasi) (alloc_data "\nError: passed a bad number of parameters\n" datasi)) (bad_params_msg_val (bor (<< bad_params_length 32) bad_params_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)) + ((newline_loc newline_length datasi) (alloc_data "\n" datasi)) + (newline_msg_val (bor (<< newline_length 32) newline_loc #b011)) ((remaining_vau_loc remaining_vau_length datasi) (alloc_data "\nError: trying to call a remainin vau\n" datasi)) (remaining_vau_msg_val (bor (<< remaining_vau_length 32) remaining_vau_loc #b011)) @@ -1458,11 +1465,11 @@ ; 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 #b00111101) (local.get '$to_str_len)) + (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 #b00011101) (local.get '$to_str_len)) + (i64.eq (i64.const false_val) (local.get '$to_str_len)) (then (i32.const false_length)) (else (_if '$is_str_or_symbol '(result i32) @@ -1476,20 +1483,20 @@ (_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 2)) + (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 - (br_if '$b (i32.eq (local.get '$i_tmp) (i32.const 0))) (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) ) ) - (i32.sub (local.get '$running_len_tmp) (i32.const 1)) + (local.get '$running_len_tmp) ) (else (_if '$is_env '(result i32) @@ -1561,14 +1568,14 @@ ; 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 #b00111101) (local.get '$to_str)) + (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 #b00011101) (local.get '$to_str)) + (i64.eq (i64.const false_val) (local.get '$to_str)) (then (memory.copy (local.get '$buf) (i32.const false_loc) (i32.const false_length)) @@ -1603,9 +1610,9 @@ (local.set '$ptr_tmp (i32.wrap_i64 (i64.and (local.get '$to_str) (i64.const -8)))) (block '$b (_loop '$l - (br_if '$b (i32.eq (local.get '$i_tmp) (i32.const 0))) (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))) @@ -1771,64 +1778,175 @@ (i64.shl (i64.extend_i32_u (local.get '$new_size)) (i64.const 32))) )))) - ((k_len func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$len '(param $it i64) '(param $d i64) '(param $s i64) '(result i64) - (i64.and (i64.shr_u (local.get '$it) (i64.const 31)) (i64.const -2)) - (call '$drop (local.get '$it)) - (call '$drop (local.get '$d)) - ; static env is 0 by construction + ; 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)))) + + (ensure_not_op_n_params_set_ptr_len (lambda (op n) (concat + (local.set '$len (i32.wrap_i64 (i64.shr_u (local.get '$p) (i64.const 32)))) + (_if '$is_2_params + (op (local.get '$len) (i32.const n)) + (then + (call '$print (i64.const bad_params_msg_val)) + (unreachable) + ) + ) + (local.set '$ptr (i32.wrap_i64 (i64.and (local.get '$p) (i64.const -8)))) + ))) + (drop_p_d (concat + (call '$drop (local.get '$p)) + (call '$drop (local.get '$d)))) + + ((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 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 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)) )))) - (ensure_2_params_set_ptr (concat (_if '$is_2_params - (i64.ne (i64.shr_u (local.get '$p) (i64.const 32)) (i64.const 2)) - (then - (call '$print (i64.const bad_params_msg_val)) - (unreachable) - ) - ) - (local.set '$ptr (i32.wrap_i64 (i64.and (local.get '$p) (i64.const -8)))) - )) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ; THESE BOTH NEED TO BE INLINED AS THEY'RE ACTUALLY SHORT CIRCUITING EVALUATION-WISE + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ((k_or func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$or '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $ptr i32) '(local $len i32) '(local $i i32) '(local $cur i64) + ;(local.set '$ptr (i32.wrap_i64 (i64.and (local.get '$p) (i64.const -8)))) + ;(local.set '$len (i32.wrap_i64 (i64.shr_u (local.get '$p) (i64.const 32)))) + ;(local.set '$i (i32.const 0)) + ;(local.set '$cur (i64.const false_val)) + ;(block '$b + ; (_loop '$l + ; (br_if '$b (i32.eq (local.get '$len) (local.get '$i))) + ; (local.set '$cur (i64.load (local.get '$ptr))) + ; (br_if '$b (truthy_test (local.get '$cur))) + ; (local.set '$i (i32.add (local.get '$i) (i32.const 1))) + ; (local.set '$ptr (i32.add (i32.const 8) (local.get '$ptr))) + ; (br '$l) + ; ) + ;) + ;(local.get '$cur) + (unreachable) + )))) + ((k_and func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$and '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $ptr i32) '(local $len i32) '(local $i i32) '(local $cur i64) + ;(local.set '$ptr (i32.wrap_i64 (i64.and (local.get '$p) (i64.const -8)))) + ;(local.set '$len (i32.wrap_i64 (i64.shr_u (local.get '$p) (i64.const 32)))) + ;(local.set '$i (i32.const 0)) + ;(local.set '$cur (i64.const false_val)) + ;(block '$b + ; (_loop '$l + ; (br_if '$b (i32.eq (local.get '$len) (local.get '$i))) + ; (local.set '$cur (i64.load (local.get '$ptr))) + ; (br_if '$b (truthy_test (local.get '$cur))) + ; (local.set '$i (i32.add (local.get '$i) (i32.const 1))) + ; (local.set '$ptr (i32.add (i32.const 8) (local.get '$ptr))) + ; (br '$l) + ; ) + ;) + ;(local.get '$cur) + (unreachable) + )))) - ((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) (unreachable))))) - ((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) (unreachable))))) - ((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) (unreachable))))) - ((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) (unreachable))))) - ((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) (unreachable))))) - ((k_or func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$or '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) (unreachable))))) - ((k_and func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$and '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) (unreachable))))) - ((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) (unreachable))))) - ((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) (unreachable))))) - ((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) (unreachable))))) - ((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) (unreachable))))) - ((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) (unreachable))))) - ((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) '(local $ptr i32) - ensure_2_params_set_ptr + ((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) '(local $ptr i32) '(local $len i32) + (ensure_not_op_n_params_set_ptr_len i32.lt_u 2) (_if '$eq '(result i64) ; TODO: BAD BAD BAD this is ptr equality (i64.eq (i64.load 0 (local.get '$ptr)) (i64.load 8 (local.get '$ptr))) (then (i64.const true_val)) (else (i64.const false_val)) ) + drop_p_d )))) - ((k_mod func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$mod '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) (unreachable))))) - ((k_div func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$div '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) (unreachable))))) - ((k_mul func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$mul '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) (unreachable))))) - ((k_add func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$add '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) (unreachable))))) - ((k_sub func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$sub '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) (unreachable))))) - ((k_band func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$band '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) (unreachable))))) - ((k_bor func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$bor '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) (unreachable))))) + ((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) + (_if '$neq '(result i64) + (i64.eq (i64.const true_val) (call '$eq (local.get '$p) (local.get '$d) (local.get '$s))) + (then (i64.const false_val)) + (else (i64.const true_val)) + ) + )))) + ((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) (unreachable))))) + ((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) (unreachable))))) + ((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) (unreachable))))) + ((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) (unreachable))))) + + (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 func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (math_function '$mod true i64.rem_s)))) + ((k_div func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (math_function '$div true i64.div_s)))) + ((k_mul func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (math_function '$mul true i64.mul)))) + ((k_sub func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (math_function '$sub true i64.sub)))) + ((k_add func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (math_function '$add false i64.add)))) + ((k_band func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (math_function '$band false i64.and)))) + ((k_bor func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (math_function '$bor false i64.or)))) + ((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) (unreachable))))) ((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) (unreachable))))) + ((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) (unreachable))))) ((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) (unreachable))))) ((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) (unreachable))))) + ((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) + ; TYPE CHECK + (i64.and (i64.shr_u (local.get '$p) (i64.const 31)) (i64.const -2)) + drop_p_d + )))) + ((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_arrayp func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$arrayp '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) (unreachable))))) - ((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) (unreachable))))) - ((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) (unreachable))))) + + ((k_array? func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$arrayp '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) (unreachable))))) ((k_bool? func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$bool? '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) (unreachable))))) ((k_nil? func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$nil? '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) (unreachable))))) ((k_env? func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$env? '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) (unreachable))))) @@ -1836,10 +1954,16 @@ ((k_string? func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$string? '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) (unreachable))))) ((k_int? func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$int? '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) (unreachable))))) ((k_symbol? func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$symbol? '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) (unreachable))))) - ((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) (unreachable))))) - ((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) (unreachable))))) + + ((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) (unreachable))))) + ((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) (unreachable))))) + ((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) (unreachable))))) ((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) (unreachable))))) + ((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) (unreachable))))) + ((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) (unreachable))))) + ((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) (unreachable))))) + ((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) (unreachable))))) (get_passthrough (lambda (hash datasi funcs memo) (let ((r (get-value-or-false memo hash))) (if r (array r datasi funcs memo) #f)))) @@ -1888,47 +2012,47 @@ (result (bor (<< c_loc 5) #b01001)) (memo (put memo (.hash c) result)) ) (array result datasi funcs memo)))) - ((prim_comb? c) (cond ((= 'vau (.prim_comb_sym c)) (array (bor (<< (- k_vau k_len) 35) (<< 0 4) #b0001) datasi funcs memo)) - ((= 'cond (.prim_comb_sym c)) (array (bor (<< (- k_cond k_len) 35) (<< 0 4) #b0001) datasi funcs memo)) - ((= 'or (.prim_comb_sym c)) (array (bor (<< (- k_or k_len) 35) (<< 0 4) #b0001) datasi funcs memo)) - ((= 'and (.prim_comb_sym c)) (array (bor (<< (- k_and k_len) 35) (<< 0 4) #b0001) datasi funcs memo)) - ((= 'len (.prim_comb_sym c)) (array (bor (<< (- k_len k_len) 35) (<< 1 4) #b0001) datasi funcs memo)) - ((= 'read-string (.prim_comb_sym c)) (array (bor (<< (- k_read-string k_len) 35) (<< 1 4) #b0001) datasi funcs memo)) - ((= 'log (.prim_comb_sym c)) (array (bor (<< (- k_log k_len) 35) (<< 1 4) #b0001) datasi funcs memo)) - ((= 'error (.prim_comb_sym c)) (array (bor (<< (- k_error k_len) 35) (<< 1 4) #b0001) datasi funcs memo)) - ((= 'str (.prim_comb_sym c)) (array (bor (<< (- k_str k_len) 35) (<< 1 4) #b0001) datasi funcs memo)) - ((= '>= (.prim_comb_sym c)) (array (bor (<< (- k_geq k_len) 35) (<< 1 4) #b0001) datasi funcs memo)) - ((= '> (.prim_comb_sym c)) (array (bor (<< (- k_gt k_len) 35) (<< 1 4) #b0001) datasi funcs memo)) - ((= '<= (.prim_comb_sym c)) (array (bor (<< (- k_leq k_len) 35) (<< 1 4) #b0001) datasi funcs memo)) - ((= '< (.prim_comb_sym c)) (array (bor (<< (- k_lt k_len) 35) (<< 1 4) #b0001) datasi funcs memo)) - ((= '!= (.prim_comb_sym c)) (array (bor (<< (- k_neq k_len) 35) (<< 1 4) #b0001) datasi funcs memo)) - ((= '= (.prim_comb_sym c)) (array (bor (<< (- k_eq k_len) 35) (<< 1 4) #b0001) datasi funcs memo)) - ((= '% (.prim_comb_sym c)) (array (bor (<< (- k_mod k_len) 35) (<< 1 4) #b0001) datasi funcs memo)) - ((= '/ (.prim_comb_sym c)) (array (bor (<< (- k_div k_len) 35) (<< 1 4) #b0001) datasi funcs memo)) - ((= '* (.prim_comb_sym c)) (array (bor (<< (- k_mul k_len) 35) (<< 1 4) #b0001) datasi funcs memo)) - ((= '+ (.prim_comb_sym c)) (array (bor (<< (- k_add k_len) 35) (<< 1 4) #b0001) datasi funcs memo)) - ((= '- (.prim_comb_sym c)) (array (bor (<< (- k_sub k_len) 35) (<< 1 4) #b0001) datasi funcs memo)) - ((= '& (.prim_comb_sym c)) (array (bor (<< (- k_band k_len) 35) (<< 1 4) #b0001) datasi funcs memo)) - ((= 'bor (.prim_comb_sym c)) (array (bor (<< (- k_bor k_len) 35) (<< 1 4) #b0001) datasi funcs memo)) - ((= '<< (.prim_comb_sym c)) (array (bor (<< (- k_ls k_len) 35) (<< 1 4) #b0001) datasi funcs memo)) - ((= '>> (.prim_comb_sym c)) (array (bor (<< (- k_rs k_len) 35) (<< 1 4) #b0001) datasi funcs memo)) - ((= 'concat (.prim_comb_sym c)) (array (bor (<< (- k_concat k_len) 35) (<< 1 4) #b0001) datasi funcs memo)) - ((= 'slice (.prim_comb_sym c)) (array (bor (<< (- k_slice k_len) 35) (<< 1 4) #b0001) datasi funcs memo)) - ((= 'idx (.prim_comb_sym c)) (array (bor (<< (- k_idx k_len) 35) (<< 1 4) #b0001) datasi funcs memo)) - ((= 'array (.prim_comb_sym c)) (array (bor (<< (- k_array k_len) 35) (<< 1 4) #b0001) datasi funcs memo)) - ((= 'arrayp (.prim_comb_sym c)) (array (bor (<< (- k_arrayp k_len) 35) (<< 1 4) #b0001) datasi funcs memo)) - ((= 'get-text (.prim_comb_sym c)) (array (bor (<< (- k_get-text k_len) 35) (<< 1 4) #b0001) datasi funcs memo)) - ((= 'str-to-symbol (.prim_comb_sym c)) (array (bor (<< (- k_str-to-symbol k_len) 35) (<< 1 4) #b0001) datasi funcs memo)) - ((= 'bool? (.prim_comb_sym c)) (array (bor (<< (- k_bool? k_len) 35) (<< 1 4) #b0001) datasi funcs memo)) - ((= 'nil? (.prim_comb_sym c)) (array (bor (<< (- k_nil? k_len) 35) (<< 1 4) #b0001) datasi funcs memo)) - ((= 'envp (.prim_comb_sym c)) (array (bor (<< (- k_env? k_len) 35) (<< 1 4) #b0001) datasi funcs memo)) - ((= 'combinerp (.prim_comb_sym c)) (array (bor (<< (- k_combiner? k_len) 35) (<< 1 4) #b0001) datasi funcs memo)) - ((= 'string? (.prim_comb_sym c)) (array (bor (<< (- k_string? k_len) 35) (<< 1 4) #b0001) datasi funcs memo)) - ((= 'int? (.prim_comb_sym c)) (array (bor (<< (- k_int? k_len) 35) (<< 1 4) #b0001) datasi funcs memo)) - ((= 'symbol? (.prim_comb_sym c)) (array (bor (<< (- k_symbol? k_len) 35) (<< 1 4) #b0001) datasi funcs memo)) - ((= 'eval (.prim_comb_sym c)) (array (bor (<< (- k_eval k_len) 35) (<< 1 4) #b0001) datasi funcs memo)) - ((= 'unwrap (.prim_comb_sym c)) (array (bor (<< (- k_unwrap k_len) 35) (<< 1 4) #b0001) datasi funcs memo)) - ((= 'wrap (.prim_comb_sym c)) (array (bor (<< (- k_wrap k_len) 35) (<< 1 4) #b0001) datasi funcs memo)) + ((prim_comb? c) (cond ((= 'vau (.prim_comb_sym c)) (array (bor (<< (- k_vau dyn_start) 35) (<< 0 4) #b0001) datasi funcs memo)) + ((= 'cond (.prim_comb_sym c)) (array (bor (<< (- k_cond dyn_start) 35) (<< 0 4) #b0001) datasi funcs memo)) + ((= 'or (.prim_comb_sym c)) (array (bor (<< (- k_or dyn_start) 35) (<< 0 4) #b0001) datasi funcs memo)) + ((= 'and (.prim_comb_sym c)) (array (bor (<< (- k_and dyn_start) 35) (<< 0 4) #b0001) datasi funcs memo)) + ((= 'len (.prim_comb_sym c)) (array (bor (<< (- dyn_start dyn_start) 35) (<< 1 4) #b0001) datasi funcs memo)) + ((= 'read-string (.prim_comb_sym c)) (array (bor (<< (- k_read-string dyn_start) 35) (<< 1 4) #b0001) datasi funcs memo)) + ((= 'log (.prim_comb_sym c)) (array (bor (<< (- k_log dyn_start) 35) (<< 1 4) #b0001) datasi funcs memo)) + ((= 'error (.prim_comb_sym c)) (array (bor (<< (- k_error dyn_start) 35) (<< 1 4) #b0001) datasi funcs memo)) + ((= 'str (.prim_comb_sym c)) (array (bor (<< (- k_str dyn_start) 35) (<< 1 4) #b0001) datasi funcs memo)) + ((= '>= (.prim_comb_sym c)) (array (bor (<< (- k_geq dyn_start) 35) (<< 1 4) #b0001) datasi funcs memo)) + ((= '> (.prim_comb_sym c)) (array (bor (<< (- k_gt dyn_start) 35) (<< 1 4) #b0001) datasi funcs memo)) + ((= '<= (.prim_comb_sym c)) (array (bor (<< (- k_leq dyn_start) 35) (<< 1 4) #b0001) datasi funcs memo)) + ((= '< (.prim_comb_sym c)) (array (bor (<< (- k_lt dyn_start) 35) (<< 1 4) #b0001) datasi funcs memo)) + ((= '!= (.prim_comb_sym c)) (array (bor (<< (- k_neq dyn_start) 35) (<< 1 4) #b0001) datasi funcs memo)) + ((= '= (.prim_comb_sym c)) (array (bor (<< (- k_eq dyn_start) 35) (<< 1 4) #b0001) datasi funcs memo)) + ((= '% (.prim_comb_sym c)) (array (bor (<< (- k_mod dyn_start) 35) (<< 1 4) #b0001) datasi funcs memo)) + ((= '/ (.prim_comb_sym c)) (array (bor (<< (- k_div dyn_start) 35) (<< 1 4) #b0001) datasi funcs memo)) + ((= '* (.prim_comb_sym c)) (array (bor (<< (- k_mul dyn_start) 35) (<< 1 4) #b0001) datasi funcs memo)) + ((= '+ (.prim_comb_sym c)) (array (bor (<< (- k_add dyn_start) 35) (<< 1 4) #b0001) datasi funcs memo)) + ((= '- (.prim_comb_sym c)) (array (bor (<< (- k_sub dyn_start) 35) (<< 1 4) #b0001) datasi funcs memo)) + ((= '& (.prim_comb_sym c)) (array (bor (<< (- k_band dyn_start) 35) (<< 1 4) #b0001) datasi funcs memo)) + ((= 'bor (.prim_comb_sym c)) (array (bor (<< (- k_bor dyn_start) 35) (<< 1 4) #b0001) datasi funcs memo)) + ((= '<< (.prim_comb_sym c)) (array (bor (<< (- k_ls dyn_start) 35) (<< 1 4) #b0001) datasi funcs memo)) + ((= '>> (.prim_comb_sym c)) (array (bor (<< (- k_rs dyn_start) 35) (<< 1 4) #b0001) datasi funcs memo)) + ((= 'concat (.prim_comb_sym c)) (array (bor (<< (- k_concat dyn_start) 35) (<< 1 4) #b0001) datasi funcs memo)) + ((= 'slice (.prim_comb_sym c)) (array (bor (<< (- k_slice dyn_start) 35) (<< 1 4) #b0001) datasi funcs memo)) + ((= 'idx (.prim_comb_sym c)) (array (bor (<< (- k_idx dyn_start) 35) (<< 1 4) #b0001) datasi funcs memo)) + ((= 'array (.prim_comb_sym c)) (array (bor (<< (- k_array dyn_start) 35) (<< 1 4) #b0001) datasi funcs memo)) + ((= 'arrayp (.prim_comb_sym c)) (array (bor (<< (- k_array? dyn_start) 35) (<< 1 4) #b0001) datasi funcs memo)) + ((= 'get-text (.prim_comb_sym c)) (array (bor (<< (- k_get-text dyn_start) 35) (<< 1 4) #b0001) datasi funcs memo)) + ((= 'str-to-symbol (.prim_comb_sym c)) (array (bor (<< (- k_str-to-symbol dyn_start) 35) (<< 1 4) #b0001) datasi funcs memo)) + ((= 'bool? (.prim_comb_sym c)) (array (bor (<< (- k_bool? dyn_start) 35) (<< 1 4) #b0001) datasi funcs memo)) + ((= 'nil? (.prim_comb_sym c)) (array (bor (<< (- k_nil? dyn_start) 35) (<< 1 4) #b0001) datasi funcs memo)) + ((= 'envp (.prim_comb_sym c)) (array (bor (<< (- k_env? dyn_start) 35) (<< 1 4) #b0001) datasi funcs memo)) + ((= 'combinerp (.prim_comb_sym c)) (array (bor (<< (- k_combiner? dyn_start) 35) (<< 1 4) #b0001) datasi funcs memo)) + ((= 'string? (.prim_comb_sym c)) (array (bor (<< (- k_string? dyn_start) 35) (<< 1 4) #b0001) datasi funcs memo)) + ((= 'int? (.prim_comb_sym c)) (array (bor (<< (- k_int? dyn_start) 35) (<< 1 4) #b0001) datasi funcs memo)) + ((= 'symbol? (.prim_comb_sym c)) (array (bor (<< (- k_symbol? dyn_start) 35) (<< 1 4) #b0001) datasi funcs memo)) + ((= 'eval (.prim_comb_sym c)) (array (bor (<< (- k_eval dyn_start) 35) (<< 1 4) #b0001) datasi funcs memo)) + ((= 'unwrap (.prim_comb_sym c)) (array (bor (<< (- k_unwrap dyn_start) 35) (<< 1 4) #b0001) datasi funcs memo)) + ((= 'wrap (.prim_comb_sym c)) (array (bor (<< (- k_wrap dyn_start) 35) (<< 1 4) #b0001) datasi funcs memo)) (true (error (str "Can't compile prim comb " (.prim_comb_sym c) " right now"))))) ((comb? c) (or (get_passthrough (.hash c) datasi funcs memo) (dlet ( ((wrap_level de? se variadic params body) (.comb c)) @@ -1979,17 +2103,7 @@ ((and (prim_comb? func_value) (= (.prim_comb_sym func_value) 'cond)) (array ((rec-lambda recurse (codes i) (cond ((< i (- (len codes) 1)) (_if '_cond_flat '(result i64) - (i64.ne (i64.const #b01) - ; 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 - (i64.and (i64.const -29) - (idx codes i))) + (truthy_test (idx codes i)) (then (idx codes (+ i 1))) (else (recurse codes (+ i 2))) )) @@ -2103,7 +2217,7 @@ (concat setup_code inner_code end_code) )) (funcs (concat funcs our_func)) - (our_func_idx (- (len funcs) k_len -1)) + (our_func_idx (- (len funcs) dyn_start -1)) ; also insert env here (result (bor (<< our_func_idx 35) located_env_ptr (<< wrap_level 4) #b0001)) (memo (put memo (.hash c) result)) @@ -2116,7 +2230,7 @@ ((exit_val datasi funcs memo) (compile_value datasi funcs memo (marked_symbol true 'exit))) ((read_val datasi funcs memo) (compile_value datasi funcs memo (marked_symbol true 'read))) ((write_val datasi funcs memo) (compile_value datasi funcs memo (marked_symbol true 'write))) - ((error_msg_val datasi funcs memo) (compile_value datasi funcs memo (marked_val "Not a legal monad ( ['read fd len ] / ['write fd data ] / ['exit exit_code])"))) + ((monad_error_msg_val datasi funcs memo) (compile_value datasi funcs memo (marked_val "Not a legal monad ( ['read fd len ] / ['write fd data ] / ['exit exit_code])"))) ((bad_read_val datasi funcs memo) (compile_value datasi funcs memo (marked_val ""))) ((exit_msg_val datasi funcs memo) (compile_value datasi funcs memo (marked_val "Exiting with code:"))) ((root_marked_env_val datasi funcs memo) (compile_value datasi funcs memo root_marked_env)) @@ -2254,7 +2368,7 @@ ) ) ; print error - (call '$print (i64.const error_msg_val)) + (call '$print (i64.const monad_error_msg_val)) (call '$print (local.get '$it)) ) (call '$drop (local.get '$it)) @@ -2264,7 +2378,7 @@ (global '$data_end '(mut i32) (i32.const watermark)) datas funcs start (table '$tab (len funcs) 'funcref) - (apply elem (cons (i32.const 0) (range k_len (+ 2 (len funcs))))) + (apply elem (cons (i32.const 0) (range dyn_start (+ 2 (len funcs))))) )) (export "memory" '(memory $mem)) (export "_start" '(func $start)) @@ -2514,7 +2628,20 @@ ;(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) (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) (& 1337 written)))")))) + ;;;; Doesn't work because Scheme thinks | is special sigh + ;(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 (& args) args))")))) ;(output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (a & args) a))"))))