diff --git a/k_prime.krak b/k_prime.krak index f9630f4..1d6f1a1 100644 --- a/k_prime.krak +++ b/k_prime.krak @@ -1312,6 +1312,7 @@ fun main(argc: int, argv: **char): int { return make_pair(null(), KPResult::Ok(kpString(get_line(params[0].get_string(), 1024)))) } })); + env->set(str("empty_env"), kpEnv(new()->construct())) // Launch into new kraken for interface and self-hosting features var params = vec() diff --git a/prelude.kp b/prelude.kp index 3ccf2cc..793dd39 100644 --- a/prelude.kp +++ b/prelude.kp @@ -11,8 +11,9 @@ (let1 do (vau se (& s) (do_helper do_helper s 0 se)) (let1 current-env (vau de () de) -(let1 lapply (lambda (f p) (eval (concat (array (unwrap f)) p) (current-env))) -(let1 vapply (lambda (f p ede) (eval (concat (array f) p) ede)) +(let1 cons (lambda (h t) (concat (array h) t)) +(let1 lapply (lambda (f p) (eval (cons (unwrap f) p) (current-env))) +(let1 vapply (lambda (f p ede) (eval (cons f p) ede)) (let1 Y (lambda (f) ((lambda (x) (x x)) (lambda (x) (f (lambda (& y) (lapply (x x) y)))))) @@ -168,7 +169,7 @@ let-vrec do if - concat + cons map map_i flat_map @@ -234,7 +235,7 @@ ) ) ) -))))))))) ; end of all the let1's +)))))))))) ; end of all the let1's ; impl of let1 )) (vau de (s v b) (eval (array (array vau (quote _) (array s) b) (eval v de)) de))) diff --git a/types.kp b/types.kp index f252b7c..199d898 100644 --- a/types.kp +++ b/types.kp @@ -1,33 +1,75 @@ (let ( - check_and_erase (lambda (x type) - (let (xe (x) - xt (meta xe)) - (if (= type xt) xe (println "\n\nType error, expected" type "but got" xt "\n\n"))) + ; First quick lookup function, since maps are not built in + lookup (let (lookup-helper (rec-lambda recurse (dict key i) (if (>= i (len dict)) + nil + (if (= key (idx (idx dict i) 0)) + (idx (idx dict i) 1) + (recurse dict key (+ i 1)))))) + (lambda (dict key) (lookup-helper dict key 0))) + + with_type (lambda (exp typ) [exp typ]) + get_exp (lambda (et) (idx et 0)) + get_typ (lambda (et) (idx et 1)) + get_ret_typ (lambda (f_typ) (idx f_typ 1)) + types_match (lambda (t1 t2) (= t1 t2)) + + simple_type_com (lambda (exp typ) (lambda (env) (with_type exp typ))) + symbol_type_com (lambda (sym) (lambda (env) (with_type sym (lookup env sym)))) + + parameter_types_match (let (pmth (rec-lambda recurse (l1 l2 i) (cond (= i (len l1)) true + (types_match (idx l1 i) (idx l2 i)) (recurse l1 l2 (+ i 1)) + true false))) + (lambda (f_t pt) (let (fp_t (idx f_t 0)) + (if (= (len fp_t) (len pt)) + (pmth fp_t pt 0) + false)))) + call_type_com (lambda (innards) + (lambda (env) + (if (= 0 (len innards)) (error "stlc_error: Can't have a 0-length call") + (let ( + f_et ((idx innards 0) env) + f_e (get_exp f_et) + f_t (get_typ f_et) + p_et (map (lambda (x) (x env)) (slice innards 1 -1)) + p_e (map get_exp p_et) + p_t (map get_typ p_et) + ) (if (parameter_types_match f_t p_t) + (with_type (cons f_e p_e) (get_ret_typ f_t)) + (error (str "Function type (" f_t ") does not match parameter types (" p_t ")")) + ) + ) + ) + ) ) - add_one_impl (lambda (x) (+ x 1)) - - stlc [ - - [ 'WS [ "( | | -|(;[ -~]* -))+"] (lambda (x) nil)] - - [ 'stlc_expr '("-?[0-9]+") (lambda (x) (lambda () (with-meta (read-string x) 'int))) ] - [ 'stlc_expr '("plus") (lambda (x) (lambda () (with-meta + '(int int int)))) ] - [ 'stlc_expr '("call" WS stlc_expr WS stlc_expr WS stlc_expr) - (lambda (_ _ c _ a _ b) (lambda () - (let ( - ae (check_and_erase a 'int) - be (check_and_erase b 'int) - ce (check_and_erase c '(int int int)) - ) - (with-meta [ce ae be] 'int) - ))) ] - [ 'stlc '(stlc_expr) (lambda (x) (check_and_erase x 'int)) ] + base_env [ + [ '+ [['int 'int] 'int] ] + [ '- [['int 'int] 'int] ] + [ '< [['int 'int] 'bool] ] + [ '> [['int 'int] 'bool] ] + [ 'println [['str] 'nil] ] ] + current_env (vau de () de) + syms (map (lambda (x) (idx x 0)) base_env) + builtin_real_env (eval (concat (vapply provide syms root_env) [[current_env]]) empty_env) - our_expr "call plus 13 20" -) - (println "\n\nExpr evaluates to" (eval (read-string our_expr stlc 'stlc)) "\n") + stlc (concat basic_rules [ + + [ 'expr [ 'number ] (lambda (x) (simple_type_com x 'int)) ] + [ 'expr [ 'string ] (lambda (x) (simple_type_com x 'str)) ] + [ 'expr [ 'bool_nil_symbol ] (lambda (x) (cond (= x true) (simple_type_com x 'bool) + (= x false) (simple_type_com x 'bool) + (= x nil) (simple_type_com x 'nil) + true (symbol_type_com x) + ) + ) ] + + [ 'call_innards [ 'WS * ] (lambda (_) []) ] + [ 'call_innards [ 'expr [ 'WS 'expr ] * ] (lambda (f r) (cons f (map (lambda (x) (idx x 1)) r))) ] + [ 'form [ "\\(" 'call_innards "\\)" ] (lambda (_ innards _) (call_type_com innards)) ] + + [ 'stlc_start_symbol [ 'WS * 'form 'WS * ] (lambda (_ e _) [eval (get_exp (e base_env)) builtin_real_env]) ] + + ])) + (provide stlc) ) diff --git a/types_test.kp b/types_test.kp new file mode 100644 index 0000000..fc5d8c5 --- /dev/null +++ b/types_test.kp @@ -0,0 +1,2 @@ +#lang (with_import "./types.kp" stlc) stlc_start_symbol +(+ 1 2)