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

Much more real match with arrays and unquote, also added unquote to parser and made log return its last argument

Browse Source
This commit is contained in:
Nathan Braswell
2022-05-06 00:35:31 -04:00
parent c3b2a852b7
commit 9bb6104952
2 changed files with 185 additions and 16 deletions
Download Patch File Download Diff File Expand all files Collapse all files

159
matching.kp
View File

@@ -17,21 +17,150 @@
if (vau de (con than & else) (eval (array cond con than if (vau de (con than & else) (eval (array cond con than
true (cond (> (len else) 0) (idx else 0) true (cond (> (len else) 0) (idx else 0)
true false)) de)) true false)) de))
add-dict-to-env (let (helper (rec-lambda recurse (env dict i)
(if (= i (len dict)) env map (lambda (f5 l5)
(recurse (eval (array (array vau '_ (array (idx (idx dict i) 0)) (array (array vau 'inner (array) 'inner) ) ) (idx (idx dict i) 1) ) env) dict (+ i 1))))) (let (helper (rec-lambda recurse (f4 l4 n4 i4)
(lambda (env dict) (helper env dict 0))) (cond (= i4 (len l4)) n4
empty_dict (array) (<= i4 (- (len l4) 4)) (recurse f4 l4 (concat n4 (array
(f4 (idx l4 (+ i4 0)))
(f4 (idx l4 (+ i4 1)))
(f4 (idx l4 (+ i4 2)))
(f4 (idx l4 (+ i4 3)))
)) (+ i4 4))
true (recurse f4 l4 (concat n4 (array (f4 (idx l4 i4)))) (+ i4 1)))))
(helper f5 l5 (array) 0)))
map_i (lambda (f l)
(let (helper (rec-lambda recurse (f l n i)
(cond (= i (len l)) n
(<= i (- (len l) 4)) (recurse f l (concat n (array
(f (+ i 0) (idx l (+ i 0)))
(f (+ i 1) (idx l (+ i 1)))
(f (+ i 2) (idx l (+ i 2)))
(f (+ i 3) (idx l (+ i 3)))
)) (+ i 4))
true (recurse f l (concat n (array (f i (idx l i)))) (+ i 1)))))
(helper f l (array) 0)))
filter_i (lambda (f l)
(let (helper (rec-lambda recurse (f l n i)
(if (= i (len l))
n
(if (f i (idx l i)) (recurse f l (concat n (array (idx l i))) (+ i 1))
(recurse f l n (+ i 1))))))
(helper f l (array) 0)))
filter (lambda (f l) (filter_i (lambda (i x) (f x)) l))
; Huge thanks to Oleg Kiselyov for his fantastic website
; http://okmij.org/ftp/Computation/fixed-point-combinators.html
Y* (lambda (& l)
((lambda (u) (u u))
(lambda (p)
(map (lambda (li) (lambda (& x) (lapply (lapply li (p p)) x))) l))))
vY* (lambda (& l)
((lambda (u) (u u))
(lambda (p)
(map (lambda (li) (vau ide (& x) (vapply (lapply li (p p)) x ide))) l))))
let-rec (vau de (name_func body)
(let (names (filter_i (lambda (i x) (= 0 (% i 2))) name_func)
funcs (filter_i (lambda (i x) (= 1 (% i 2))) name_func)
overwrite_name (idx name_func (- (len name_func) 2)))
(eval (array let (concat (array overwrite_name (concat (array Y*) (map (lambda (f) (array lambda names f)) funcs)))
(lapply concat (map_i (lambda (i n) (array n (array idx overwrite_name i))) names)))
body) de)))
let-vrec (vau de (name_func body)
(let (names (filter_i (lambda (i x) (= 0 (% i 2))) name_func)
funcs (filter_i (lambda (i x) (= 1 (% i 2))) name_func)
overwrite_name (idx name_func (- (len name_func) 2)))
(eval (array let (concat (array overwrite_name (concat (array vY*) (map (lambda (f) (array lambda names f)) funcs)))
(lapply concat (map_i (lambda (i n) (array n (array idx overwrite_name i))) names)))
body) de)))
flat_map (lambda (f l)
(let (helper (rec-lambda recurse (f l n i)
(if (= i (len l))
n
(recurse f l (concat n (f (idx l i))) (+ i 1)))))
(helper f l (array) 0)))
flat_map_i (lambda (f l)
(let (helper (rec-lambda recurse (f l n i)
(if (= i (len l))
n
(recurse f l (concat n (f i (idx l i))) (+ i 1)))))
(helper f l (array) 0)))
; with all this, we make a destrucutring-capable let
let (let (
destructure_helper (rec-lambda recurse (vs i r)
(cond (= (len vs) i) r
(array? (idx vs i)) (let (bad_sym (str-to-symbol (str (idx vs i)))
new_vs (flat_map_i (lambda (i x) (array x (array idx bad_sym i))) (idx vs i))
)
(recurse (concat new_vs (slice vs (+ i 2) -1)) 0 (concat r (array bad_sym (idx vs (+ i 1))))))
true (recurse vs (+ i 2) (concat r (slice vs i (+ i 2))))
))) (vau de (vs b) (vapply let (array (destructure_helper vs 0 (array)) b) de)))
; and a destructuring-capable lambda!
only_symbols (rec-lambda recurse (a i) (cond (= i (len a)) true
(symbol? (idx a i)) (recurse a (+ i 1))
true false))
; Note that if macro_helper is inlined, the mapping lambdas will close over
; se, and then not be able to be taken in as values to the maps, and the vau
; will fail to partially evaluate away.
lambda (let (macro_helper (lambda (p b) (let (
sym_params (map (lambda (param) (if (symbol? param) param
(str-to-symbol (str param)))) p)
body (array let (flat_map_i (lambda (i x) (array (idx p i) x)) sym_params) b)
) (array vau sym_params body))))
(vau se (p b) (if (only_symbols p 0) (vapply lambda (array p b) se)
(wrap (eval (macro_helper p b) se)))))
; and rec-lambda - yes it's the same definition again
rec-lambda (vau se (n p b) (eval (array Y (array lambda (array n) (array lambda p b))) se))
nil (array) nil (array)
put (lambda (m k v) (cons (array k v) m)) not (lambda (x) (if x false true))
or (let (macro_helper (rec-lambda recurse (bs i) (cond (= i (len bs)) false
(= (+ 1 i) (len bs)) (idx bs i)
true (array let (array 'tmp (idx bs i)) (array if 'tmp 'tmp (recurse bs (+ i 1)))))))
(vau se (& bs) (eval (macro_helper bs 0) se)))
and (let (macro_helper (rec-lambda recurse (bs i) (cond (= i (len bs)) true
(= (+ 1 i) (len bs)) (idx bs i)
true (array let (array 'tmp (idx bs i)) (array if 'tmp (recurse bs (+ i 1)) 'tmp)))))
(vau se (& bs) (eval (macro_helper bs 0) se)))
foldl (let (helper (rec-lambda recurse (f z vs i) (if (= i (len (idx vs 0))) z
(recurse f (lapply f (cons z (map (lambda (x) (idx x i)) vs))) vs (+ i 1)))))
(lambda (f z & vs) (helper f z vs 0)))
foldr (let (helper (rec-lambda recurse (f z vs i) (if (= i (len (idx vs 0))) z
(lapply f (cons (recurse f z vs (+ i 1)) (map (lambda (x) (idx x i)) vs))))))
(lambda (f z & vs) (helper f z vs 0)))
reverse (lambda (x) (foldl (lambda (acc i) (cons i acc)) (array) x))
zip (lambda (& xs) (lapply foldr (concat (array (lambda (a & ys) (cons ys a)) (array)) xs)))
match (let ( match (let (
evaluate_case (rec-lambda recurse (x_symbol c b) (cond evaluate_case (rec-lambda evaluate_case (access c) (cond
(symbol? c) (array true (array let (array c x_symbol) b)) (symbol? c) (array true (lambda (b) (array let (array c access) b)))
(array? c) (array true (array error "unimpl match")) (and (array? c) (= 2 (len c)) (= 'unquote (idx c 0))) (array (array = access (idx c 1)) (lambda (b) b))
true (array (array = x_symbol c) b) (array? c) (let (
tests (array and (array array? access) (array = (len c) (array len access)))
(tests body_func) ((rec-lambda recurse (tests body_func i) (if (= i (len c))
(array tests body_func)
(let ( (inner_test inner_body_func) (evaluate_case (array idx access i) (idx c i)) )
(recurse (concat tests (array inner_test))
(lambda (b) (body_func (inner_body_func b)))
(+ i 1)))))
tests (lambda (b) b) 0)
) (array tests body_func))
true (array (array = access c) (lambda (b) b))
)) ))
helper (rec-lambda helper (x_sym cases i) (cond (< i (- (len cases) 1)) (concat (evaluate_case x_sym (idx cases i) (idx cases (+ i 1))) (helper x_sym cases (+ i 2))) helper (rec-lambda helper (x_sym cases i) (cond (< i (- (len cases) 1)) (let ( (test body_func) (evaluate_case x_sym (idx cases i)) )
(concat (array test (body_func (idx cases (+ i 1)))) (helper x_sym cases (+ i 2))))
true (array true (array error "none matched")))) true (array true (array error "none matched"))))
) (vau de (x & cases) (eval (array let (array '___MATCH_SYM x) (concat (array cond) (helper '___MATCH_SYM cases 0))) de))) ) (vau de (x & cases) (eval (array let (array '___MATCH_SYM x) (concat (array cond) (helper '___MATCH_SYM cases 0))) de)))
@@ -42,10 +171,14 @@
) )
monad (array 'write 1 (str "enter number to fact: " match_result1) (vau (written code) monad (array 'write 1 (str "enter number to fact: " match_result1 " ") (vau (written code)
(array 'read 0 60 (vau (data code) (array 'read 0 60 (vau (data code)
(array 'exit (match (read-string data) (array 'exit (match (read-string data)
1 false 1 "one"
,match_result1 383838
(1 b) (+ 1337 b)
(,match_result1 b) (+ 2337 b)
(a b) (+ a b)
a (+ a 13) a (+ a 13)
)) ))
)) ))

40
partial_eval.scm
View File

@@ -1812,6 +1812,8 @@
((quote_sym_loc quote_sym_length datasi) (alloc_data "quote" datasi)) ((quote_sym_loc quote_sym_length datasi) (alloc_data "quote" datasi))
(quote_sym_val (bor (<< quote_sym_length 32) quote_sym_loc #b111)) (quote_sym_val (bor (<< quote_sym_length 32) quote_sym_loc #b111))
((unquote_sym_loc unquote_sym_length datasi) (alloc_data "unquote" datasi))
(unquote_sym_val (bor (<< unquote_sym_length 32) unquote_sym_loc #b111))
; 0 is path_open, 1 is fd_read, 2 is fd_write ; 0 is path_open, 1 is fd_read, 2 is fd_write
;(num_pre_functions 2) ;(num_pre_functions 2)
@@ -2504,12 +2506,21 @@
((k_log_loc k_log_length datasi) (alloc_data "k_log" datasi)) ((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_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) ((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) '(local $ptr i32) '(local $len i32)
set_len_ptr
(call '$print (i64.const log_msg_val)) (call '$print (i64.const log_msg_val))
(call '$print (local.get '$p)) (call '$print (local.get '$p))
(call '$print (i64.const newline_msg_val)) (call '$print (i64.const newline_msg_val))
drop_p_d (_if '$no_params '(result i64)
(i32.eqz (local.get '$len))
(then
(i64.const nil_val) (i64.const nil_val)
)
(else
(call '$dup (i64.load (i32.add (local.get '$ptr) (i32.sub (local.get '$len) (i32.const 1)))))
)
)
drop_p_d
)))) ))))
((func_idx funcs) (array (+ 1 func_idx) (concat funcs (func '$dummy '(result i64) (i64.const 0))))) ((func_idx funcs) (array (+ 1 func_idx) (concat funcs (func '$dummy '(result i64) (i64.const 0)))))
((k_error_loc k_error_length datasi) (alloc_data "k_error" datasi)) ((k_error_loc k_error_length datasi) (alloc_data "k_error" datasi))
@@ -3640,6 +3651,31 @@
(br '$b1) (br '$b1)
) )
) )
(_if '$is_unquote
(i32.eq (local.get '$tmp) (i32.const #x2C))
(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 unquote_sym_val) (local.get '$sub_result)))
(br '$b1)
)
)
; symbol ; symbol
(_if '$is_dash_and_more (_if '$is_dash_and_more