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

Finally make a clean sweep and delete / organize old files. Add skeleton for LaTeX formal writeup in doc/ and change license (since this is all new code from the past few years) to BSD-2-Clause-Patent

Browse Source
This commit is contained in:
Nathan Braswell
2022-01-30 16:57:21 -05:00
parent 315ae20698
commit 7f220c97b8
325 changed files with 901 additions and 31024 deletions
Download Patch File Download Diff File Expand all files Collapse all files

52
working_files/bf.kp Normal file
View File

@@ -0,0 +1,52 @@
(load-file "./k_prime_stdlib/prelude.kp")
; We don't have atoms built in, mutable arrays
; are our base building block. In order to make the
; following BF implementation nice, let's add atoms!
; They will be implmented as length 1 arrays with nice syntax for deref
(fun make-atom (x) [x])
(fun set-atom! (x y) (set-idx! x 0 y))
(fun get-atom (x) (idx x 0))
(add_grammar_rule 'form ["@" 'form] (lambda (_ x) `(get-atom ~x)))
; Now begin by defining our BF syntax & semantics
; Define our tokens as BF atoms
(add_grammar_rule 'bfs_atom ["<"] (lambda (_) '(set-atom! cursor (- @cursor 1))))
(add_grammar_rule 'bfs_atom [">"] (lambda (_) '(set-atom! cursor (+ @cursor 1))))
(add_grammar_rule 'bfs_atom ["\\+"] (lambda (_) '(set-idx! tape @cursor (+ (idx tape @cursor) 1))))
(add_grammar_rule 'bfs_atom ["-"] (lambda (_) '(set-idx! tape @cursor (- (idx tape @cursor) 1))))
(add_grammar_rule 'bfs_atom [","] (lambda (_) '(let (value (idx input @inptr))
(do (set-atom! inptr (+ 1 @inptr))
(set-idx! tape @cursor value)))))
(add_grammar_rule 'bfs_atom ["."] (lambda (_) '(set-atom! output (concat [(idx tape @cursor)] @output))))
; Define strings of BF atoms
(add_grammar_rule 'bfs ['bfs_atom *] (lambda (x) x))
; Add loop as an atom
; (note that closure cannot yet close over itself by value, so we pass it in)
(add_grammar_rule 'bfs_atom ["\\[" 'bfs "]"] (lambda (_ x _)
`(let (f (lambda (f)
(if (= 0 (idx tape @cursor))
nil
(do ,x (f f)))))
(f f))))
; For now, stick BFS rule inside an unambigious BFS block
; Also add setup code
(add_grammar_rule 'form ["bf" 'optional_WS "{" 'optional_WS 'bfs 'optional_WS "}"]
(lambda (_ _ _ _ x _ _)
`(lambda (input)
(let (
tape (array 0 0 0 0 0)
cursor (make-atom 0)
inptr (make-atom 0)
output (make-atom (array))
)
(do (println "beginning bfs") ,x (idx output 0))))))
; Let's try it out! This BF program prints the input 3 times
(println (bf { ,>+++[<.>-] } [1337]))
; we can also have it compile into our main program
(fun main () (do (println "BF: " (bf { ,>+++[<.>-] } [1337])) 0))

27
working_files/collections.kp Normal file
View File

@@ -0,0 +1,27 @@
(let (
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)) [] x))
zip (lambda (& xs) (lapply foldr (concat [(lambda (a & ys) (cons ys a)) []] xs)))
empty_dict []
put (lambda (m k v) (cons [k v] m))
get-value-helper (rec-lambda recurse (dict key i) (if (>= i (len dict))
(error (str key " not found in " dict))
(if (= key (idx (idx dict i) 0))
(idx (idx dict i) 1)
(recurse dict key (+ i 1)))))
get-value (lambda (dict key) (get-value-helper dict key 0))
add-dict-to-env (let (helper (rec-lambda recurse (env dict i)
(if (= i (len dict)) env
(recurse (eval [ [vau '_ [(idx (idx dict i) 0)] [ [vau 'inner [] 'inner] ] ] (idx (idx dict i) 1) ] env) dict (+ i 1)))))
(lambda (env dict) (helper env dict 0)))
)
(provide foldl foldr reverse zip empty_dict put get-value add-dict-to-env)
)

92
working_files/comp_wasm.kp Normal file
View File

@@ -0,0 +1,92 @@
(with_import "./wasm.kp"
(let (
_ (println "args" *ARGV*)
(_ _ out) (cond (!= (len *ARGV*) 3) (error "wrong number of params to comp_wasm (please provide out)")
true *ARGV*)
_ (println "out" out)
wasm_code
(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)
;(table $tab2 8 16 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 $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))
(start $start)
)
_ (write_file out (wasm_to_binary wasm_code))
return_code 0
) return_code ))

4
working_files/compile_for_web.sh Executable file
View File

@@ -0,0 +1,4 @@
#!/usr/bin/env bash
emcc ./k_prime.krak.c -o k_prime.html --embed-file k_prime_stdlib -s EXPORTED_FUNCTIONS='["_main"]' -s EXTRA_EXPORTED_RUNTIME_METHODS='["ccall", "cwrap"]' -s ERROR_ON_UNDEFINED_SYMBOLS=0
#emcc ./k_prime.krak.c -o k_prime.js -s EXPORTED_FUNCTIONS='["_fun_execute_code_starcharactercolonobkcbk_"]' -s EXTRA_EXPORTED_RUNTIME_METHODS='["ccall", "cwrap"]' -s ERROR_ON_UNDEFINED_SYMBOLS=0

141
working_files/damas_hindley_milner.kp Normal file
View File

@@ -0,0 +1,141 @@
(let (
; 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)))
contains (let (contains-helper (rec-lambda recurse (s x i) (cond (= i (len s)) false
(= x (idx s i)) true
true (recurse s x (+ i 1)))))
(lambda (s x) (contains-helper s x 0)))
applyST (rec-lambda recurse (S t)
(cond
(meta t) (with-meta (recurse (filter (lambda (x) (not (contains (meta t) x))) S) (with-meta t nil)) (meta t))
(int? t) (or (lookup S t) t)
(array? t) (map (lambda (x) (recurse S x)) t)
true t
))
applySE (lambda (S env) (map (lambda (x) [(idx x 0) (applyST S (idx x 1))]) env))
applySS (lambda (S_0 S_1) (let (r (concat S_0 (applySE S_0 S_1)) _ (println "applySS of " S_0 " and " S_1 " is " r)) r))
fvT (rec-lambda recurse (t) (cond (meta t) (filter (lambda (x) (not (contains (meta t) x))) (recurse (with-meta t nil)))
(int? t) [t]
(array? t) (flat_map recurse t)
true []
))
fvE (lambda (env) (flat_map (lambda (x) (fvT (idx x 1))) env))
varBind (lambda (a b) (cond
(= a b) []
(contains (fvT b) a) (error "Contains check failed for " a " and " b)
true [ [a b] ]))
mgu (rec-lambda mgu (a b) (let (r (cond
(and (array? a) (array? b) (= (len a) (len b))) ((rec-lambda recurse (S i) (if (= i (len a)) S
(recurse (applySS (mgu (idx a i) (idx b i)) S) (+ 1 i)))) [] 0)
(int? a) (varBind a b)
(int? b) (varBind b a)
(= a b) []
true (error (str "Cannot unify " a " and " b))
) _ (println "mgu of " a " and " b " is " r)) r))
generalize (lambda (env t) (do (println "generalize " t " with respect to " env) (let (free_T (fvT t)
free_E (fvE env))
(with-meta t (filter (lambda (x) (not (contains free_E x))) free_T)))))
instantiate (lambda (sigma idn) (do (println "instantiate " sigma " meta is " (meta sigma)) [(applyST (map_i (lambda (x i) [x (+ i idn)]) (meta sigma)) (with-meta sigma nil)) (+ idn (len (meta sigma)))]))
execute_type_com (lambda (tc e idn) (tc e idn))
simple_type_com (lambda (exp typ) (lambda (env idn) [exp typ [] idn]))
symbol_type_com (lambda (sym) (lambda (env idn) (let (
(t idn) (instantiate (lookup env sym) idn))
[sym t [] idn])))
call_type_com (lambda (innards)
(lambda (env idn)
(if (= 0 (len innards)) (error "stlc_error: Can't have a 0-length call")
(let (
(f_e f_t S_0 idn) (execute_type_com (idx innards 0) env idn)
across_params (rec-lambda recurse (env S idn params i out_e out_t)
(if (= i (len params)) [out_e out_t S idn]
(let (
(p_e p_t S_i idn) (execute_type_com (idx params i) env idn)
) (recurse (applySE S_i env) (applySS S_i S) idn params (+ 1 i) (concat out_e [p_e]) (concat out_t [p_t])))))
(p_es p_ts S_ps idn) (across_params (applySE S_0 env) [] idn (slice innards 1 -1) 0 [] [])
(r_t idn) [idn (+ 1 idn)]
S_f (mgu (applyST S_ps f_t) [p_ts r_t])
_ (println "mgu of " (applyST S_ps f_t) " and " [p_ts r_t] " produces substitution " S_f)
_ (println "For this call: " (cons f_e p_es) " the return type " r_t " transformed by " S_f " is " (applyST S_f r_t))
) [(cons f_e p_es) (applyST S_f r_t) (applySS S_f (applySS S_ps S_0)) idn])
)
)
)
lambda_type_com (lambda (p t b)
(lambda (env idn)
(let (
(p_t idn) (if (= nil t) [idn (+ 1 idn)]
[t idn])
extended_env (cons [p (with-meta p_t [])] env)
(b_e b_t S idn) (execute_type_com b extended_env idn)
f_e [lambda [p] b_e]
f_t [[ (applyST S p_t) ] b_t]
) [f_e f_t S idn])
)
)
let_type_com (lambda (x e1 e2)
(lambda (env0 idn)
(let (
(e1_e e1_t S_0 idn) (execute_type_com e1 env0 idn)
env1 (applySE S_0 env0)
e1_sigma (generalize env1 e1_t)
extended_env (cons [x e1_sigma] env1)
(e2_e e2_t S_1 idn) (execute_type_com e2 extended_env idn)
l_e [[lambda [x] e2_e] e1_e]
l_t e2_t
) [l_e l_t (applySS S_1 S_0) idn])
)
)
base_env [
[ '+ (with-meta [['int 'int] 'int] []) ]
[ '- (with-meta [['int 'int] 'int] []) ]
[ '< (with-meta [['int 'int] 'bool] []) ]
[ '> (with-meta [['int 'int] 'bool] []) ]
[ 'println (with-meta [['str] 'void] []) ]
]
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)
top-level-erase-and-check (lambda (e) (let (
(e t S idn) (execute_type_com e base_env 0)
_ (println "Type of program is " t " with sub " S)
_ (println "expression code is " e)
) e))
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)
)
) ]
[ 'expr [ "\\\\" 'WS * 'bool_nil_symbol 'WS * ":" 'WS * 'bool_nil_symbol 'WS * "." 'WS * 'expr ] (lambda (_ _ p _ _ _ t _ _ _ b) (lambda_type_com p t b)) ]
[ 'expr [ "\\\\" 'WS * 'bool_nil_symbol 'WS * "." 'WS * 'expr ] (lambda (_ _ p _ _ _ b) (lambda_type_com p nil b)) ]
[ 'expr [ "let" 'WS * 'bool_nil_symbol 'WS * "=" 'WS * 'expr 'WS * "in" 'WS * 'expr ] (lambda (_ _ x _ _ _ e1 _ _ _ e2) (let_type_com x e1 e2)) ]
[ 'call_innards [ 'WS * ] (lambda (_) []) ]
[ 'call_innards [ 'expr [ 'WS 'expr ] * ] (lambda (f r) (cons f (map (lambda (x) (idx x 1)) r))) ]
[ 'expr [ "\\(" 'call_innards "\\)" ] (lambda (_ innards _) (call_type_com innards)) ]
[ 'stlc_start_symbol [ 'WS * 'expr 'WS * ] (lambda (_ e _) [eval (top-level-erase-and-check e) builtin_real_env]) ]
]))
(provide stlc)
)

2
working_files/damas_hindley_milner_test.kp Normal file
View File

@@ -0,0 +1,2 @@
#lang (with_import "./types.kp" stlc) stlc_start_symbol
let id = \ x . x in ((id println) (id "woo"))

20
working_files/dlambda_test.kp Normal file
View File

@@ -0,0 +1,20 @@
(let (
dl1 (lambda ([a b]) (+ a b))
_ (println "dl1 " (dl1 [5 6]))
dl2 (lambda (a [b c]) (+ a b c))
_ (println "dl2 " (dl2 1 [5 6]))
dl3 (lambda ([a b] c) (+ a b c))
_ (println "dl3 " (dl3 [5 6] 2))
dl4 (lambda (a [b c] d) (+ a b c d))
_ (println "dl4 " (dl4 5 [5 6] 4))
dl5 (lambda (a) (+ a 1))
_ (println "dl5 " (dl5 1336))
dl6 (lambda (a b) (+ a b))
_ (println "dl6 " (dl6 1336 12))
dl7 (lambda () (+ 1 1))
_ (println "dl7 " (dl7))
fib (rec-lambda recurse (n [a b]) (if (= 0 n) a
(recurse (- n 1) [b (+ a b)])))
_ (println "fib 5 " (fib 5 [1 1]))
) nil)

51
working_files/even_odd.kp Normal file
View File

@@ -0,0 +1,51 @@
(do
(println "Double")
(let-rec (
even (lambda (n) (cond (= 0 n) true
(= 1 n) false
true (odd (- n 1))))
odd (lambda (n) (cond (= 0 n) false
(= 1 n) true
true (even (- n 1))))
)
(do
(println (even 7))
(println (even 8))
(println (odd 7))
(println (odd 8))
)
)
(println "Triple")
(let-rec (
first (lambda (n) (cond (= 0 n) true
(= 1 n) false
(= 2 n) false
true (third (- n 1))))
second (lambda (n) (cond (= 0 n) false
(= 1 n) true
(= 2 n) false
true (first (- n 1))))
third (lambda (n) (cond (= 0 n) false
(= 1 n) false
(= 2 n) true
true (second (- n 1))))
)
(do
(println)
(println (first 7))
(println (first 8))
(println (first 9))
(println)
(println (second 7))
(println (second 8))
(println (second 9))
(println)
(println (third 7))
(println (third 8))
(println (third 9))
)
)
)

8
working_files/fib-comp.kp Normal file
View File

@@ -0,0 +1,8 @@
(def! fib (fn* (n) (cond (= 0 n) 0
(= 1 n) 1
true (+ (fib (- n 1)) (fib (- n 2))))))
(def! main (fn* ()
(do
(let* (n 27)
(println "Fib(" n "): " (fib n)))
0)))

5
working_files/fib-interp.kp Normal file
View File

@@ -0,0 +1,5 @@
(def! fib (fn* (n) (cond (= 0 n) 0
(= 1 n) 1
true (+ (fib (- n 1)) (fib (- n 2))))))
(let* (n 27)
(println "Fib(" n "): " (fib n)))

96
working_files/fungll.kp Normal file
View File

@@ -0,0 +1,96 @@
(with_import "./collections.kp"
(with_import "./rb.kp"
(let (
; Implementing "Purely Functional GLL Parsing"
; by L. Thomas van Binsbergena, Elizabeth Scott, Adrian Johnstone
; retrived from from http://ltvanbinsbergen.nl/publications/jcola-fgll.pdf
; discriptor is a triple of grammer-slot and 2 indicies of t-string
; corresponding to process
; <X::= a.b,l,k>
; I previously had this as nonterminal, rule-idx, idx into rule, l,r
; U - discriptors added to (worklist?), makes sure no duplicates added to "list"
; P - binary relation between pairs of commencments and right extants
; makes sure that later discoveries that use a sub-non-terminal that has already
; been processed can be completed since the sub-non-terminal won't be
; re-descended at the same index <s::=.d,k,k>
;
; a commencement is a pair of a nonterminal and a left extent (the arguemnts to
; descend, since that's what we're skipping) to a set of right extants
; G - binary relation between commencments and continuations, modified to include
; actional continuation.
; The normal continuation is a pair of as slot and a left extent.
; So <<X,k> -> <g,l>> in G, with a new are is combined to form
; discriptor <g,l,r> and BSR <g,l,k,r> whenever k,r are discovered for X
; Note we haven't finished things with the above P, since some subs of the form
; <s::=.d,k,k> or descriptors that follow them may not have been processed
; yet. When new Right extants are discovered, we must add descriptors
; <Y::=a's.b',l',r_j> and <X::as.b,l,rj> to R (if not in U) and add
; BSR elements <Y::=a's.b',l',k,r_j> and <X::=as.b,l,k,r_j> to Y
; Y - Our result BSR set!
; I've decided, a slot is [X [stff] int-for-dot]
id (lambda (sigma) sigma)
altStart (lambda (t s k c) id)
altOp (lambda (p q) (lambda (t s k c) (lcompose (p t s k c) (q t s [] k c))))
term_parser (lambda (t [X b i] l k c) (lambda (sigma)
(let (this_term (idx b (- i 1))
_ (println "term parser looking for " this_term " at position " k " in " t)
)
(if (and (<= (+ k (len this_term)) (len t)) (= this_term (slice t k (+ k (len this_term))))) ((c [[X b i] l (+ (len this_term) k)]) sigma)
sigma))))
; the extra lambda layer of indirection is so that
; recursive nonterminals can be made with rec-let, which
; only works on functions. So both term types get wrapped in
; an extra function which is evaluated in seqOp and parse
term (lambda (s) (lambda () [ s term_parser ]))
continue (lambda (BSR_element c) (lambda ([U G P Y])
(let (
[slot l k r] BSR_element
descriptor [slot l r]
(X b i) slot
Yp (if (or (!= 0 i) (= (len rhs) i)) (set-insert Y BSR_element)
Y)
Up (set-insert U descriptor)
) (if (set-contains? U descriptor) [U G P Yp]
((c descriptor) [Up G P Yp])))))
seqStart (lambda (t X b l c0) (continue [[X b 0] l l l] c0))
seqOp (lambda (p s_q) (lambda (t X b l c0) (let (
; see term discussion about extra lambda wrap
[s q] (s_q)
c1 (lambda ([[X b i] l k]) (let (
c2 (lambda ([slot l r]) (continue [slot l k r] c0))
) (q t [X b (+ 1 i)] l k c2)))
) (p t X (cons s b) l c1))))
cont_for (lambda (s p) (lambda ([[s d i] k r]) (lambda ([U G P Y]) (let (
composed (set-foldl (lambda (cp [g l c]) (lcompose cp (c [g l r]))) id (multimap-get G [s k]))
) (composed [U G (multimap-insert P [s k] r) Y])))))
nterm_parser (lambda (p) (lambda (t gram_slot l k c) (lambda ([U G P Y])
(let (
[X b i] gram_slot
s (idx b (- i 1))
R (multimap-get P [s k])
sigmap [U (multimap-insert G [s k] [gram_slot l c]) P Y]
) (if (= 0 (size R)) ((p t s k (cont_for s p)) sigmap)
(set-foldl (lambda (cp r) (lcompose cp (c [gram_slot l r]))) id R)
)))))
; see term discussion about extra lambda wrap
nterm (lambda (s p) (lambda () [ s (nterm_parser p) ]))
parse (lambda (s_f) (lambda (t)
(let (
; see term discussion about extra lambda wrap
[s f] (s_f)
X '__FUNGLL_UNIQUE_START_SYMBOL__
sigma [ set-empty multimap-empty multimap-empty set-empty ]
c (lambda (descriptor) (lambda (sigma) sigma))
[U G P Y] ((f t ['X [s] 1] 0 0 c) sigma)
) (set-foldl cons [] Y))))
)
(provide altStart altOp term seqStart seqOp nterm parse)
)))

48
working_files/fungll_test.kp Normal file
View File

@@ -0,0 +1,48 @@
(with_import "./fungll.kp"
(let (
_ (println "The a parser")
just_a_parser (parse (nterm 'A (altOp altStart (seqOp seqStart (term "a")))))
_ (println "parse result for a " (just_a_parser "a"))
_ (println "parse result for b " (just_a_parser "b"))
_ (println "parse result for aa " (just_a_parser "aa"))
_ (println "parse result for ba " (just_a_parser "ba"))
_ (println "parse result for ab " (just_a_parser "ab"))
_ (println "The aa parser")
just_aa_parser (parse (nterm 'A (altOp altStart (seqOp seqStart (term "aa")))))
_ (println "parse result for a " (just_aa_parser "a"))
_ (println "parse result for b " (just_aa_parser "b"))
_ (println "parse result for aa " (just_aa_parser "aa"))
_ (println "parse result for ba " (just_aa_parser "ba"))
_ (println "parse result for ab " (just_aa_parser "ab"))
_ (println "The a.a parser")
just_aa_parser (parse (nterm 'A (altOp altStart (seqOp (seqOp seqStart (term "a")) (term "a")))))
_ (println "parse result for a " (just_aa_parser "a"))
_ (println "parse result for b " (just_aa_parser "b"))
_ (println "parse result for aa " (just_aa_parser "aa"))
_ (println "parse result for ba " (just_aa_parser "ba"))
_ (println "parse result for ab " (just_aa_parser "ab"))
_ (println "The b|a.a parser")
just_aa_parser (parse (nterm 'A (altOp (altOp altStart (seqOp seqStart (term "b"))) (seqOp (seqOp seqStart (term "a")) (term "a")))))
_ (println "parse result for a " (just_aa_parser "a"))
_ (println "parse result for b " (just_aa_parser "b"))
_ (println "parse result for aa " (just_aa_parser "aa"))
_ (println "parse result for ba " (just_aa_parser "ba"))
_ (println "parse result for ab " (just_aa_parser "ab"))
_ (println "The a|a,A parser")
just_aa_parser (let-rec (
As (nterm 'A (altOp (altOp altStart (seqOp seqStart (term "a"))) (seqOp (seqOp (seqOp seqStart (term "a")) (term ",")) As)))
) (parse As))
_ (println "parse result for a " (just_aa_parser "a"))
_ (println "parse result for b " (just_aa_parser "b"))
_ (println "parse result for aa " (just_aa_parser "aa"))
_ (println "parse result for ba " (just_aa_parser "ba"))
_ (println "parse result for ab " (just_aa_parser "ab"))
_ (println "parse result for a,a " (just_aa_parser "a,a"))
_ (println "parse result for a,a,a " (just_aa_parser "a,a,a"))
) nil))

1
working_files/import_test.kp Normal file
View File

@@ -0,0 +1 @@
(let (a 123) (provide a))

425
working_files/index.html Normal file
View File

@@ -0,0 +1,425 @@
<!doctype html>
<html lang="en-us">
<meta charset="UTF-8">
<head>
<style>
h1, h2 ,h3 { line-height:1.2; }
body {
max-width: 45em;
margin: 1em auto;
padding: 0 .62em;
font: 1.2em/1.62 sans-serif;
}
th { text-align: center; }
th, td { padding: 0.5em; }
table, td {
border: 1px solid #333;
text-align: right;
}
thead, tfoot {
background-color: #000;
color: #fff;
}
#hello_editor { height: 7em; width: 70em; }
#hello_output { height: 7em; width: 70em; }
#prelude_editor { height: 54em; width: 70em; }
#prelude_output { height: 7em; width: 70em; }
#method_editor { height: 58em; width: 70em; }
#method_output { height: 7em; width: 70em; }
#bf_editor { height: 67em; width: 70em; }
#bf_output { height: 7em; width: 70em; }
#fib_editor { height: 8em; width: 70em; }
#fib_output { height: 7em; width: 70em; }
</style>
</head>
<body>
<header><h2>Nathan Braswell's Current Programming Language / Compiler Research</h2></header>
Repository: <a title="Kraken on GitHub" href="https://github.com/limvot/kraken">https://github.com/limvot/kraken</a>
<br> <br>
<b>Table of Contents:</b> <i>If you're impatient, jump to the code examples!</i>
<ul>
<li><a href="#concept">Concept</a>
<li><a href="#about">About</a>
<li><a href="#hello_example">Example: Hello World</a>
<li><a href="#vau_core">Vau as a core</a>
<li><a href="#method_example">Example: Implementing Methods</a>
<li><a href="#bf_example">Example: Embedding BF</a>
<li><a href="#next_steps">Next Steps</a>
</ul>
<a name="concept"/>
<h3>Concept:</h3>
<ul>
<li> Minimal, close to the metal Kernel/Scheme (operate on words, bytes, arrays) as AST / core language, with Kernel/Vau calculus inspiration oblivating the need for non-reader macros (<a title="Kernel/Vau calculus thesis" href="https://web.wpi.edu/Pubs/ETD/Available/etd-090110-124904/unrestricted/jshutt.pdf">Kernel/Vau calculus thesis</a>)
<li> Full Context-free (and eventually, context sensitive) reader macros using FUN-GLL (<a title="fun-gll paper" href="https://www.sciencedirect.com/science/article/pii/S2590118420300058">FUN-GLL paper</a>) to extend language's syntax dynamically
<li> Implement Type Systems as Macros (but using Vaus instead of macros) (<a title="type systems as macros paper 1" href="http://www.ccs.neu.edu/home/stchang/pubs/ckg-popl2017.pdf">paper, up to System Fω</a>) (<a title="type systems as macros paper 2" href="https://www.ccs.neu.edu/home/stchang/pubs/cbtb-popl2020.pdf">second paper, up to dependent types</a>)
<li> Use above "type systems as vaus" to create richer language and embed entire other programming languages (syntax, semantics, and type system) for flawless interop/FFI (C, Go, Lua, JS, etc)
<li> File is interpreted, and then if "main" exists it is compiled, spidering backwards to referenced functions and data (Allows interpreted code to do metaprogramming, dependency resolution, generate code, etc, which is then compiled)
<li> Regionalized Value State Dependence Graph as backend-IR, enabling simpler implementations of powerful optimizations (<a title="RSVDG paper" href="https://arxiv.org/pdf/1912.05036.pdf">RSVDG paper</a>) so that embedded languages have good performance when compiled with little code
</ul>
<a name="about"/>
<h3> About:</h3>
<p> Currently, I am bootstrapping this new core Lisp out of my prior compiler for my programming language, Kraken. I have implemented the first version of the FUN-GLL algorithm and have working vaus and context-free reader macros.
<p> The general flow is that the input files will be executed with the core Lisp interpreter, and if there is a "main" symbol defined the compiler emits C code for that function & all other functions & data that it references. In this way the language supports very powerful meta-programming at compile time, including adding syntax to the language, arbitrary computation, and importing other files, and then compiles into a static executable.
<p> Below are a few examples of using the vau / live grammar modification / context-free reader macros to implement basic methods as well as embed the BF language into the core Lisp. The core Lisp implementation has been compiled to WebAssembly and should be able to run in your browser. Feel free to make edits and play around below.
<br>
Note that the current implementation is inefficient, and sometimes has problems running in phone web browsers.
<a name="hello_example"/>
<h4>Runnable Example Code:</h4>
<button onclick="executeKraken(hello_editor.getValue(), 'hello_output')"><b>Run</b></button> <br>
<div id="hello_editor">; Of course
(println "Hello World")
; Just print 3
(println "Math works:" (+ 1 2))
</div>
<h4>Output:</h4>
<textarea id="hello_output">Output will appear here</textarea>
<a name="vau_core"/>
<h4>Vau/Kernel as simple core:</h4>
By constructing our core language on a very simple Vau/Kernel base, we can keep the base truely tiny, and build up normal Lisp functions and programming language features in the language itself. This should help implement other programming languages concisely, and will hopefully make optimization easier and more broadly applicable.
<br>
Below is the current prelude that adds quoting, quasiquoting, syntax for arrays and quoting/quasiquoting, do, if, let, and even lambda itself!
<br>
<button onclick="executeKraken(prelude_editor.getValue(), 'prelude_output')"><b>Run</b></button> <br>
<div id="prelude_editor">
(set! quote (vau _ (x) x))
(set! lambda (vau se (p b) (wrap (eval (array vau (quote _) p b) se))))
(set! current-env (vau de () de))
(set! fun (vau se (n p b) (eval (array set! n (array lambda p b)) se)))
; do_helper is basically mapping eval over statements, but the last one is in TCO position
; a bit of a hack, using cond to sequence (note the repitition of the eval in TCO position if it's last,
; otherwise the same eval in cond position, and wheather or not it returns a truthy value, it recurses in TCO position)
(fun do_helper (s i se) (cond (= i (len s)) nil
(= i (- (len s) 1)) (eval (idx s i) se)
(eval (idx s i) se) (do_helper s (+ i 1) se)
true (do_helper s (+ i 1) se)))
(set! do (vau se (& s) (do_helper s 0 se)))
(fun concat_helper (a1 a2 a3 i) (cond (< i (len a1)) (do (set-idx! a3 i (idx a1 i)) (concat_helper a1 a2 a3 (+ i 1)))
(< i (+ (len a1) (len a2))) (do (set-idx! a3 i (idx a2 (- i (len a1)))) (concat_helper a1 a2 a3 (+ i 1)))
true a3))
(fun concat (a1 a2) (concat_helper a1 a2 (array-with-len (+ (len a1) (len a2))) 0))
(add_grammar_rule (quote form) (quote ( "'" optional_WS form )) (vau de (_ _ f) (array quote (eval f de))))
(add_grammar_rule 'form '( "\\[" optional_WS space_forms optional_WS "\\]" ) (vau de (_ _ fs _ _) (concat (array array) (eval fs de))))
(fun vapply (f p ede) (eval (concat [f] p) ede))
(fun lapply (f p) (eval (concat [(unwrap f)] p) (current-env)))
(set! let1 (vau de (s v b) (eval [[vau '_ [s] b] (eval v de)] de)))
(set! let (vau de (vs b) (cond (= (len vs) 0) (eval b de) true (vapply let1 [(idx vs 0) (idx vs 1) [let (slice vs 2 -1) b]] de))))
(set! if (vau de (con than & else) (cond
(eval con de) (eval than de)
(> (len else) 0) (eval (idx else 0) de)
true nil)))
(fun map (f l)
(let (helper (lambda (f l n i recurse)
(if (= i (len l))
n
(do (set-idx! n i (f (idx l i)))
(recurse f l n (+ i 1) recurse)))))
(helper f l (array-with-len (len l)) 0 helper)))
(fun flat_map (f l)
(let (helper (lambda (f l n i recurse)
(if (= i (len l))
n
(recurse f l (concat n (f (idx l i))) (+ i 1) recurse))))
(helper f l (array) 0 helper)))
(fun map_with_idx (f l)
(let (helper (lambda (f l n i recurse)
(if (= i (len l))
n
(do (set-idx! n i (f i (idx l i)))
(recurse f l n (+ i 1) recurse)))))
(helper f l (array-with-len (len l)) 0 helper)))
(fun print_through (x) (do (println x) x))
(fun is_pair? (x) (and (array? x) (> (len x) 0)))
(set! quasiquote (vau de (x)
(cond (is_pair? x)
(cond (and (symbol? (idx x 0)) (= (get-text (idx x 0)) "unquote"))
(eval (idx x 1) de)
true
(cond (and (is_pair? (idx x 0)) (symbol? (idx (idx x 0) 0)) (= (get-text (idx (idx x 0) 0)) "splice-unquote"))
(concat (eval (idx (idx x 0) 1) de) (vapply quasiquote [(slice x 1 -1)] de))
true
(concat [(vapply quasiquote [(idx x 0)] de)] (vapply quasiquote [(slice x 1 -1)] de))))
true x)))
(add_grammar_rule 'form '("`" optional_WS form) (lambda (_ _ f) ['quasiquote f]))
(add_grammar_rule 'form '("~" optional_WS form) (lambda (_ _ f) ['unquote f]))
(add_grammar_rule 'form '("," optional_WS form) (lambda (_ _ f) ['splice-unquote f]))
(println "now with both array and quasiquote syntax, check out " `(1 2 3 ~(+ 7 8) ,[ 5 6 7]))
</div>
<h4>Output:</h4>
<textarea id="prelude_output">Output will appear here</textarea>
<a name="method_example"/>
<h4>Method Example:</h4>
Let's use our meta system (attaching objects to other objects) to implement basic objects/methods, a new lambda syntax, a new block syntax, and string interpolation!
We will attach a array of alternating symbols / functions (to make this example simple, since maps aren't built in) to our data as the meta, then look up methods on it when we perform a call. The add_grammar_rule function modifies the grammar/parser currently being used to parse the file and operates as a super-powerful reader macro. We use it in this code to add a rule that transforms <pre><code>a.b(c, d)</code></pre> into <pre><code>(method-call a 'b c d)</code></pre> where method-call is the function that looks up the symbol 'b on the meta object attached to a and calls it with the rest of the parameters.
Note also the block ({}) syntax that translates to nested do/let expressions, the nicer lambda syntax, and the string interpolation (that even works nested!).
<br>
<button onclick="executeKraken(method_editor.getValue(), 'method_output')"><b>Run</b></button>
<br>
<div id="method_editor">
; Load prelude so we get fun, lambda, if, quoting, etc
(load-file "./k_prime_stdlib/prelude.kp")
; First quick lookup function, since maps are not built in
(fun get-value-helper (dict key i) (if (>= i (len dict))
nil
(if (= key (idx (idx dict i) 0))
(idx (idx dict i) 1)
(get-value-helper dict key (+ i 1)))))
(fun get-value (dict key) (get-value-helper dict key 0))
; Our actual method call function
(fun method-call (object method & arguments) (let (method_fn (get-value (meta object) method))
(if (= method_fn nil)
(println "no method " method)
(lapply method_fn (concat [object] arguments)))))
; Some nice syntactic sugar for method calls
; No params
(add_grammar_rule 'form ['form "\\." 'atom]
(lambda (o _ m) `(method-call ~o '~m)))
; params
(add_grammar_rule 'form ['form "\\." 'atom 'optional_WS "\\(" 'optional_WS 'space_forms 'optional_WS "\\)"]
(lambda (o _ m _ _ _ p _ _) `(method-call ~o '~m ,p)))
; object creation
(fun make_constructor (members methods)
(eval `(lambda ~members
(with-meta [,members]
[,(map_with_idx (lambda (i x) [array `'~x (lambda (o) (idx o i))]) members)
,(map (lambda (x) [array `'~(idx x 0) (idx x 1)]) methods)]))))
; object syntax
(add_grammar_rule 'form ["obj" 'WS 'atom "\\(" ['optional_WS 'atom] * 'optional_WS "\\)" 'optional_WS "{" 'optional_WS ['atom 'optional_WS 'form 'optional_WS] * "}"] (lambda (_ _ name _ members _ _ _ _ _ methods _)
`(set! ~name (make_constructor [,(map (lambda (x) `'~(idx x 1)) members)]
[,(map (lambda (x) `['~(idx x 0) ~(idx x 2)]) methods)]))))
; Lambda syntax
(add_grammar_rule 'form ["\\|" 'optional_WS [ 'atom 'optional_WS ] * "\\|" 'optional_WS 'form ]
(lambda (_ _ params _ _ body) `(lambda (,(map (lambda (x) (idx x 0)) params)) ~body)))
; {} body translated to do and let
(add_grammar_rule 'block_member [ 'form ] |x| [x])
(add_grammar_rule 'block_member [ "let" 'optional_WS 'atom 'optional_WS "=" 'optional_WS 'form ]
|_ _ name _ _ _ rhs| `(~name ~rhs))
(fun construct_body (is_do current to_add i)
(if (> (len to_add) i)
(cond (and is_do (= (len (idx to_add i)) 1)) (construct_body true (concat current [(idx (idx to_add i) 0)]) to_add (+ i 1))
(= (len (idx to_add i)) 1) (concat current [(construct_body true [do (idx (idx to_add i) 0)] to_add (+ i 1))])
true (concat current [(construct_body false [let [(idx (idx to_add i) 0) (idx (idx to_add i) 1)] ] to_add (+ i 1))]))
current))
(add_grammar_rule 'form ["{" 'optional_WS [ 'block_member 'optional_WS ] * "}"]
|_ _ inner _| (construct_body true [do] (map |x| (idx x 0) inner) 0))
; Call functions with function first, c style (notice no whitespace)
(add_grammar_rule 'form [ 'form 'call_form ] |f ps| (concat [f] ps))
; fun syntax
(add_grammar_rule 'form [ "fun" 'WS 'atom 'optional_WS "\\(" 'optional_WS [ 'atom 'optional_WS ] * "\\)" 'optional_WS 'form ]
|_ _ name _ _ _ params _ _ body| `(fun ~name (,(map |x| (idx x 0) params)) ~body))
; string interpolation
fun remove_dollar(done to_do i j) (cond (>= j (- (len to_do) 2)) (str done (slice to_do i -1))
(= "\\$" (slice to_do j (+ j 2))) (remove_dollar (str done (slice to_do i j) "$") to_do (+ j 2) (+ j 2))
true (remove_dollar done to_do i (+ j 1)))
fun fixup_str_parts(s) (remove_dollar "" (slice s 0 -2) 0 0)
(add_grammar_rule 'form [ "$\"" [ "(#|[%-[]| |[]-~]|(\\\\)|(\\n)|(\\t)|(\\*)|(\\\\$)|
|[ -!]|(\\\\\"))*$" 'form ] * "(#|[%-[]| |[]-~]|(\\\\)|(\\n)|(\\t)|(\\*)|(\\\\$)|
|[ -!]|(\\\\\"))*\"" ]
|_ string_form_pairs end| `(str ,( flat_map |x| [ (fixup_str_parts (idx x 0)) (idx x 1) ] string_form_pairs) ~(fixup_str_parts end)))
(println $"unu |\$| $$"inner $(+ 1 2) post-inner" sual")
obj Point( x y ) {
add |self other| { Point((+ self.x other.x) (+ self.y other.y)) }
sub |self other| { Point((- self.x other.x) (- self.y other.y)) }
to_str |self| { str("x: " self.x ", y: " self.y) }
}
fun say_hi(name) {
println("hayo" name)
}
fun test() {
let plus_1 = |x| (+ x 1)
let a = 1
let b = plus_1(a)
println("some" b)
say_hi("Marcus")
let p1 = Point(1 2)
let p2 = Point(3 4)
let p3 = p1.add(p2)
let p4 = p1.sub(p2)
println("p1:" p1.to_str)
println("p2:" p2.to_str)
println("p3:" p3.to_str)
println("p4:" p4.to_str)
(+ a b)
}
println("Test result is" test())
</div>
<h4>Output: </h4>
<textarea id="method_output">Output will appear here</textarea>
<a name="bf_example"/>
<h4>More Complicated Example: BF as an embedded language</h4>
<button onclick="executeKraken(bf_editor.getValue(), 'bf_output')"><b>Run</b></button> <br>
<div id="bf_editor">
(load-file "./k_prime_stdlib/prelude.kp")
; We don't have atoms built in, mutable arrays
; are our base building block. In order to make the
; following BF implementation nice, let's add atoms!
; They will be implmented as length 1 arrays with nice syntax for deref
(fun make-atom (x) [x])
(fun set-atom! (x y) (set-idx! x 0 y))
(fun get-atom (x) (idx x 0))
(add_grammar_rule 'form ["@" 'form] (lambda (_ x) `(get-atom ~x)))
; Now begin by defining our BF syntax & semantics
; Define our tokens as BF atoms
(add_grammar_rule 'bfs_atom ["<"] (lambda (_) '(set-atom! cursor (- @cursor 1))))
(add_grammar_rule 'bfs_atom [">"] (lambda (_) '(set-atom! cursor (+ @cursor 1))))
(add_grammar_rule 'bfs_atom ["\\+"] (lambda (_) '(set-idx! tape @cursor (+ (idx tape @cursor) 1))))
(add_grammar_rule 'bfs_atom ["-"] (lambda (_) '(set-idx! tape @cursor (- (idx tape @cursor) 1))))
(add_grammar_rule 'bfs_atom [","] (lambda (_) '(let (value (idx input @inptr))
(do (set-atom! inptr (+ 1 @inptr))
(set-idx! tape @cursor value)))))
(add_grammar_rule 'bfs_atom ["."] (lambda (_) '(set-atom! output (concat [(idx tape @cursor)] @output))))
; Define strings of BF atoms
(add_grammar_rule 'bfs ['bfs_atom *] (lambda (x) x))
; Add loop as an atom
; (note that closure cannot yet close over itself by value, so we pass it in)
(add_grammar_rule 'bfs_atom ["\\[" 'bfs "]"] (lambda (_ x _)
`(let (f (lambda (f)
(if (= 0 (idx tape @cursor))
nil
(do ,x (f f)))))
(f f))))
; For now, stick BFS rule inside an unambigious BFS block
; Also add setup code
(add_grammar_rule 'form ["bf" 'optional_WS "{" 'optional_WS 'bfs 'optional_WS "}"]
(lambda (_ _ _ _ x _ _)
`(lambda (input)
(let (
tape (array 0 0 0 0 0)
cursor (make-atom 0)
inptr (make-atom 0)
output (make-atom (array))
)
(do (println "beginning bfs") ,x (idx output 0))))))
; Let's try it out! This BF program prints the input 3 times
(println (bf { ,>+++[<.>-] } [1337]))
; we can also have it compile into our main program
(fun main () (do (println "BF: " (bf { ,>+++[<.>-] } [1337])) 0))
</div>
<h4>Output: </h4>
<textarea id="bf_output">Output will appear here</textarea>
<a name="benchmarks"/>
<!--<h3>Performance Benchmarks</h3>-->
<!--<p>Performance is quite poor (for the interpreter mainly, the C compiler seems to be smart enough to make even the very inefficient generated C code fast), as almost no work has gone into it as of yet.-->
<!--We are currently focusing on the FUN-GLL macros and creating a more fully-featured language on top of the core Lisp using them. We will focus more on performance with the implementation of the functional persistent data structures and the self-hosting rewrite, and performance will be the main focus of the RVSDG IR part of the project.-->
<!--<p> Even so, it is worth keeping a rough estimate of performance in mind. For this, we have compiled a very basic benchmark below, with more benchmark programs (sorting, etc) to be included as the language gets developed:-->
<!--<br>-->
<!--<table>-->
<!--<thead>-->
<!--<tr>-->
<!--<th></th>-->
<!--<th>Core Lisp Interpreter</th>-->
<!--<th>Core Lisp Compiled to C</th>-->
<!--<th>Hand-written C</th>-->
<!--</tr>-->
<!--</thead>-->
<!--<tbody>-->
<!--<tr>-->
<!--<td><b>Fibonacci(27)</b></td>-->
<!--<td>51.505s</td>-->
<!--<td>0.007s</td>-->
<!--<td>0.002s</td>-->
<!--</tr>-->
<!--</tbody>-->
<!--</table>-->
<!--<br>-->
<!--Here is the core Lisp code run / compiled by the above test, which you can run in your web browser. The hand-written C code is an exact translation of this into idiomatic C.-->
<!--<br><i>Note: N is lowered in the web demo so WebAssembly doesn't run out of memory.</i>-->
<!--<a name="fib_example"/>-->
<!--<h4>Fibonacci:</h4>-->
<!--<button onclick="executeKraken(fib_editor.getValue(), 'fib_output')"><b>Run</b></button> <br>-->
<!--<div id="fib_editor">(def! fib (fn* (n) (cond (= 0 n) 0-->
<!--(= 1 n) 1-->
<!--true (+ (fib (- n 1)) (fib (- n 2))))))-->
<!--(let* (n 16)-->
<!--(println "Fib(" n "): " (fib n)))-->
<!--</div>-->
<!--<h4>Output:</h4>-->
<!--<textarea id="fib_output">Output will appear here</textarea>-->
<a name="next_steps"/>
<h3>Next Steps</h3>
<ul>
<li> Implement persistent functional data structures
<ul>
<li> Hash Array-Mapped Trie (HAMT) / Relaxed Radix Balance Tree (RRB-Tree)
<li> Hash Map based on the above
<li> Hash Set based on the above
</ul>
<li> Prototype Type Systems as Macros, may require macro system rewrite/upgrade
<li> Sketch out Kraken language on top of core Lisp, includes basic Hindley-Milner type system implemented with Macros and above data structures
<li> Re-self-host using functional approach in above Kraken language
<li> Use Type System Macros to implement automatic transient creation on HAMT/RBB-Tree as an optimization
<li> Implement RVSDG IR and develop best bang-for-buck optimizations using it
</ul>
<script type="text/javascript" src="https://cdnjs.cloudflare.com/ajax/libs/ace/1.4.11/ace.min.js"></script>
<script>
ace.config.set('basePath', 'https://cdnjs.cloudflare.com/ajax/libs/ace/1.4.11/')
var hello_editor = ace.edit("hello_editor")
var prelude_editor = ace.edit("prelude_editor")
var method_editor = ace.edit("method_editor")
var bf_editor = ace.edit("bf_editor")
//var fib_editor = ace.edit("fib_editor")
//for (let editor of [hello_editor, method_editor, bf_editor, fib_editor]) {
for (let editor of [hello_editor, prelude_editor, method_editor, bf_editor]) {
editor.session.setMode("ace/mode/clojure")
editor.setOption("displayIndentGuides", false)
editor.setShowPrintMargin(false)
}
var output_name = ""
var Module = {
noInitialRun: true,
onRuntimeInitialized: () => {
},
print: txt => {
document.getElementById(output_name).value += txt + "\n";
},
printErr: txt => {
document.getElementById(output_name).value += "STDERR:[" + txt + "]\n";
}
};
function executeKraken(code, new_output_name) {
output_name = new_output_name
document.getElementById(new_output_name).value = "running...\n";
Module.callMain(["-C", code]);
}
</script>
<script type="text/javascript" src="k_prime.js"></script>
</body>
</html>

100
working_files/k_prime_stdlib/method.kp Normal file
View File

@@ -0,0 +1,100 @@
; First quick lookup function, since maps are not built in
(fun get-value-helper (dict key i) (if (>= i (len dict))
nil
(if (= key (idx (idx dict i) 0))
(idx (idx dict i) 1)
(get-value-helper dict key (+ i 1)))))
(fun get-value (dict key) (get-value-helper dict key 0))
; Our actual method call function
(fun method-call (object method & arguments) (let (method_fn (get-value (meta object) method))
(if (= method_fn nil)
(println "no method " method)
(lapply method_fn (concat [object] arguments)))))
; Some nice syntactic sugar for method calls
; No params
(add_grammar_rule 'form ['form "\\." 'atom]
(lambda (o _ m) `(method-call ~o '~m)))
; params
(add_grammar_rule 'form ['form "\\." 'atom 'optional_WS "\\(" 'optional_WS 'space_forms 'optional_WS "\\)"]
(lambda (o _ m _ _ _ p _ _) `(method-call ~o '~m ,p)))
; object creation
(fun make_constructor (members methods)
(eval `(lambda ~members
(with-meta [,members]
[,(map_with_idx (lambda (i x) [array `'~x (lambda (o) (idx o i))]) members)
,(map (lambda (x) [array `'~(idx x 0) (idx x 1)]) methods)]))))
; object syntax
(add_grammar_rule 'form ["obj" 'WS 'atom "\\(" ['optional_WS 'atom] * 'optional_WS "\\)" 'optional_WS "{" 'optional_WS ['atom 'optional_WS 'form 'optional_WS] * "}"] (lambda (_ _ name _ members _ _ _ _ _ methods _)
`(set! ~name (make_constructor [,(map (lambda (x) `'~(idx x 1)) members)]
[,(map (lambda (x) `['~(idx x 0) ~(idx x 2)]) methods)]))))
; Lambda syntax
(add_grammar_rule 'form ["\\|" 'optional_WS [ 'atom 'optional_WS ] * "\\|" 'optional_WS 'form ]
(lambda (_ _ params _ _ body) `(lambda (,(map (lambda (x) (idx x 0)) params)) ~body)))
; {} body translated to do and let
(add_grammar_rule 'block_member [ 'form ] |x| [x])
(add_grammar_rule 'block_member [ "let" 'optional_WS 'atom 'optional_WS "=" 'optional_WS 'form ]
|_ _ name _ _ _ rhs| `(~name ~rhs))
(fun construct_body (is_do current to_add i)
(if (> (len to_add) i)
(cond (and is_do (= (len (idx to_add i)) 1)) (construct_body true (concat current [(idx (idx to_add i) 0)]) to_add (+ i 1))
(= (len (idx to_add i)) 1) (concat current [(construct_body true [do (idx (idx to_add i) 0)] to_add (+ i 1))])
true (concat current [(construct_body false [let [(idx (idx to_add i) 0) (idx (idx to_add i) 1)] ] to_add (+ i 1))]))
current))
(add_grammar_rule 'form ["{" 'optional_WS [ 'block_member 'optional_WS ] * "}"]
|_ _ inner _| (construct_body true [do] (map |x| (idx x 0) inner) 0))
; Call functions with function first, c style (notice no whitespace)
(add_grammar_rule 'form [ 'form 'call_form ] |f ps| (concat [f] ps))
; fun syntax
(add_grammar_rule 'form [ "fun" 'WS 'atom 'optional_WS "\\(" 'optional_WS [ 'atom 'optional_WS ] * "\\)" 'optional_WS 'form ]
|_ _ name _ _ _ params _ _ body| `(fun ~name (,(map |x| (idx x 0) params)) ~body))
; string interpolation
fun remove_dollar(done to_do i j) (cond (>= j (- (len to_do) 2)) (str done (slice to_do i -1))
(= "\\$" (slice to_do j (+ j 2))) (remove_dollar (str done (slice to_do i j) "$") to_do (+ j 2) (+ j 2))
true (remove_dollar done to_do i (+ j 1)))
fun fixup_str_parts(s) (remove_dollar "" (slice s 0 -2) 0 0)
(add_grammar_rule 'form [ "$\"" [ "(#|[%-[]| |[]-~]|(\\\\)|(\\n)|(\\t)|(\\*)|(\\\\$)|
|[ -!]|(\\\\\"))*$" 'form ] * "(#|[%-[]| |[]-~]|(\\\\)|(\\n)|(\\t)|(\\*)|(\\\\$)|
|[ -!]|(\\\\\"))*\"" ]
|_ string_form_pairs end| `(str ,( flat_map |x| [ (fixup_str_parts (idx x 0)) (idx x 1) ] string_form_pairs) ~(fixup_str_parts end)))
(println $"unu |\$| $$"inner $(+ 1 2) post-inner" sual")
obj Point( x y ) {
add |self other| { Point((+ self.x other.x) (+ self.y other.y)) }
sub |self other| { Point((- self.x other.x) (- self.y other.y)) }
to_str |self| { str("x: " self.x ", y: " self.y) }
}
fun say_hi(name) {
println("hayo" name)
}
fun test() {
let plus_1 = |x| (+ x 1)
let a = 1
let b = plus_1(a)
println("some" b)
say_hi("Marcus")
let p1 = Point(1 2)
let p2 = Point(3 4)
let p3 = p1.add(p2)
let p4 = p1.sub(p2)
println("p1:" p1.to_str)
println("p2:" p2.to_str)
println("p3:" p3.to_str)
println("p4:" p4.to_str)
(+ a b)
}
println("Test result is" test())

82
working_files/k_prime_stdlib/prelude.kp Normal file
View File

@@ -0,0 +1,82 @@
(set! quote (vau _ (x) x))
(set! lambda (vau se (p b) (wrap (eval (array vau (quote _) p b) se))))
(set! current-env (vau de () de))
(set! fun (vau se (n p b) (eval (array set! n (array lambda p b)) se)))
; do_helper is basically mapping eval over statements, but the last one is in TCO position
; a bit of a hack, using cond to sequence (note the repitition of the eval in TCO position if it's last,
; otherwise the same eval in cond position, and wheather or not it returns a truthy value, it recurses in TCO position)
(fun do_helper (s i se) (cond (= i (len s)) nil
(= i (- (len s) 1)) (eval (idx s i) se)
(eval (idx s i) se) (do_helper s (+ i 1) se)
true (do_helper s (+ i 1) se)))
(set! do (vau se (& s) (do_helper s 0 se)))
(fun concat_helper (a1 a2 a3 i) (cond (< i (len a1)) (do (set-idx! a3 i (idx a1 i)) (concat_helper a1 a2 a3 (+ i 1)))
(< i (+ (len a1) (len a2))) (do (set-idx! a3 i (idx a2 (- i (len a1)))) (concat_helper a1 a2 a3 (+ i 1)))
true a3))
(fun concat (a1 a2) (concat_helper a1 a2 (array-with-len (+ (len a1) (len a2))) 0))
(add_grammar_rule (quote form) (quote ( "'" optional_WS form )) (vau de (_ _ f) (array quote (eval f de))))
(add_grammar_rule 'form '( "\\[" optional_WS space_forms optional_WS "\\]" ) (vau de (_ _ fs _ _) (concat (array array) (eval fs de))))
(fun vapply (f p ede) (eval (concat [f] p) ede))
(fun lapply (f p) (eval (concat [(unwrap f)] p) (current-env)))
(set! let1 (vau de (s v b) (eval [[vau '_ [s] b] (eval v de)] de)))
(set! let (vau de (vs b) (cond (= (len vs) 0) (eval b de) true (vapply let1 [(idx vs 0) (idx vs 1) [let (slice vs 2 -1) b]] de))))
(set! if (vau de (con than & else) (cond
(eval con de) (eval than de)
(> (len else) 0) (eval (idx else 0) de)
true nil)))
(fun map (f l)
(let (helper (lambda (f l n i recurse)
(if (= i (len l))
n
(do (set-idx! n i (f (idx l i)))
(recurse f l n (+ i 1) recurse)))))
(helper f l (array-with-len (len l)) 0 helper)))
(fun flat_map (f l)
(let (helper (lambda (f l n i recurse)
(if (= i (len l))
n
(recurse f l (concat n (f (idx l i))) (+ i 1) recurse))))
(helper f l (array) 0 helper)))
(fun map_with_idx (f l)
(let (helper (lambda (f l n i recurse)
(if (= i (len l))
n
(do (set-idx! n i (f i (idx l i)))
(recurse f l n (+ i 1) recurse)))))
(helper f l (array-with-len (len l)) 0 helper)))
(fun print_through (x) (do (println x) x))
(fun is_pair? (x) (and (array? x) (> (len x) 0)))
(set! quasiquote (vau de (x)
(cond (is_pair? x)
(cond (and (symbol? (idx x 0)) (= (get-text (idx x 0)) "unquote"))
(eval (idx x 1) de)
true
(cond (and (is_pair? (idx x 0)) (symbol? (idx (idx x 0) 0)) (= (get-text (idx (idx x 0) 0)) "splice-unquote"))
(concat (eval (idx (idx x 0) 1) de) (vapply quasiquote [(slice x 1 -1)] de))
true
(concat [(vapply quasiquote [(idx x 0)] de)] (vapply quasiquote [(slice x 1 -1)] de))))
true x)))
(add_grammar_rule 'form '("`" optional_WS form) (lambda (_ _ f) ['quasiquote f]))
(add_grammar_rule 'form '("~" optional_WS form) (lambda (_ _ f) ['unquote f]))
(add_grammar_rule 'form '("," optional_WS form) (lambda (_ _ f) ['splice-unquote f]))
(set! Y (lambda (f)
((lambda (x) (x x))
(lambda (x) (f (lambda (& y) (lapply (x x) y)))))))
(set! vY (lambda (f)
((lambda (x) (x x))
(lambda (x) (f (vau de (& y) (vapply (x x) y de)))))))
(set! rep (Y (lambda (recurse) (wrap (vau de ()
(do (println (eval (read-string (get_line "> ")) de)) (recurse)))))))

32
working_files/match.kp Normal file
View File

@@ -0,0 +1,32 @@
(with_import "./collections.kp"
(let (
match (vau de (x & cases) (let (
x (eval x de)
evaluate_case (rec-lambda recurse (name_dict x c) (cond
; an explicit nil name_dict case allows us to simply fold over recurse in the array case later
(nil? name_dict) nil
(symbol? c) (put name_dict c x)
(and (int? x) (int? c) (= x c)) name_dict
(and (string? x) (string? c) (= x c)) name_dict
(and (bool? x) (bool? c) (= x c)) name_dict
(and (combiner? x) (combiner? c) (= x c)) name_dict
; check for invocation of quote directly
; not necessarily ideal if they define their own quote or something
(and (symbol? x) (array? c) (= 2 (len c)) (= quote (idx c 0)) (= x (idx c 1))) name_dict
; ditto with above, but with unquote to allow matching against the *value* of variables
(and (array? c) (= 2 (len c)) (= 'unquote (idx c 0)) (= x (eval (idx c 1) de))) name_dict
; ditto with above, but with array. Also note this means you have to use '[' and ']' as calling
; array explicitly will give you the symbol array instead...
(and (array? x) (array? c) (= (+ 1 (len x)) (len c)) (= array (idx c 0))) (foldl recurse name_dict x (slice c 1 -1))
true nil
))
iter (rec-lambda recurse (x i cases) (if (>= i (len cases)) (error "none of match arms matched!")
(let ( mapping (evaluate_case empty_dict x (idx cases i)))
(if (!= nil mapping) (eval (idx cases (+ i 1)) (add-dict-to-env de mapping))
(recurse x (+ i 2) cases)))))
) (iter x 0 cases)))
)
(provide match)
))

49
working_files/match_test.kp Normal file
View File

@@ -0,0 +1,49 @@
(with_import "./match.kp"
(do
(println "first "
(match 1
1 true
a (+ a 1)
))
(println "second "
(match 3
1 true
a (+ a 1)
))
(println "third "
(match "str"
1 true
"str" "It was a string!"
a (+ a 1)
))
(println "fourth "
(match [ 1337 "str" ]
1 true
"str" "It was a string!"
[ 1337 "str" ] "matched an array of int str"
a (+ a 1)
))
(println "fifth "
(match [ 1337 "str" 'sy ]
1 true
"str" "It was a string!"
[ 1337 "str" 'sy ] "matched an array of int str symbol"
a (+ a 1)
))
(println "sixth "
(match [ 1337 "str" 'walla + 11 false 'kraken [ 'inner 'middle 'end ] [ 'inner1 'middle1 'end1 ] ]
1 true
"str" "It was a string!"
[ 1337 "str" 'walla + a false b [ 'inner c 'end ] d ] (str "matched, and got " a b c d)
a (+ a 1)
))
(println "seventh "
(let (b 2)
(match [ 1337 [ 1 2 3] 11 ]
1 true
"str" "It was a string!"
[ 1337 [ a ~b c] 11 ] (str "matched, and got " a c " while checking based on inserted " b)
a "sigh, failed to match"
)))
))

103
working_files/method.kp Normal file
View File

@@ -0,0 +1,103 @@
; Load prelude so we get fun, lambda, if, quoting, etc
(load-file "./k_prime_stdlib/prelude.kp")
; First quick lookup function, since maps are not built in
(fun get-value-helper (dict key i) (if (>= i (len dict))
nil
(if (= key (idx (idx dict i) 0))
(idx (idx dict i) 1)
(get-value-helper dict key (+ i 1)))))
(fun get-value (dict key) (get-value-helper dict key 0))
; Our actual method call function
(fun method-call (object method & arguments) (let (method_fn (get-value (meta object) method))
(if (= method_fn nil)
(println "no method " method)
(lapply method_fn (concat [object] arguments)))))
; Some nice syntactic sugar for method calls
; No params
(add_grammar_rule 'form ['form "\\." 'atom]
(lambda (o _ m) `(method-call ~o '~m)))
; params
(add_grammar_rule 'form ['form "\\." 'atom 'optional_WS "\\(" 'optional_WS 'space_forms 'optional_WS "\\)"]
(lambda (o _ m _ _ _ p _ _) `(method-call ~o '~m ,p)))
; object creation
(fun make_constructor (members methods)
(eval `(lambda ~members
(with-meta [,members]
[,(map_with_idx (lambda (i x) [array `'~x (lambda (o) (idx o i))]) members)
,(map (lambda (x) [array `'~(idx x 0) (idx x 1)]) methods)]))))
; object syntax
(add_grammar_rule 'form ["obj" 'WS 'atom "\\(" ['optional_WS 'atom] * 'optional_WS "\\)" 'optional_WS "{" 'optional_WS ['atom 'optional_WS 'form 'optional_WS] * "}"] (lambda (_ _ name _ members _ _ _ _ _ methods _)
`(set! ~name (make_constructor [,(map (lambda (x) `'~(idx x 1)) members)]
[,(map (lambda (x) `['~(idx x 0) ~(idx x 2)]) methods)]))))
; Lambda syntax
(add_grammar_rule 'form ["\\|" 'optional_WS [ 'atom 'optional_WS ] * "\\|" 'optional_WS 'form ]
(lambda (_ _ params _ _ body) `(lambda (,(map (lambda (x) (idx x 0)) params)) ~body)))
; {} body translated to do and let
(add_grammar_rule 'block_member [ 'form ] |x| [x])
(add_grammar_rule 'block_member [ "let" 'optional_WS 'atom 'optional_WS "=" 'optional_WS 'form ]
|_ _ name _ _ _ rhs| `(~name ~rhs))
(fun construct_body (is_do current to_add i)
(if (> (len to_add) i)
(cond (and is_do (= (len (idx to_add i)) 1)) (construct_body true (concat current [(idx (idx to_add i) 0)]) to_add (+ i 1))
(= (len (idx to_add i)) 1) (concat current [(construct_body true [do (idx (idx to_add i) 0)] to_add (+ i 1))])
true (concat current [(construct_body false [let [(idx (idx to_add i) 0) (idx (idx to_add i) 1)] ] to_add (+ i 1))]))
current))
(add_grammar_rule 'form ["{" 'optional_WS [ 'block_member 'optional_WS ] * "}"]
|_ _ inner _| (construct_body true [do] (map |x| (idx x 0) inner) 0))
; Call functions with function first, c style (notice no whitespace)
(add_grammar_rule 'form [ 'form 'call_form ] |f ps| (concat [f] ps))
; fun syntax
(add_grammar_rule 'form [ "fun" 'WS 'atom 'optional_WS "\\(" 'optional_WS [ 'atom 'optional_WS ] * "\\)" 'optional_WS 'form ]
|_ _ name _ _ _ params _ _ body| `(fun ~name (,(map |x| (idx x 0) params)) ~body))
; string interpolation
fun remove_dollar(done to_do i j) (cond (>= j (- (len to_do) 2)) (str done (slice to_do i -1))
(= "\\$" (slice to_do j (+ j 2))) (remove_dollar (str done (slice to_do i j) "$") to_do (+ j 2) (+ j 2))
true (remove_dollar done to_do i (+ j 1)))
fun fixup_str_parts(s) (remove_dollar "" (slice s 0 -2) 0 0)
(add_grammar_rule 'form [ "$\"" [ "(#|[%-[]| |[]-~]|(\\\\)|(\\n)|(\\t)|(\\*)|(\\\\$)|
|[ -!]|(\\\\\"))*$" 'form ] * "(#|[%-[]| |[]-~]|(\\\\)|(\\n)|(\\t)|(\\*)|(\\\\$)|
|[ -!]|(\\\\\"))*\"" ]
|_ string_form_pairs end| `(str ,( flat_map |x| [ (fixup_str_parts (idx x 0)) (idx x 1) ] string_form_pairs) ~(fixup_str_parts end)))
(println $"unu |\$| $$"inner $(+ 1 2) post-inner" sual")
obj Point( x y ) {
add |self other| { Point((+ self.x other.x) (+ self.y other.y)) }
sub |self other| { Point((- self.x other.x) (- self.y other.y)) }
to_str |self| { str("x: " self.x ", y: " self.y) }
}
fun say_hi(name) {
println("hayo" name)
}
fun test() {
let plus_1 = |x| (+ x 1)
let a = 1
let b = plus_1(a)
println("some" b)
say_hi("Marcus")
let p1 = Point(1 2)
let p2 = Point(3 4)
let p3 = p1.add(p2)
let p4 = p1.sub(p2)
println("p1:" p1.to_str)
println("p2:" p2.to_str)
println("p3:" p3.to_str)
println("p4:" p4.to_str)
(+ a b)
}
println("Test result is" test())

102
working_files/new_kraken.kp Normal file
View File

@@ -0,0 +1,102 @@
(let (
; First quick lookup function, since maps are not built in
get-value-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)))))
get-value (lambda (dict key) (get-value-helper dict key 0))
; Our actual method call function
method-call (lambda (object method & arguments) (let (method_fn (get-value (meta object) method))
(if (= method_fn nil)
(println "no method " method)
(lapply method_fn (concat [object] arguments)))))
make_constructor (lambda (name members methods)
`(~rec-lambda ~name ~members
(~with-meta [,members]
[,(map_i (lambda (i x) [array `'~x (lambda (o) (idx o i))]) members)
,(map (lambda (x) [array `'~(idx x 0) (idx x 1)]) methods)])))
; {} body translated to do and let
construct_body (rec-lambda recurse (is_do current to_add i)
(if (> (len to_add) i)
(cond (and is_do (= (len (idx to_add i)) 1)) (recurse true (concat current [(idx (idx to_add i) 0)]) to_add (+ i 1))
(= (len (idx to_add i)) 1) (concat current [(recurse true [do (idx (idx to_add i) 0)] to_add (+ i 1))])
(= (len (idx to_add i)) 3) (concat current [[with_import (idx (idx to_add i) 0) (recurse false [do] to_add (+ i 1))]])
true (concat current [(recurse false [let [(idx (idx to_add i) 0) (idx (idx to_add i) 1)] ] to_add (+ i 1))]))
current))
; string interpolation
remove_dollar (rec-lambda recurse (done to_do i j) (cond (>= j (- (len to_do) 2)) (str done (slice to_do i -1))
(= "\\$" (slice to_do j (+ j 2))) (recurse (str done (slice to_do i j) "$") to_do (+ j 2) (+ j 2))
true (recurse done to_do i (+ j 1))))
fixup_str_parts (lambda (s) (remove_dollar "" (slice s 0 -2) 0 0))
new_kraken_untyped (concat standard_grammar [
[ 'expr [ 'number ] (lambda (x) x) ]
[ 'expr [ 'string ] (lambda (x) x) ]
[ 'expr [ 'bool_nil_symbol ] (lambda (x) x) ]
[ 'call_innards [ 'WS * ] (lambda (_) []) ]
[ 'call_innards [ 'expr [ 'WS 'expr ] * ] (lambda (f r) (concat [f] (map (lambda (x) (idx x 1)) r))) ]
[ 'expr ['expr "\\." 'bool_nil_symbol] (lambda (o _ m) `(~method-call ~o '~m)) ]
; params
[ 'expr ['expr "\\." 'bool_nil_symbol "\\(" 'call_innards "\\)"]
(lambda (o _ m _ p _) `(~method-call ~o '~m ,p)) ]
[ 'expr [ "\\|" 'call_innards "\\|" 'WS * 'expr ]
(lambda (_ params _ _ body) `(lambda (,params) ~body)) ]
; Call functions with function first, c style (notice no whitespace)
[ 'expr [ 'expr "\\(" 'call_innards "\\)" ]
(lambda (f _ ps _) (concat [f] ps)) ]
; fun syntax
[ 'block_member [ "fun" 'WS 'bool_nil_symbol 'WS * "\\(" 'call_innards "\\)" 'WS * 'expr ]
(lambda (_ _ name _ _ params _ _ body) `(~name (~lambda (,params) ~body))) ]
[ 'block_member [ 'expr ] (lambda (x) [x]) ]
[ 'block_member [ "let" 'WS * 'bool_nil_symbol 'WS * "=" 'WS * 'expr ]
(lambda (_ _ name _ _ _ rhs) `(~name ~rhs)) ]
; object syntax
[ 'block_member ["obj" 'WS 'bool_nil_symbol "\\(" ['WS * 'bool_nil_symbol] * 'WS * "\\)" 'WS * "{" 'WS * ['bool_nil_symbol 'WS * 'expr 'WS *] * "}"]
(lambda (_ _ name _ members _ _ _ _ _ methods _)
[name (make_constructor name (map (lambda (x) (idx x 1)) members)
(map (lambda (x) [(idx x 0) (idx x 2)]) methods))]) ]
; import
[ 'block_member [ "with_import" 'WS 'string 'WS * ":" ]
(lambda (_ _ file _ _) [file 0 0]) ]
[ 'expr ["{" 'WS * 'block_member "}"]
(lambda (_ _ inner _) (construct_body true [do] [inner] 0)) ]
[ 'expr ["{" 'WS * [ 'block_member 'WS ] * "}"]
(lambda (_ _ inner _) (construct_body true [do] (map (lambda (x) (idx x 0)) inner) 0)) ]
[ 'new_kraken_start_symbol [ 'WS * [ 'block_member 'WS ] * ]
(lambda (_ inner) (construct_body true [do] (map (lambda (x) (idx x 0)) inner) 0)) ]
[ 'expr [ "$\"" [ "(#|[%-[]| |[]-~]|(\\\\\\\\)|(\\\\n)|(\\\\t)|(\\*)|(\\\\$)|
|[ -!]|(\\\\\"))*$" 'expr ] * "(#|[%-[]| |[]-~]|(\\\\\\\\)|(\\\\n)|(\\\\t)|(\\*)|(\\\\$)|
|[ -!]|(\\\\\"))*\"" ]
(lambda (_ string_expr_pairs end) `(str ,( flat_map (lambda (x) [ (fixup_str_parts (idx x 0)) (idx x 1) ]) string_expr_pairs) ~(fixup_str_parts end))) ]
; Swapping back and forth between underlying Lisp syntax
; Might want to disable this when we start doing typing
; till we figure out how to type Vau and such.
[ 'expr [ "\\\\" 'form ] (lambda (_ inner) inner) ]
[ 'form [ "\\\\" 'expr ] (lambda (_ inner) inner) ]
]))
(provide new_kraken_untyped)
)

49
working_files/new_kraken_test.kp Normal file
View File

@@ -0,0 +1,49 @@
#lang (with_import "./new_kraken.kp" new_kraken_untyped) new_kraken_start_symbol
let my_var = 1337
println($"this is string interpolation: ${+(1 3 4)} <- cool right? another $my_var yep even variables")
obj Point( x y ) {
add |self other| { Point(+(self.x other.x) +(self.y other.y)) }
sub |self other| { Point(-(self.x other.x) -(self.y other.y)) }
to_str |self| { str("x: " self.x ", y: " self.y) }
}
fun say_hi(name) {
println("hayo" name)
}
fun test() {
let plus_1 = |x| { +(x 1) }
let a = 1
let b = plus_1(a)
println("some" b)
say_hi("Marcus")
let p1 = Point(1 2)
let p2 = Point(3 4)
let p3 = p1.add(p2)
let p4 = p1.sub(p2)
say_hi("Charlie/Betty")
println("p1:" p1.to_str)
println("p2:" p2.to_str)
println("p3:" p3.to_str)
println("p4:" p4.to_str)
println("before + a b" +(a b))
with_import("./import_test.kp" println("after + a b" +(a b)))
println("post after + a b" +(a b))
with_import "./import_test.kp":
println("post new impot after + a b" +(a b))
println("We're back baby" \(+ 1 13
(do
(println "hahaha" 'a \{
let a = 75
let b = 75
println("Inside hahaha more HAHAHAA " +(1 2 a b))
"Inside Result"
}) 4)))
}
println("Test result is" test())

521
working_files/partial_eval.kp Normal file
View File

@@ -0,0 +1,521 @@
(with_import "./collections.kp"
(let (
; For right now we only support calling partial_eval in such a way that it partial evals against
; the root env, but this is could and really should be extended. We could at least check if the env we're called with
; is the root_env, or if what we look up in whatever env is passed in matches something in the root env
; Care should also be taken when evaluating outside combinators to have them be in the right env, etc
; Here is every form in k'
; True
; False
; Env: *KPEnv
; Combiner: KPCombiner / BuiltinCombiner: KPBuiltinCombiner
; String: str
; Symbol: str
; Int: int
; Array: rc<vec<KPValue>>
; Nil
; Ok, some more things we need / need to change
; 1) meta...
; Honestly, I'm tempted to get rid of it
; Possible marked values
; ['val v] - v is a value that evaluates to itself, and not a combiner or env, as those have their own metadata. Not an array or symbol
; That means it's true/false/a string/ an int/nil
; ['marked_array is_val a] - a contains marked values. if is_val, then it's the value version, and must be stripped back into (array ...),
; otherwise it's a calling form, and should be lowered back to (...). Also, if it's is_val, partial_eval won't perform a call, etc
; ['marked_symbol is_val s] - a symbol. is_val has the same meaning as in marked_array
; ['comb wrap_level de? se variadic params body] - A combiner. Contains the static env and the actual function, if possible.
; It is possible to have a combiner without an actual function, but that's only generated when
; we know it's about to be called and we won't have to strip-lower it
; ['prim_comb <handler_function>] - A primitive combiner! It has it's own special handler function to partial eval
; ['env is_real de_bruijn_idx_or_nil [ ['symbol marked_value ]... <upper_marked_env> ]] - A marked env
val? (lambda (x) (= 'val (idx x 0)))
.val (lambda (x) (idx x 1))
marked_array? (lambda (x) (= 'marked_array (idx x 0)))
.marked_array_is_val (lambda (x) (idx x 1))
.marked_array_values (lambda (x) (idx x 2))
marked_symbol? (lambda (x) (= 'marked_symbol (idx x 0)))
.marked_symbol_is_val (lambda (x) (idx x 1))
.marked_symbol_value (lambda (x) (idx x 2))
comb? (lambda (x) (= 'comb (idx x 0)))
.comb (lambda (x) (slice x 1 -1))
prim_comb? (lambda (x) (= 'prim_comb (idx x 0)))
.prim_comb (lambda (x) (idx x 1))
marked_env? (lambda (x) (= 'env (idx x 0)))
marked_env_real? (lambda (x) (idx x 1))
.marked_env_idx (lambda (x) (idx x 2))
.env_marked (lambda (x) (idx x 3))
later? (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)))
; This is now taken care of via the de Bruijn >= 0 check in call, otherwise these are values, kinda, as long as they don't go negative (or are real)
;(and (marked_env? x) (not (marked_env_real? x)))
;(and (comb? x) (let ([wrap_level de? se variadic params body] (.comb x)
; ; this is the complex bit - we should do something like check if
; ; se is fake check to see if there are symbols or eval that could use it
; ; or a sub-comb's se, or if de is non-nil and used in some sub-call.
; comb_is_later (recurse se)
; ) comb_is_later))
))
false? (lambda (x) (cond (and (marked_array? x) (= false (.marked_array_is_val x))) (error (str "got a later marked_array passed to false? " x))
(and (marked_symbol? x) (= false (.marked_symbol_is_val x))) (error (str "got a later marked_symbol passed to false? " x))
(val? x) (not (.val x))
true false))
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 (str key " not found in env " (.env_marked env)))) (lambda (x) x)))
mark (rec-lambda recurse (x) (cond (env? x) (error (str "called mark with an env " x))
(combiner? x) (error (str "called mark with a combiner " x))
(symbol? x) ['marked_symbol false x]
(array? x) ['marked_array false (map recurse x)]
true ['val x]))
indent_str (rec-lambda recurse (i) (if (= i 0) ""
(str " " (recurse (- i 1)))))
str_strip (lambda (& args) (lapply str (concat (slice args 0 -2) [((rec-lambda recurse (x)
(cond (val? x) (.val x)
(marked_array? x) (let (stripped_values (map recurse (.marked_array_values x)))
(if (.marked_array_is_val x) (cons array stripped_values)
stripped_values))
(marked_symbol? x) (if (.marked_symbol_is_val x) ['quote (.marked_symbol_value x)]
(.marked_symbol_value x))
(comb? x) (let ([wrap_level de? se variadic params body] (.comb x))
(str "<comb " wrap_level " " de? " <se " (recurse se) "> " params " " (recurse body) ">"))
(prim_comb? x) (idx x 2)
(marked_env? x) (let (e (.env_marked x)
index (.marked_env_idx x)
u (idx e -1)
) (if u (str "<" (if (marked_env_real? x) "real" "fake") " ENV idx: " (str index) ", " (map (lambda ([k v]) [k (recurse v)]) (slice e 0 -2)) " upper: " (recurse u) ">")
"<no_upper_likely_root_env>"))
true (error (str "some other str_strip? |" x "|"))
)
) (idx args -1))])))
print_strip (lambda (& args) (println (lapply str_strip args)))
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)))
(if (.marked_array_is_val x) (if need_value (error (str "needed value for this strip but got" x)) (cons array stripped_values))
stripped_values))
(marked_symbol? x) (if (.marked_symbol_is_val x) (if need_value (error (str "needed value for this strip but got" x)) [quote (.marked_symbol_value x)])
(.marked_symbol_value x))
(comb? x) (let ([wrap_level de? se variadic params body] (.comb x)
de_entry (if de? [de?] [])
final_params (if variadic (concat (slice params 0 -2) '& [(idx params -1)]) params)
; Honestly, could trim down the env to match what could be evaluated in the comb
; Also if this isn't real, lower to a call to vau
se_env (if (marked_env_real? se) (recurse se true) nil)
body_v (recurse body false)
ve (concat [vau] de_entry [final_params] [body_v])
fe ((rec-lambda recurse (x i) (if (= i 0) x (recurse [wrap x] (- i 1)))) ve wrap_level)
) (if se_env (eval fe se_env) fe))
(prim_comb? x) (idx x 2)
; env emitting doesn't pay attention to real value right now, not sure if that makes sense
; TODO: properly handle de Bruijn indexed envs
(marked_env? x) (cond (and (not need_value) (= 0 (.marked_env_idx x))) [current-env]
true (let (_ (if (not (marked_env_real? x)) (error (str_strip "trying to emit fake env!" x)))
upper (idx (.env_marked x) -1)
upper_env (if upper (recurse upper true) empty_env)
just_entries (slice (.env_marked x) 0 -2)
vdict (map (lambda ([k v]) [k (recurse v true)]) just_entries)
) (add-dict-to-env upper_env vdict)))
true (error (str "some other strip? " x))
)
)) (lambda (x) (let (_ (print_strip "stripping: " x) r (helper x false) _ (println "result of strip " r)) r)))
; A bit wild, but what if instead of is_value we had an evaluation level integer, kinda like wrap?
; when lowering, it could just turn into multiple evals or somesuch, though we'd have to be careful of envs...
try_unval (rec-lambda recurse (x fail_f)
(cond (marked_array? x) (if (not (.marked_array_is_val x)) [false (fail_f x)]
(let ([sub_ok subs] (foldl (lambda ([ok a] x) (let ([nok p] (recurse x fail_f))
[(and ok nok) (concat a [p])]))
[true []]
(.marked_array_values x)))
[sub_ok ['marked_array false subs]]))
(marked_symbol? x) (if (.marked_symbol_is_val x) [true ['marked_symbol false (.marked_symbol_value x)]]
[false (fail_f x)])
true [true x]
)
)
try_unval_array (lambda (x) (foldl (lambda ([ok a] x) (let ([nok p] (try_unval x (lambda (_) nil)))
[(and ok nok) (concat a [p])]))
[true []]
x))
ensure_val (rec-lambda recurse (x)
(cond (marked_array? x) ['marked_array true (map recurse (.marked_array_values x))]
(marked_symbol? x) ['marked_symbol true (.marked_symbol_value x)]
true x
)
)
; This is a conservative analysis, since we can't always tell what constructs introduce
; a new binding scope & would be shadowing... we should at least be able to implement it for
; vau/lambda, but we won't at first
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)))
; TODO: make this check for stop envs using de Bruijn indicies
contains_symbols (rec-lambda recurse (stop_envs symbols x) (cond
(val? x) false
(marked_symbol? x) (let (r (in_array (.marked_symbol_value x) symbols)
_ (if r (println "!!! contains symbols found " x " in symbols " symbols)))
r)
(marked_array? x) (foldl (lambda (a x) (or a (recurse stop_envs symbols x))) false (.marked_array_values x))
(comb? x) (let ([wrap_level de? se variadic params body] (.comb x))
(or (recurse stop_envs symbols se) (recurse stop_envs (filter (lambda (y) (not (or (= de? y) (in_array y params)))) symbols) body)))
(prim_comb? x) false
(marked_env? x) (let (inner (.env_marked x))
(cond (in_array x stop_envs) false
(foldl (lambda (a x) (or a (recurse stop_envs symbols (idx x 1)))) false (slice inner 0 -2)) true
(idx inner -1) (recurse stop_envs symbols (idx inner -1))
true false))
true (error (str "Something odd passed to contains_symbols " x))
))
is_all_values (lambda (evaled_params) (foldl (lambda (a x) (and a (not (later? x)))) true evaled_params))
; * TODO: allowing envs to be shead if they're not used.
shift_envs (rec-lambda recurse (cutoff d x) (cond
(val? x) [true x]
(marked_env? x) (let ([_env is_real dbi meat] x
[nmeat_ok nmeat] (foldl (lambda ([ok r] [k v]) (let ([tok tv] (recurse cutoff d v)) [(and ok tok) (concat r [[k tv]])])) [true []] (slice meat 0 -2))
[nupper_ok nupper] (if (idx meat -1) (recurse cutoff d (idx meat -1)) [true nil])
ndbi (cond (nil? dbi) nil
(>= dbi cutoff) (+ dbi d)
true dbi)
) [(and nmeat_ok nupper_ok (or is_real (and ndbi (>= ndbi 0)))) ['env is_real ndbi (concat nmeat [nupper])]])
(comb? x) (let ([wrap_level de? se variadic params body] (.comb x)
[se_ok nse] (recurse cutoff d se)
[body_ok nbody] (recurse (+ cutoff 1) d body)
) [(and se_ok body_ok) ['comb wrap_level de? nse variadic params nbody]])
(prim_comb? x) [true x]
(marked_symbol? x) [true x]
(marked_array? x) (let ([insides_ok insides] (foldl (lambda ([ok r] tx) (let ([tok tr] (recurse cutoff d tx)) [(and ok tok) (concat r [tr])])) [true []] (.marked_array_values x)))
[insides_ok ['marked_array (.marked_array_is_val x) insides]])
true (error (str "impossible shift_envs value " x))
))
increment_envs (lambda (x) (idx (shift_envs 0 1 x) 1))
decrement_envs (lambda (x) (shift_envs 0 -1 x))
; 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 false 0 (concat (map (lambda (p) [p ['marked_symbol false p]]) params) (if (= nil de?) [] [ [de? ['marked_symbol false de?]] ]) [(increment_envs de)])])
partial_eval_helper (rec-lambda recurse (x env env_stack indent)
(cond (val? x) x
(marked_env? x) (let (dbi (.marked_env_idx x))
(if dbi (let (new_env (idx env_stack dbi)
ndbi (.marked_env_idx new_env)
;_ (if (!= dbi ndbi) (error (str (str_strip "same env with different dbis " x) (str_strip " and " new_env))))
_ (if (!= 0 ndbi) (error (str_strip "new env with non-zero dbis " x)))
_ (println (str_strip "replacing " x) (str_strip " with " new_env))
)
(if (= 0 dbi) new_env (idx (shift_envs 0 dbi new_env) 1)))
x))
(comb? x) (let ([wrap_level de? se variadic params body] (.comb x))
(if (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!
(let (inner_env (make_tmp_inner_env params de? env))
['comb wrap_level de? env variadic params (recurse body inner_env (cons inner_env env_stack) (+ indent 1))])
x))
(prim_comb? x) x
(marked_symbol? x) (if (.marked_symbol_is_val x) x
(env-lookup env (.marked_symbol_value x)))
(marked_array? x) (cond (.marked_array_is_val x) x
(= 0 (len (.marked_array_values x))) (error "Partial eval on empty array")
true (let (values (.marked_array_values x)
;_ (println (indent_str indent) "partial_evaling comb " (idx values 0))
_ (print_strip (indent_str indent) "partial_evaling comb " (idx values 0))
comb (recurse (idx values 0) env env_stack (+ 1 indent))
literal_params (slice values 1 -1)
_ (println (indent_str indent) "Going to do an array call!")
_ (print_strip (indent_str indent) " total is " x)
_ (print_strip (indent_str indent) " evaled comb is " comb)
ident (+ 1 indent)
)
(cond (prim_comb? comb) ((.prim_comb comb) env env_stack literal_params (+ 1 indent))
(comb? comb) (let (
rp_eval (lambda (p) (recurse p env env_stack (+ 1 indent)))
[wrap_level de? se variadic params body] (.comb comb)
ensure_val_params (map ensure_val literal_params)
[ok appropriatly_evaled_params] ((rec-lambda param-recurse (wrap cparams)
(if (!= 0 wrap)
(let (pre_evaled (map rp_eval cparams)
[ok unval_params] (try_unval_array pre_evaled))
(if (not ok) [ok nil]
(let (evaled_params (map rp_eval unval_params))
(param-recurse (- wrap 1) evaled_params))))
[true cparams])
) wrap_level ensure_val_params)
ok_and_non_later (and ok (is_all_values appropriatly_evaled_params))
) (if (not ok_and_non_later) ['marked_array false (cons comb (if (> wrap_level 0) (map rp_eval literal_params)
literal_params))]
(let (
final_params (if variadic (concat (slice appropriatly_evaled_params 0 (- (len params) 1))
[['marked_array true (slice appropriatly_evaled_params (- (len params) 1) -1)]])
appropriatly_evaled_params)
[de_real de_entry] (if (!= nil de?) [ (marked_env_real? env) [ [de? (increment_envs env) ] ] ]
[ true []])
;_ (println (indent_str indent) "final_params params " final_params)
inner_env ['env (and de_real (marked_env_real? se)) 0 (concat (zip params (map (lambda (x) (increment_envs x)) final_params)) de_entry [(increment_envs se)])]
_ (print_strip (indent_str indent) " with inner_env is " inner_env)
_ (print_strip (indent_str indent) "going to eval " body)
tmp_func_result (recurse body inner_env (cons inner_env env_stack) (+ 1 indent))
_ (print_strip (indent_str indent) "evaled result of function call is " tmp_func_result)
[able_to_sub_env func_result] (decrement_envs tmp_func_result)
result_is_later (later? func_result)
_ (print_strip (indent_str indent) "success? " able_to_sub_env " decremented result of function call is " tmp_func_result)
stop_envs ((rec-lambda ser (a e) (if e (ser (cons e a) (idx (.env_marked e) -1)) a)) [] se)
result_closes_over (contains_symbols stop_envs (concat params (if de? [de?] [])) func_result)
_ (println (indent_str indent) "func call able_to_sub: " able_to_sub_env " result is later? " result_is_later " and result_closes_over " result_closes_over)
; This could be improved to a specialized version of the function
; just by re-wrapping it in a comb instead if we wanted.
; Something to think about!
result (if (or (not able_to_sub_env) (and result_is_later result_closes_over))
['marked_array false (cons comb (if (> wrap_level 0) (map rp_eval literal_params)
literal_params))]
func_result)
) result)))
(later? comb) ['marked_array false (cons comb literal_params)]
true (error (str "impossible comb value " x)))))
true (error (str "impossible partial_eval value " x))
)
)
needs_params_val_lambda (vau de (f_sym) (let (
actual_function (eval f_sym de)
handler (rec-lambda recurse (de env_stack params indent) (let (
;_ (println "partial_evaling params in need_params_val_lambda for " f_sym " is " params)
evaled_params (map (lambda (p) (partial_eval_helper p de env_stack (+ 1 indent))) params)
)
(if (is_all_values evaled_params) (mark (lapply actual_function (map strip evaled_params)))
['marked_array false (cons ['prim_comb recurse actual_function] evaled_params)])))
) [f_sym ['prim_comb handler actual_function]]))
give_up_eval_params (vau de (f_sym) (let (
actual_function (eval f_sym de)
handler (rec-lambda recurse (de env_stack params indent) (let (
_ (println "partial_evaling params in give_up_eval_params for " f_sym " is " params)
evaled_params (map (lambda (p) (partial_eval_helper p de env_stack (+ 1 indent))) params)
)
['marked_array false (cons ['prim_comb recurse actual_function] evaled_params)]))
) [f_sym ['prim_comb handler actual_function]]))
; !!!!!!
; ! I think needs_params_val_lambda should be combined with parameters_evaled_proxy
; !!!!!!
parameters_evaled_proxy (rec-lambda recurse (pasthr_ie inner_f) (lambda (de env_stack params indent) (let (
_ (println "partial_evaling params in parameters_evaled_proxy is " params)
[evaled_params l] (foldl (lambda ([ac i] p) (let (p (partial_eval_helper p de env_stack (+ 1 indent)))
[(concat ac [p]) (+ i 1)]))
[[] 0]
params)
) (inner_f (lambda (& args) (lapply (recurse pasthr_ie inner_f) args)) de env_stack evaled_params indent))))
root_marked_env ['env true nil [
; Ok, so for combinators, it should partial eval the body.
; It should then check to see if the partial-evaled body has closed over
; any 'later values from above the combinator. If so, the combinator should
; evaluate to a ['later [vau de? params (strip partially_evaled_body)]], otherwise it can evaluate to a 'comb.
; Note that this 'later may be re-evaluated later if the parent function is called.
['vau ['prim_comb (rec-lambda recurse (de env_stack params indent) (let (
mde? (if (= 3 (len params)) (idx params 0))
vau_mde? (if (= nil mde?) [] [mde?])
de? (if mde? (.marked_symbol_value mde?))
vau_de? (if (= nil de?) [] [de?])
raw_marked_params (if (= nil de?) (idx params 0) (idx params 1))
raw_params (map (lambda (x) (if (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 (lambda ([v a] x) (if (= x '&) [true a] [v (concat a [x])])) [false []] raw_params)
body (if (= nil de?) (idx params 1) (idx params 2))
inner_env (make_tmp_inner_env vau_params de? de)
_ (print_strip (indent_str indent) "in vau, evaluating body with 'later params - " body)
pe_body (partial_eval_helper body inner_env (cons inner_env env_stack) (+ 1 indent))
_ (print_strip (indent_str indent) "in vau, result of evaluating body was " pe_body)
) ['comb 0 de? de variadic vau_params pe_body]
)) vau]]
['wrap ['prim_comb (parameters_evaled_proxy 0 (lambda (recurse de env_stack [evaled] indent)
(if (comb? evaled) (let ([wrap_level de? se variadic params body] (.comb evaled)
wrapped_marked_fun ['comb (+ 1 wrap_level) de? se variadic params body]
) wrapped_marked_fun)
['marked_array false [['prim_comb recurse wrap] evaled]]))
) wrap]]
['unwrap ['prim_comb (parameters_evaled_proxy 0 (lambda (recurse de env_stack [evaled] indent)
(if (comb? evaled) (let ([wrap_level de? se variadic params body] (.comb evaled)
unwrapped_marked_fun ['comb (- wrap_level 1) de? se variadic params body]
) unwrapped_marked_fun)
['marked_array false [['prim_comb recurse unwrap] evaled]]))
) unwrap]]
['eval ['prim_comb (rec-lambda recurse (de env_stack params indent) (let (
self ['prim_comb recurse eval]
eval_env (if (= 2 (len params)) (partial_eval_helper (idx params 1) de env_stack (+ 1 indent))
de)
eval_env_v (if (= 2 (len params)) [eval_env] [])
) (if (not (marked_env? eval_env)) (do (print_strip (indent_str indent) "eval got not a marked env " eval_env) ['marked_array false (cons self params)])
(let (
_ (print_strip (indent_str indent) " partial_evaling_body the first time " (idx params 0))
body1 (partial_eval_helper (idx params 0) de env_stack (+ 1 indent))
_ (print_strip (indent_str indent) "after first eval of param " body1)
; With this, we don't actually fail as this is always a legitimate uneval
fail_handler (lambda (failed) ['marked_array false (concat [self failed] eval_env_v)])
[ok unval_body] (try_unval body1 fail_handler)
self_fallback (fail_handler body1)
_ (print_strip (indent_str indent) "partial_evaling body for the second time in eval " unval_body)
body2 (if (= self_fallback unval_body) self_fallback (partial_eval_helper unval_body eval_env env_stack (+ 1 indent)))
_ (print_strip (indent_str indent) "and body2 is " body2)
) body2))
)) eval]]
;TODO: This could go a lot farther, not stopping after the first 'later, etc
; Also, GAH on odd params - but only one by one - a later odd param can't be imm_eval cuz it will
; be frozen if an earlier cond is 'later....
['cond ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de env_stack evaled_params indent)
(if (!= 0 (% (len evaled_params) 2)) (error (str "partial eval cond with odd evaled_params " evaled_params))
((rec-lambda recurse_inner (i)
(cond (later? (idx evaled_params i)) ['marked_array false (cons ['prim_comb recurse cond] (slice evaled_params i -1))]
(false? (idx evaled_params i)) (recurse_inner (+ 2 i))
true (idx evaled_params (+ 1 i))) ; we could partially_eval again passing in immediate
; eval if it was true, to partially counteract the above GAH
) 0)
)
)) cond]]
(needs_params_val_lambda symbol?)
(needs_params_val_lambda int?)
(needs_params_val_lambda string?)
; not even a gah, but kinda!
['combiner? ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de env_stack [evaled_param] indent)
(cond (comb? evaled_param) ['val true]
(prim_comb? evaled_param) ['val true]
(later? evaled_param) ['marked_array false [['prim_comb recurse combiner?] evaled_param]]
true ['val false]
)
)) combiner?]]
; not even a gah, but kinda!
['env? ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de env_stack [evaled_param] indent)
(cond (marked_env? evaled_param) ['val true]
(later? evaled_param) ['marked_array false [['prim_comb recurse env?] evaled_param]]
true ['val false]
)
)) env?]]
(needs_params_val_lambda nil?)
(needs_params_val_lambda bool?)
(needs_params_val_lambda str-to-symbol)
(needs_params_val_lambda get-text)
['array? ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de env_stack [evaled_param] indent)
(cond
(later? evaled_param) ['marked_array false [['prim_comb recurse array?] evaled_param]]
(marked_array? evaled_param) ['val true]
true ['val false]
)
)) array?]]
; This one's sad, might need to come back to it.
; We need to be able to differentiate between half-and-half arrays
; for when we ensure_params_values or whatever, because that's super wrong
['array ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de env_stack evaled_params indent)
(if (is_all_values evaled_params) ['marked_array true evaled_params]
['marked_array false (cons ['prim_comb recurse array] evaled_params)])
)) array]]
['len ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de env_stack [evaled_param] indent)
(cond (later? evaled_param) ['marked_array false [['prim_comb recurse len] evaled_param]]
(marked_array? evaled_param) ['val (len (.marked_array_values evaled_param))]
true (error (str "bad type to len " evaled_param))
)
)) len]]
['idx ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de env_stack [evaled_array evaled_idx] indent)
(cond (and (val? evaled_idx) (marked_array? evaled_array) (.marked_array_is_val evaled_array)) (idx (.marked_array_values evaled_array) (.val evaled_idx))
true ['marked_array false [['prim_comb recurse idx] evaled_array evaled_idx]]
)
)) idx]]
['slice ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de env_stack [evaled_array evaled_begin evaled_end] indent)
(cond (and (val? evaled_begin) (val? evaled_end) (marked_array? evaled_array) (.marked_array_is_val evaled_array))
['marked_array true (slice (.marked_array_values evaled_array) (.val evaled_begin) (.val evaled_end))]
true ['marked_array false [['prim_comb recurse slice] evaled_array evaled_idx evaled_begin evaled_end]]
)
)) slice]]
['concat ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de env_stack evaled_params indent)
(cond (foldl (lambda (a x) (and a (and (marked_array? x) (.marked_array_is_val x)))) true evaled_params) ['marked_array true (lapply concat (map (lambda (x)
(.marked_array_values x))
evaled_params))]
true ['marked_array false (cons ['prim_comb recurse concat] evaled_params)]
)
)) concat]]
(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 >>)
(needs_params_val_lambda =)
(needs_params_val_lambda !=)
(needs_params_val_lambda <)
(needs_params_val_lambda <=)
(needs_params_val_lambda >)
(needs_params_val_lambda >=)
; these could both be extended to eliminate other known true values except for the end and vice-versa
['and ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de env_stack evaled_params indent)
((rec-lambda inner_recurse (i)
(cond (= i (- (len evaled_params) 1)) (idx evaled_params i)
(later? (idx evaled_params i)) ['marked_array false (cons ['prim_comb recurse and] (slice evaled_params i -1))]
(false? (idx evaled_params i)) (idx evaled_params i)
true (inner_recurse (+ 1 i)))
) 0)
)) and]]
; see above for improvement
['or ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de env_stack evaled_params indent)
((rec-lambda inner_recurse (i)
(cond (= i (- (len evaled_params) 1)) (idx evaled_params i)
(later? (idx evaled_params i)) ['marked_array false (cons ['prim_comb recurse or] (slice evaled_params i -1))]
(false? (idx evaled_params i)) (recurse (+ 1 i))
true (idx evaled_params i))
) 0)
)) or]]
; should make not a built in and then do here
; OR not - I think it will actually lower correctly partially evaled
(needs_params_val_lambda pr-str)
(needs_params_val_lambda str)
(needs_params_val_lambda prn)
(give_up_eval_params println)
; really do need to figure out if we want to keep meta, and add it if so
(give_up_eval_params meta)
(give_up_eval_params with-meta)
; if 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)
(give_up_eval_params slurp)
(give_up_eval_params get_line)
(give_up_eval_params write_file)
['empty_env ['env true nil [nil]]]
nil
] root_env]
partial_eval (lambda (x) (partial_eval_helper (mark x) root_marked_env [] 0))
)
(provide partial_eval strip print_strip)
))

35
working_files/partial_eval_test.csc Normal file
View File

@@ -0,0 +1,35 @@
; Going to set some aliases just for this, the scheme version
; commenting out the first let with it's final ) should make this
; legal kraken
(import (chicken process-context))
(import (chicken port))
(load "partial_eval.csc")
(import (partial_eval))
(let* (
(array list)
(concat append)
(len length)
(idx list-ref)
;(array vector)
;(concat vector-append) ; only in extension vector library!
;(len vector-length)
;(idx vector-ref)
(= equal?)
)
(print (array 1 2 3))
(print (command-line-arguments))
(print (call-with-input-string "'(1 2)" (lambda (p) (read p))))
(print partial_eval)
)

176
working_files/partial_eval_test.kp Normal file
View File

@@ -0,0 +1,176 @@
(with_import "./partial_eval.kp"
(let (
test-case (lambda (code) (let (
_ (println "Code: " code)
; For right now we only support calling partial_eval in such a way that it partial evals against
; the root env, but this is could and really should be extended. We could at least check if the env we're called with
; is the root_env, or if what we look up in whatever env is passed in matches something in the root env
partially_evaled (partial_eval code)
_ (println "Partially evaled: " partially_evaled)
_ (print_strip partially_evaled)
stripped (strip partially_evaled)
_ (println "Stripped: " stripped)
fully_evaled (eval stripped root_env)
_ (println "Fully evaled: " fully_evaled)
fully_evaled_called (if (combiner? fully_evaled) (fully_evaled 1337))
_ (if (combiner? fully_evaled) (println "..and called " fully_evaled_called))
outer_eval (eval code root_env)
_ (println " outer-eval " outer_eval)
outer_called (if (combiner? outer_eval) (outer_eval 1337))
_ (if (combiner? outer_eval) (println "..and outer called " outer_called))
_ (cond (or (combiner? fully_evaled) (combiner? outer_eval))
(if (!= fully_evaled_called outer_called) (error (str "called versions unequal for " code " are " fully_evaled_called " vs " outer_called)))
(!= fully_evaled outer_eval) (error (str "partial-eval versions unequal for " code " are " fully_evaled " vs " outer_eval))
true nil)
_ (println)
) fully_evaled))
simple_add (read-string "(+ 1 2)")
vau_with_add (read-string "(vau (y) (+ 1 2))")
vau_with_add_called (read-string "((vau (y) (+ 1 2)) 4)")
vau_with_passthrough (read-string "((vau (y) y) 4)")
vau_with_no_eval_add (read-string "((vau (y) (+ 13 2 y)) 4)")
vau_with_wrap_add (read-string "((wrap (vau (y) (+ 13 2 y))) (+ 3 4))")
vau_with_add_p (read-string "(vau de (y) (+ (eval y de) (+ 1 2)))")
vau_with_add_p_called (read-string "((vau de (y) ((vau dde (z) (+ 1 (eval z dde))) y)) 17)")
cond_test (read-string "(cond false 1 false 2 (+ 1 2) 3 true 1337)")
cond_vau_test (read-string "(vau de (x) (cond false 1 false 2 x 3 true 42))")
cond_vau_test2 (read-string "(vau de (x) (cond false 1 false 2 3 x true 42))")
combiner_test (read-string "(combiner? true)")
combiner_test2 (read-string "(combiner? (vau de (x) x))")
combiner_test3 (read-string "(vau de (x) (combiner? x))")
symbol_test (read-string "((vau (x) x) a)")
env_test (read-string "(env? true)")
; this doesn't partially eval, but it could with a more percise if the marked values were more percise
env_test2 (read-string "(vau de (x) (env? de))")
env_test3 (read-string "(vau de (x) (env? x))")
env_test4 (read-string "((vau de (x) (env? de)) 1)")
; let1 test
; ((wrap (vau root_env (quote) ((wrap (vau (let1) ;HERE;)) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de))))) (vau (x) x))
;let1_test (read-string "((wrap (vau root_env (quote) ((wrap (vau (let1) (let1 a 12 (+ a 1)))) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de))))) (vau (x) x))")
let1_test (read-string "((wrap (vau (let1) (let1 a 12 (+ a 1)))) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de)))")
let2_test (read-string "((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)))")
let3_test (read-string "((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)))")
let4_test (read-string "((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)))")
let4.3_test (read-string "((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)))")
let4.7_test (read-string "((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)))")
;!!!!!!!!!!!!!!!!!!!!!!!!!!
; Which means we need TODO
;!!!!!!!!!!!!!!!!!!!!!!!!!!
; 1) Change from is_val as a bool to is_val as an int, and allow negative values in certain situations
; If we're not careful about the environment it was evaluated in vs current environment, we'll also have to carry around the environment
; We might be able to call partial_eval with them, but not pass them any further down, esp into anything that might change the scope.
; This will at least allow us to decend into and partial eval the other parts of the array calling form so we can partial eval inside the body's of lets
; where the value being assigned has some later? value.
; 2) Finish up closes_over_var_from_this_env_marked so it's less finicky
;
; I think we'll need both for this to actualy work
;
let5_test (read-string "((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)))")
lambda1_test (read-string "((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 vau (array s) b) (eval v de)) de)))")
lambda2_test (read-string "((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 vau (array s) b) (eval v de)) de)))")
;!!!! Ditto to let5_test
lambda3_test (read-string "((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 vau (array s) b) (eval v de)) de)))")
array_test (read-string "(array 1 2 3 4 5)")
vararg_test (read-string "((wrap (vau (a & rest) rest)) 1 2 3 4 5)")
;do1_test (read-string "((wrap (vau (let1)
; (let1 lambda (vau se (p b) (wrap (eval (array vau p b) se)))
; (let1 do_helper (lambda (recurse s i se) (cond (= i (len s)) nil
; (= i (- (len s) 1)) (eval (idx s i) se)
; (eval (idx s i) se) (recurse recurse s (+ i 1) se)
; true (recurse recurse s (+ i 1) se)))
; (let1 do (vau se (& s) (do_helper do_helper s 0 se))
; (do (println 1 2 3)
; (println 4 5 6))
; ))))) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de)))")
;do2_test (read-string "((wrap (vau (let1)
; (let1 lambda (vau se (p b) (wrap (eval (array vau p b) se)))
; (let1 do_helper (lambda (recurse s i se) (cond (= i (len s)) nil
; (= i (- (len s) 1)) (eval (idx s i) se)
; (eval (idx s i) se) (recurse recurse s (+ i 1) se)
; true (recurse recurse s (+ i 1) se)))
; (let1 do (vau se (& s) (do_helper do_helper s 0 se))
; (do (println 1 2 3)
; (println 4 5 6))
; ))))) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de)))")
;big_test1 [[vau ['*ARGV*] (read-string (slurp "./prelude.kp"))] ["" "-C" "1339"]]
;big_test1 [[vau ['*ARGV*] (read-string (slurp "./prelude.kp"))] ["" "-C" "(let (a 17) (vau (x) a))"]]
big_test1 [[vau ['*ARGV*] (read-string (slurp "./prelude.kp"))] ["" "-C" "(let (a 17) a)"]]
;big_test1 [[vau ['*ARGV*] (read-string (slurp "./prelude.kp"))] []]
_ (test-case simple_add)
_ (test-case vau_with_add)
_ (test-case vau_with_add_called)
_ (test-case vau_with_passthrough)
_ (test-case vau_with_no_eval_add)
_ (test-case vau_with_wrap_add)
_ (test-case vau_with_add_p)
_ (test-case vau_with_add_p_called)
_ (test-case cond_test)
_ (test-case cond_vau_test)
_ (test-case cond_vau_test2)
_ (test-case combiner_test)
_ (test-case combiner_test2)
_ (test-case combiner_test3)
_ (test-case symbol_test)
_ (test-case env_test)
_ (test-case env_test2)
_ (test-case env_test3)
_ (test-case env_test4)
_ (test-case let1_test)
_ (test-case let2_test)
_ (test-case let3_test)
_ (test-case let4_test)
_ (test-case let4.3_test)
_ (test-case let4.7_test)
_ (test-case let5_test)
_ (test-case lambda1_test)
_ (test-case lambda2_test)
_ (test-case lambda3_test)
_ (test-case array_test)
_ (test-case vararg_test)
;_ (test-case do1_test)
;_ (test-case do2_test)
;_ (println "THE BIG SHOW")
;_ (println big_test1)
;_ (test-case big_test1)
) nil))

40
working_files/partial_eval_test_rec.kp Normal file
View File

@@ -0,0 +1,40 @@
(with_import "./partial_eval.kp"
(let (
test-case (lambda (source) (let (
_ (println "Source: " source)
code (read-string source)
_ (println "Code: " code)
partially_evaled (partial_eval code)
_ (println "Partially evaled: " partially_evaled)
_ (print_strip partially_evaled)
stripped (strip partially_evaled)
_ (println "Stripped: " stripped)
fully_evaled (eval stripped root_env)
_ (println "Fully evaled: " fully_evaled)
fully_evaled_called (if (combiner? fully_evaled) (fully_evaled 1337))
_ (if (combiner? fully_evaled) (println "..and called " fully_evaled_called))
outer_eval (eval code root_env)
_ (println " outer-eval " outer_eval)
outer_called (if (combiner? outer_eval) (outer_eval 1337))
_ (if (combiner? outer_eval) (println "..and outer called " outer_called))
_ (cond (or (combiner? fully_evaled) (combiner? outer_eval))
(if (!= fully_evaled_called outer_called) (error (str "called versions unequal for " code " are " fully_evaled_called " vs " outer_called)))
(!= fully_evaled outer_eval) (error (str "partial-eval versions unequal for " code " are " fully_evaled " vs " outer_eval))
true nil)
_ (println)
) fully_evaled))
;_ (test-case "(+ 1 2)")
_ (test-case "((wrap (vau (x n) (x x n))) (wrap (vau (self n) (cond (= n 0) 10 true (self self (- n 1))))) 2)")
;_ (test-case "((wrap (vau (let1)
; (let1 lambda (vau se (p b) (wrap (eval (array vau p b) se)))
; (let1 current-env (vau de () de)
; (let1 cons (lambda (h t) (concat (array h) t))
; (let1 lapply (lambda (f p) (eval (cons (unwrap f) p) (current-env)))
; (lambda (x) x)
; )))))) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de)))")
) nil))

297
working_files/prelude.kp Normal file
View File

@@ -0,0 +1,297 @@
((wrap (vau root_env (quote)
((wrap (vau (let1)
(let1 lambda (vau se (p b) (wrap (eval (array vau p b) se)))
(let1 do_helper (lambda (recurse s i se) (cond (= i (len s)) nil
(= i (- (len s) 1)) (eval (idx s i) se)
(eval (idx s i) se) (recurse recurse s (+ i 1) se)
true (recurse recurse s (+ i 1) se)))
(let1 do (vau se (& s) (do_helper do_helper s 0 se))
(let1 current-env (vau de () de)
(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))))))
(let1 vY (lambda (f)
((lambda (x) (x x))
(lambda (x) (f (vau de (& y) (vapply (x x) y de))))))
(let1 let (vY (lambda (recurse) (vau de (vs b) (cond (= (len vs) 0) (eval b de)
true (vapply let1 (array (idx vs 0) (idx vs 1) (array recurse (slice vs 2 -1) b)) de)))))
(let (
print_through (lambda (x) (do (println x) x))
lcompose (lambda (g f) (lambda (& args) (lapply g (array (lapply f args)))))
rec-lambda (vau se (n p b) (eval (array Y (array lambda (array n) (array lambda p b))) se))
if (vau de (con than & else) (cond (eval con de) (eval than de)
(> (len else) 0) (eval (idx else 0) de)
true nil))
map (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 (idx l (+ i 0)))
(f (idx l (+ i 1)))
(f (idx l (+ i 2)))
(f (idx l (+ i 3)))
)) (+ i 4))
true (recurse f l (concat n (array (f (idx l i)))) (+ i 1)))))
(helper f l (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))
not (lambda (x) (if x false true))
; 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))) (slice (idx vs i) 1 -1))
)
(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))
lambda (vau se (p b) (if (only_symbols p 0) (vapply lambda (array p b) se)
(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)
) (wrap (eval (array vau sym_params body) 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))
is_pair? (lambda (x) (and (array? x) (> (len x) 0)))
quasiquote (vY (lambda (recurse) (vau de (x)
(cond (is_pair? x)
(cond (and (symbol? (idx x 0)) (= (get-text (idx x 0)) "unquote"))
(eval (idx x 1) de)
true
(cond (and (is_pair? (idx x 0)) (symbol? (idx (idx x 0) 0)) (= (get-text (idx (idx x 0) 0)) "splice-unquote"))
(concat (eval (idx (idx x 0) 1) de) (vapply recurse (array (slice x 1 -1)) de))
true
(concat (array (vapply recurse (array (idx x 0)) de)) (vapply recurse (array (slice x 1 -1)) de))))
true x))))
repl (vY (lambda (recurse) (wrap (vau de (grammer start_symbol)
(do (recover (println (eval (read-string (get_line "> ") grammer start_symbol) de))
captured_error (println "repl caught an exception:" captured_error))
(eval (array recurse (array quote grammer) (array quote start_symbol)) de))))))
string-to-int (lambda (s) (let (
c0 (idx "0" 0)
c9 (idx "9" 0)
ca (idx "a" 0)
cz (idx "z" 0)
cA (idx "A" 0)
cZ (idx "Z" 0)
helper (rec-lambda recurse (s i radix result)
(if (< i (len s))
(let (c (idx s i))
(cond (<= c0 c c9) (recurse s (+ i 1) radix (+ (* radix result) (- (idx s i) c0)))
(<= ca c cz) (recurse s (+ i 1) radix (+ (* radix result) (+ 10 (- (idx s i) ca))))
(<= cA c cZ) (recurse s (+ i 1) radix (+ (* radix result) (+ 10 (- (idx s i) cA))))
true (error "Impossible char in string-to-int"))
)
result
)
))
(cond (= (idx s 0) (idx "-" 0)) (- (helper s 1 10 0))
(and (> (len s) 2) (or (= "0x" (slice s 0 2)) (= "0X" (slice s 0 2)))) (helper s 2 16 0)
true (helper s 0 10 0))
))
unescape-str (lambda (s) (let (
helper (rec-lambda recurse (s i r)
(cond (>= (+ 1 i) (len s)) r
(= (idx s i) (idx "\\" 0)) (cond (= (+ i 1) (len s)) "BAD ESCAPE AT END"
(= (idx s (+ i 1)) (idx "n" 0)) (recurse s (+ i 2) (str r "\n"))
(= (idx s (+ i 1)) (idx "t" 0)) (recurse s (+ i 2) (str r "\t"))
(= (idx s (+ i 1)) (idx "0" 0)) (recurse s (+ i 2) (str r "\0"))
(= (idx s (+ i 1)) (idx "\\" 0)) (recurse s (+ i 2) (str r "\\"))
(= (idx s (+ i 1)) (idx "\"" 0)) (recurse s (+ i 2) (str r "\""))
true "BAD ESCAPE IS NORMAL CHAR"
)
true (recurse s (+ i 1) (str r (slice s i (+ i 1))))
)
)) (helper s 1 "")))
basic_rules (array
(array (quote WS) (array "( | |
|(;[ -~]*
))+") (lambda (x) nil))
(array (quote number) (array "(0(x|X)([0-9]|[a-f]|[A-F])+)|(-?[0-9]+)") (lambda (x) (string-to-int x)))
(array (quote string) (array "\"([#-[]| |[]-~]|(\\\\\\\\)|(\\\\n)|(\\\\t)|(\\*)|(\\\\0)|
|[ -!]|(\\\\\"))*\"") (lambda (x) (unescape-str x)))
(array (quote bool_nil_symbol) (array "-|(([a-z]|[A-Z]|_|\\*|/|\\?|\\+|!|=|&|\\||<|>|%|$|\\.)([a-z]|[A-Z]|_|[0-9]|\\*|\\?|\\+|-|!|=|&|\\||<|>|%|$|\\.)*)") (lambda (x) (cond (= "true" x) true
(= "false" x) false
(= "nil" x) nil
true (str-to-symbol x))))
)
provide (vau de (& items) (array let
(flat_map (lambda (item) (array item (array quote (eval item de)))) items)))
scope_let_sans_import_gram (provide
root_env
current-env
lambda
rec-lambda
let
let-rec
let-vrec
do
if
cons
map
map_i
flat_map
flat_map_i
filter_i
filter
not
lapply
vapply
lcompose
Y
vY
Y*
quote
quasiquote
repl
provide
print_through
basic_rules
)
insert_into_scope_let (lambda (scope_let name item) (array (idx scope_let 0) (concat (idx scope_let 1) (array name (array quote item)))))
scope_let (let-vrec (
with_import (vau de (lib_path code)
(let (imported_scope_let (eval (concat
(insert_into_scope_let
(insert_into_scope_let scope_let_sans_import_gram (quote standard_grammar) (gen_standard_grammar))
(quote with_import) with_import)
(array (read-string (slurp (eval lib_path de)) (gen_standard_grammar) (quote start_symbol)))) root_env))
(eval (concat imported_scope_let (array code)) de)))
gen_standard_grammar (vau de () (concat basic_rules (array
(array (quote form) (array (quote number)) (lambda (x) x))
(array (quote form) (array (quote string)) (lambda (x) x))
(array (quote form) (array (quote bool_nil_symbol)) (lambda (x) x))
(array (quote form) (array "\\(" (quote WS) * "\\)" ) (lambda (_ _ _) (array)))
(array (quote form) (array "\\(" (quote WS) * (quote form) (array (quote WS) + (quote form)) * (quote WS) * "\\)" ) (lambda (_ _ head tail _ _) (concat (array head) (map (lambda (x) (idx x 1)) tail))))
(array (quote form) (array "\\[" (quote WS) * "\\]" ) (lambda (_ _ _) (array array)))
(array (quote form) (array "\\[" (quote WS) * (quote form) (array (quote WS) + (quote form)) * (quote WS) * "\\]" ) (lambda (_ _ head tail _ _) (concat (array array head) (map (lambda (x) (idx x 1)) tail))))
(array (quote form) (array "'" (quote WS) * (quote form)) (lambda (_ _ x) (array quote x)))
(array (quote form) (array "`" (quote WS) * (quote form)) (lambda (_ _ x) (array quasiquote x)))
(array (quote form) (array "~" (quote WS) * (quote form)) (lambda (_ _ x) (array (quote unquote) x)))
(array (quote form) (array "," (quote WS) * (quote form)) (lambda (_ _ x) (array (quote splice-unquote) x)))
(array (quote start_symbol) (array (quote WS) * (quote form) (quote WS) *) (lambda (_ f _) f))
(array (quote start_symbol) (array (quote WS) * "#lang" (quote WS) (quote form) (quote WS) (quote form) "([ -~]|
)*")
(lambda (_ _ _ gram _ symbol source) (do (println "gonna do that # yo") (read-string source
(eval (concat
(insert_into_scope_let
(insert_into_scope_let scope_let_sans_import_gram (quote standard_grammar) (gen_standard_grammar))
(quote with_import) with_import)
(array gram)) root_env)
symbol))))
)))
)
(insert_into_scope_let
(insert_into_scope_let scope_let_sans_import_gram (quote standard_grammar) (gen_standard_grammar))
(quote with_import) with_import)
)
standard_grammar (eval (concat scope_let (array (quote standard_grammar))) root_env)
)
(do
(println "Welcome to Kraken! Parameters were" *ARGV*)
(cond (and (>= (len *ARGV*) 3) (= "-C" (idx *ARGV* 1))) (eval (concat scope_let (array (read-string (idx *ARGV* 2) standard_grammar (quote start_symbol)))) root_env)
(> (len *ARGV*) 1) (eval (concat scope_let (array (read-string (slurp (idx *ARGV* 1)) standard_grammar (quote start_symbol)))) root_env)
true (eval (concat scope_let (array (array repl (array quote standard_grammar) (array quote (quote start_symbol))))) root_env)
)
)
)
)))))))))) ; end of all the let1's
; impl of let1
)) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de)))
; impl of quote
)) (vau (x) x))

132
working_files/rb.kp Normal file
View File

@@ -0,0 +1,132 @@
(with_import "./match.kp"
(let (
; This is based on https://www.cs.cornell.edu/courses/cs3110/2020sp/a4/deletion.pdf
; and the figure references refer to it
; Insert is taken from the same paper, but is origional to Okasaki, I belive
; The tree has been modified slightly to take in a comparison function
; and override if insert replaces or not to allow use as a set or as a map
; I think this is actually pretty cool - instead of having a bunch of seperate ['B]
; be our leaf node, we use ['B] with all nils. This allows us to not use -B, as
; both leaf and non-leaf 'BB has the same structure with children! Also, we make
; sure to use empty itself so we don't make a ton of empties...
empty ['B nil nil nil]
E empty
EE ['BB nil nil nil]
size (rec-lambda recurse (t) (match t
~E 0
[c a x b] (+ 1 (recurse a) (recurse b))))
generic-foldl (rec-lambda recurse (f z t) (match t
~E z
[c a x b] (recurse f (f (recurse f z a) x) b)))
generic-contains? (rec-lambda recurse (t cmp v found not-found) (match t
~E (not-found)
[c a x b] (match (cmp v x) '< (recurse a cmp v found not-found)
'= (found x)
'> (recurse b cmp v found not-found))))
blacken (lambda (t) (match t
['R a x b] ['B a x b]
t t))
balance (lambda (t) (match t
; figures 1 and 2
['B ['R ['R a x b] y c] z d] ['R ['B a x b] y ['B c z d]]
['B ['R a x ['R b y c]] z d] ['R ['B a x b] y ['B c z d]]
['B a x ['R ['R b y c] z d]] ['R ['B a x b] y ['B c z d]]
['B a x ['R b y ['R c z d]]] ['R ['B a x b] y ['B c z d]]
; figure 8, double black cases
['BB ['R a x ['R b y c]] z d] ['B ['B a x b] y ['B c z d]]
['BB a x ['R ['R b y c] z d]] ['B ['B a x b] y ['B c z d]]
; already balenced
t t))
generic-insert (lambda (t cmp v replace) (let (
ins (rec-lambda ins (t) (match t
~E ['R t v t]
[c a x b] (match (cmp v x) '< (balance [c (ins a) x b])
'= (if replace [c a v b]
t)
'> (balance [c a x (ins b)]))))
) (blacken (ins t))))
rotate (lambda (t) (match t
; case 1, fig 6
['R ['BB a x b] y ['B c z d]] (balance ['B ['R ['B a x b] y c] z d])
['R ['B a x b] y ['BB c z d]] (balance ['B a x ['R b y ['B c z d]]])
; case 2, figure 7
['B ['BB a x b] y ['B c z d]] (balance ['BB ['R ['B a x b] y c] z d])
['B ['B a x b] y ['BB c z d]] (balance ['BB a x ['R b y ['B c z d]]])
; case 3, figure 9
['B ['BB a w b] x ['R ['B c y d] z e]] ['B (balance ['B ['R ['B a w b] x c] y d]) z e]
['B ['R a w ['B b x c]] y ['BB d z e]] ['B a w (balance ['B b x ['R c y ['B d z e]]])]
; fall through
t t))
redden (lambda (t) (match t
['B a x b] (if (and (= 'B (idx a 0)) (= 'B (idx b 0))) ['R a x b]
t)
t t))
min_delete (rec-lambda recurse (t) (match t
~E (error "min_delete empty tree")
['R ~E x ~E] [x E]
['B ~E x ~E] [x EE]
['B ~E x ['R a y b]] [x ['B a y b]]
[c a x b] (let ((v ap) (recurse a)) [v (rotate [c ap x b])])))
generic-delete (lambda (t cmp v) (let (
del (rec-lambda del (t v) (match t
; figure 3
~E t
; figure 4
['R ~E x ~E] (match (cmp v x) '= E
_ t)
['B ['R a x b] y ~E] (match (cmp v y) '< (rotate ['B (del ['R a x b] v) y ~E])
'= ['B a x b]
'> t)
; figure 5
['B ~E x ~E] (match (cmp v x) '= EE
_ t)
[c a x b] (match (cmp v x) '< (rotate [c (del a v) x b])
'= (let ([vp bp] (min_delete b))
(rotate [c a vp bp]))
'> (rotate [c a x (del b v)]))))
) (del (redden t) v)))
set-cmp (lambda (a b) (cond (< a b) '<
(= a b) '=
true '>))
set-empty empty
set-foldl generic-foldl
set-insert (lambda (t x) (generic-insert t set-cmp x false))
set-contains? (lambda (t x) (generic-contains? t set-cmp x (lambda (f) true) (lambda () false)))
set-remove (lambda (t x) (generic-delete t set-cmp x))
map-cmp (lambda (a b) (let (ak (idx a 0)
bk (idx b 0))
(cond (< ak bk) '<
(= ak bk) '=
true '>)))
map-empty empty
map-insert (lambda (t k v) (generic-insert t map-cmp [k v] true))
map-contains-key? (lambda (t k) (generic-contains? t map-cmp [k nil] (lambda (f) true) (lambda () false)))
map-get (lambda (t k) (generic-contains? t map-cmp [k nil] (lambda (f) (idx f 1)) (lambda () (error (str "didn't find key " k " in map " t)))))
map-get-or-default (lambda (t k d) (generic-contains? t map-cmp [k nil] (lambda (f) (idx f 1)) (lambda () d)))
map-get-with-default (lambda (t k d) (generic-contains? t map-cmp [k nil] (lambda (f) (idx f 1)) (lambda () (d))))
map-remove (lambda (t k) (generic-delete t map-cmp [k nil]))
; This could be 2x as efficent by being implmented on generic instead of map,
; as we wouldn't have to traverse once to find and once to insert
multimap-empty map-empty
multimap-insert (lambda (t k v) (map-insert t k (set-insert (map-get-or-default t k set-empty) v)))
multimap-get (lambda (t k) (map-get-or-default t k set-empty))
)
(provide set-empty set-foldl set-insert set-contains? set-remove
map-empty map-insert map-contains-key? map-get map-get-or-default map-get-with-default map-remove
multimap-empty multimap-insert multimap-get
size)
))

50
working_files/rb_test.kp Normal file
View File

@@ -0,0 +1,50 @@
(with_import "./rb.kp"
(let (
first set-empty
_ (println first " set-contains? " 1 " ? " (set-contains? first 1) " size " (size first))
second (set-insert first 1)
_ (println second " set-contains? " 1 " ? " (set-contains? second 1) " size " (size second))
third (set-insert second 2)
_ (println third " set-contains? " 1 " ? " (set-contains? third 1) " size " (size third))
_ (println third " set-contains? " 2 " ? " (set-contains? third 2) " size " (size third))
fourth (set-insert third 3)
_ (println fourth " set-contains? " 1 " ? " (set-contains? fourth 1) " size " (size fourth))
_ (println fourth " set-contains? " 2 " ? " (set-contains? fourth 2) " size " (size fourth))
_ (println fourth " set-contains? " 3 " ? " (set-contains? fourth 3) " size " (size fourth))
_ (println fourth " set-contains? " 4 " ? " (set-contains? fourth 4) " size " (size fourth))
_ (println fourth " foldl with + " (set-foldl + 0 fourth))
fifth (set-remove fourth 1)
_ (println fifth " set-contains? " 1 " ? " (set-contains? fifth 1) " size " (size fifth))
_ (println fifth " set-contains? " 2 " ? " (set-contains? fifth 2) " size " (size fifth))
_ (println fifth " set-contains? " 3 " ? " (set-contains? fifth 3) " size " (size fifth))
_ (println fifth " set-contains? " 4 " ? " (set-contains? fifth 4) " size " (size fifth))
sixth (set-remove fifth 3)
_ (println sixth " set-contains? " 1 " ? " (set-contains? sixth 1) " size " (size sixth))
_ (println sixth " set-contains? " 2 " ? " (set-contains? sixth 2) " size " (size sixth))
_ (println sixth " set-contains? " 3 " ? " (set-contains? sixth 3) " size " (size sixth))
_ (println sixth " set-contains? " 4 " ? " (set-contains? sixth 4) " size " (size sixth))
seventh (set-remove sixth 2)
_ (println seventh " set-contains? " 1 " ? " (set-contains? seventh 1) " size " (size seventh))
_ (println seventh " set-contains? " 2 " ? " (set-contains? seventh 2) " size " (size seventh))
_ (println seventh " set-contains? " 3 " ? " (set-contains? seventh 3) " size " (size seventh))
_ (println seventh " set-contains? " 4 " ? " (set-contains? seventh 4) " size " (size seventh))
first map-empty
_ (println first " map-contains-key? " 1 " ? " (map-contains-key? first 1) " size " (size first))
second (map-insert first 1 "hello")
_ (println second " map-contains-key? " 1 " ? " (map-contains-key? second 1) " size " (size second))
_ (println second " map-get " 1 " ? " (map-get second 1) " size " (size second))
third (map-insert second 1 "goodbye")
_ (println third " map-contains-key? " 1 " ? " (map-contains-key? third 1) " size " (size third))
_ (println third " map-get " 1 " ? " (map-get third 1) " size " (size third))
fourth (map-insert third 2 "hmmm")
_ (println fourth " map-contains-key? " 2 " ? " (map-contains-key? fourth 2) " size " (size fourth))
_ (println fourth " map-get " 2 " ? " (map-get fourth 2) " size " (size fourth))
_ (println fourth " map-contains-key? " 1 " ? " (map-contains-key? fourth 1) " size " (size fourth))
_ (println fourth " map-get " 1 " ? " (map-get fourth 1) " size " (size fourth))
_ (println fourth " map-contains-key? " 3 " ? " (map-contains-key? fourth 3) " size " (size fourth))
_ (println fourth " map-get-or-default " 3 " 'hi ? " (map-get-or-default fourth 3 'hi) " size " (size fourth))
_ (println fourth " map-get-with-default " 3 " (lambda () 'bye) ? " (map-get-with-default fourth 3 (lambda () 'bye)) " size " (size fourth))
fifth (map-remove fourth 2)
_ (println fifth " map-contains-key? " 2 " ? " (map-contains-key? fifth 2) " size " (size fifth))
) nil))

38
working_files/sierpinski.kp Normal file
View File

@@ -0,0 +1,38 @@
(with_import "./collections.kp"
(let (
to_bpm (lambda (x) (let (
rows (len x)
cols (len (idx x 0))
file "P1"
file (str file "\n" cols " " rows)
file (foldl (lambda (a row)
(str a "\n" (foldl (lambda (a x)
(str a " " x)
) "" row))
) file x)
) file))
stack concat
side (lambda (a b) (foldl (lambda (a b c) (concat a [(concat b c) ]))
[] a b))
padding (rec-lambda recurse (r c)
(cond (and (= 1 r) (= 1 c)) [ [ 0 ] ]
(= 1 c) (let (x (recurse (/ r 2) c)) (stack x x))
true (let (x (recurse r (/ c 2))) (side x x))))
shape [ [ 1 1 ]
[ 1 1 ] ]
sierpinski (rec-lambda recurse (depth)
(if (= depth 1) shape
(let (s (recurse (/ depth 2))
p (padding depth (/ depth 2))
) (stack (side (side p s) p)
(side s s))))
)
img (to_bpm (sierpinski 64))
) (write_file "./sierpinski.pbm" img)
))

15
working_files/smaller_new_kraken_test.kp Normal file
View File

@@ -0,0 +1,15 @@
#lang (with_import "./new_kraken.kp" new_kraken_untyped) new_kraken_start_symbol
let my_var = 1337
println("Hello world!")
println("my_var is:" my_var)
println($"empty string interp")
println($"var string interp: $my_var")
println($"var expr interp: ${+(2 3)}")
fun test() {
let plus_1 = |x| { +(3 1) }
let a = 1
let b = plus_1(a)
println("some" b)
1338
}
println("test is:" test())

35
working_files/test.csc Normal file
View File

@@ -0,0 +1,35 @@
; Going to set some aliases just for this, the scheme version
; commenting out the first let with it's final ) should make this
; legal kraken
(import (chicken process-context))
(import (chicken port))
(load "partial_eval.csc")
(import (partial_eval))
(let* (
(array list)
(concat append)
(len length)
(idx list-ref)
;(array vector)
;(concat vector-append) ; only in extension vector library!
;(len vector-length)
;(idx vector-ref)
(= equal?)
)
(print (array 1 2 3))
(print (command-line-arguments))
(print (call-with-input-string "'(1 2)" (lambda (p) (read p))))
(print partial_eval)
)

3
working_files/test_parse_in Normal file
View File

@@ -0,0 +1,3 @@
(false (true "a\"b\tc\\d\nefg" 1336 -1337 1338 0xDEAD 0xBEEF 0b101 0b1111 0b0 -0b101 hmmmm
; a
haaaa drat trueeee 'hehe '(ho ho ho 12 333 "a" true false) () true) true)

1
working_files/test_parse_in_large Normal file
View File

@@ -0,0 +1 @@
(false (true "a\"b\tc\\d\nefg" 1336 -1337 1338 0xDEAD 0xBEEF 0b101 0b1111 0b0 -0b101 hmmmm haaaa drat trueeee 'hehe '(ho ho ho 12 333 "a" true false) () true) true)

6
working_files/test_ystar_vau.kp Normal file
View File

@@ -0,0 +1,6 @@
(let-vrec (
first (vau de (n) (eval n de))
second (vau de (n) (eval n de))
)
(first (second "Hi!"))
)

141
working_files/types.kp Normal file
View File

@@ -0,0 +1,141 @@
(let (
; 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)))
contains (let (contains-helper (rec-lambda recurse (s x i) (cond (= i (len s)) false
(= x (idx s i)) true
true (recurse s x (+ i 1)))))
(lambda (s x) (contains-helper s x 0)))
applyST (rec-lambda recurse (S t)
(cond
; I think x should be (idx x 0)
(meta t) (with-meta (recurse (filter (lambda (x) (not (contains (meta t) x))) S) (with-meta t nil)) (meta t))
(int? t) (or (lookup S t) t)
(array? t) (map (lambda (x) (recurse S x)) t)
true t
))
applySE (lambda (S env) (map (lambda (x) [(idx x 0) (applyST S (idx x 1))]) env))
applySS (lambda (S_0 S_1) (let (r (concat S_0 (applySE S_0 S_1)) _ (println "applySS of " S_0 " and " S_1 " is " r)) r))
fvT (rec-lambda recurse (t) (cond (meta t) (filter (lambda (x) (not (contains (meta t) x))) (recurse (with-meta t nil)))
(int? t) [t]
(array? t) (flat_map recurse t)
true []
))
fvE (lambda (env) (flat_map (lambda (x) (fvT (idx x 1))) env))
varBind (lambda (a b) (cond
(= a b) []
(contains (fvT b) a) (error "Contains check failed for " a " and " b)
true [ [a b] ]))
mgu (rec-lambda mgu (a b) (let (r (cond
(and (array? a) (array? b) (= (len a) (len b))) ((rec-lambda recurse (S i) (if (= i (len a)) S
(recurse (applySS (mgu (idx a i) (idx b i)) S) (+ 1 i)))) [] 0)
(int? a) (varBind a b)
(int? b) (varBind b a)
(= a b) []
true (error (str "Cannot unify " a " and " b))
) _ (println "mgu of " a " and " b " is " r)) r))
generalize (lambda (env t) (do (println "generalize " t " with respect to " env) (let (free_T (fvT t)
free_E (fvE env))
(with-meta t (filter (lambda (x) (not (contains free_E x))) free_T)))))
instantiate (lambda (sigma idn) (do (println "instantiate " sigma " meta is " (meta sigma)) [(applyST (map_i (lambda (x i) [x (+ i idn)]) (meta sigma)) (with-meta sigma nil)) (+ idn (len (meta sigma)))]))
execute_type_com (lambda (tc e idn) (tc e idn))
simple_type_com (lambda (exp typ) (lambda (env idn) [exp typ [] idn]))
symbol_type_com (lambda (sym) (lambda (env idn) (let (
(t idn) (instantiate (lookup env sym) idn))
[sym t [] idn])))
call_type_com (lambda (innards)
(lambda (env idn)
(if (= 0 (len innards)) (error "stlc_error: Can't have a 0-length call")
(let (
(f_e f_t S_0 idn) (execute_type_com (idx innards 0) env idn)
across_params (rec-lambda recurse (env S idn params i out_e out_t)
(if (= i (len params)) [out_e out_t S idn]
(let (
(p_e p_t S_i idn) (execute_type_com (idx params i) env idn)
) (recurse (applySE S_i env) (applySS S_i S) idn params (+ 1 i) (concat out_e [p_e]) (concat out_t [p_t])))))
(p_es p_ts S_ps idn) (across_params (applySE S_0 env) [] idn (slice innards 1 -1) 0 [] [])
(r_t idn) [idn (+ 1 idn)]
S_f (mgu (applyST S_ps f_t) [p_ts r_t])
_ (println "mgu of " (applyST S_ps f_t) " and " [p_ts r_t] " produces substitution " S_f)
_ (println "For this call: " (cons f_e p_es) " the return type " r_t " transformed by " S_f " is " (applyST S_f r_t))
) [(cons f_e p_es) (applyST S_f r_t) (applySS S_f (applySS S_ps S_0)) idn])
)
)
)
lambda_type_com (lambda (p t b)
(lambda (env idn)
(let (
(p_t idn) (if (= nil t) [idn (+ 1 idn)]
[t idn])
extended_env (cons [p (with-meta p_t [])] env)
(b_e b_t S idn) (execute_type_com b extended_env idn)
f_e [lambda [p] b_e]
f_t [[ (applyST S p_t) ] b_t]
) [f_e f_t S idn])
)
)
let_type_com (lambda (x e1 e2)
(lambda (env0 idn)
(let (
(e1_e e1_t S_0 idn) (execute_type_com e1 env0 idn)
env1 (applySE S_0 env0)
e1_sigma (generalize env1 e1_t)
extended_env (cons [x e1_sigma] env1)
(e2_e e2_t S_1 idn) (execute_type_com e2 extended_env idn)
l_e [[lambda [x] e2_e] e1_e]
l_t e2_t
) [l_e l_t (applySS S_1 S_0) idn])
)
)
base_env [
[ '+ (with-meta [['int 'int] 'int] []) ]
[ '- (with-meta [['int 'int] 'int] []) ]
[ '< (with-meta [['int 'int] 'bool] []) ]
[ '> (with-meta [['int 'int] 'bool] []) ]
[ 'println (with-meta [['str] 'void] []) ]
]
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)
top-level-erase-and-check (lambda (e) (let (
(e t S idn) (execute_type_com e base_env 0)
_ (println "Type of program is " t " with sub " S)
_ (println "expression code is " e)
) e))
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)
)
) ]
[ 'expr [ "\\\\" 'WS * 'bool_nil_symbol 'WS * ":" 'WS * 'bool_nil_symbol 'WS * "." 'WS * 'expr ] (lambda (_ _ p _ _ _ t _ _ _ b) (lambda_type_com p t b)) ]
[ 'expr [ "\\\\" 'WS * 'bool_nil_symbol 'WS * "." 'WS * 'expr ] (lambda (_ _ p _ _ _ b) (lambda_type_com p nil b)) ]
[ 'call_innards [ 'WS * ] (lambda (_) []) ]
[ 'call_innards [ 'expr [ 'WS 'expr ] * ] (lambda (f r) (cons f (map (lambda (x) (idx x 1)) r))) ]
[ 'expr [ "\\(" 'call_innards "\\)" ] (lambda (_ innards _) (call_type_com innards)) ]
[ 'stlc_start_symbol [ 'WS * 'expr 'WS * ] (lambda (_ e _) [eval (top-level-erase-and-check e) builtin_real_env]) ]
]))
(provide stlc)
)

2
working_files/types_test.kp Normal file
View File

@@ -0,0 +1,2 @@
#lang (with_import "./types.kp" stlc) stlc_start_symbol
(\ id . ((id println) (id "woo"))) \ x . x

384
working_files/wasm.kp Normal file
View File

@@ -0,0 +1,384 @@
(with_import "./collections.kp"
(let (
; Vectors and Values
; Bytes encode themselves
encode_LEB128_helper (rec-lambda recurse (allow_neg x)
(cond (and allow_neg (< x 0x80)) [x]
(< x 0x40) [x]
true (cons (| (& x 0x7F) 0x80) (recurse true (>> x 7))))
)
encode_u_LEB128 (lambda (x) (encode_LEB128_helper true x))
encode_s8_LEB128 (lambda (x) (encode_LEB128_helper (< x 0) (& x 0xFF)))
encode_s32_LEB128 (lambda (x) (encode_LEB128_helper (< x 0) (& x 0xFFFFFFFF)))
encode_s33_LEB128 (lambda (x) (encode_LEB128_helper (< x 0) (& x 0x1FFFFFFFF)))
encode_s64_LEB128 (lambda (x) (encode_LEB128_helper (< x 0) (& x 0xFFFFFFFFFFFFFFFF)))
encode_vector (lambda (enc v)
(concat (encode_u_LEB128 (len v)) (flat_map enc v) )
)
encode_floating_point (lambda (x) (error "unimplemented"))
encode_name (lambda (name)
(encode_vector (lambda (x) [x]) name)
)
encode_bytes encode_name
; Types
; TODO
encode_limits (lambda (x)
(cond (= 1 (len x)) (concat [0x00] (encode_u_LEB128 (idx x 0)))
(= 2 (len x)) (concat [0x01] (encode_u_LEB128 (idx x 0)) (encode_u_LEB128 (idx x 1)))
true (error "trying to encode bad limits"))
)
encode_number_type (lambda (x)
(cond (= x 'i32) [0x7F]
(= x 'i64) [0x7E]
(= x 'f32) [0x7D]
(= x 'f64) [0x7C]
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 [0x60] (encode_result_type (idx x 0))
(encode_result_type (idx x 1)))
)
; Modules
encode_type_section (lambda (x)
(let (
encoded (encode_vector encode_function_type x)
) (concat [0x01] (encode_u_LEB128 (len encoded)) encoded ))
)
encode_import (lambda (import)
(let (
(mod_name name type idx) import
) (concat (encode_name mod_name)
(encode_name name)
(cond (= type 'func) (concat [0x00] (encode_u_LEB128 idx))
(= type 'table) (concat [0x01] (error "can't encode table type"))
(= type 'memory) (concat [0x02] (error "can't encode memory type"))
(= type 'global) (concat [0x03] (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 [0x02] (encode_u_LEB128 (len encoded)) encoded ))
)
encode_ref_type (lambda (t) (cond (= t 'funcref) [0x70]
(= t 'externref) [0x6F]
true (error (str "Bad ref type " t))))
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 [0x04] (encode_u_LEB128 (len encoded)) encoded ))
)
encode_memory_section (lambda (x)
(let (
encoded (encode_vector encode_limits x)
) (concat [0x05] (encode_u_LEB128 (len encoded)) encoded ))
)
encode_export (lambda (export)
(let (
(name type idx) export
) (concat (encode_name name)
(cond (= type 'func) [0x00]
(= type 'table) [0x01]
(= type 'memory) [0x02]
(= type 'global) [0x03]
true (error "bad export type"))
(encode_u_LEB128 idx)
))
)
encode_export_section (lambda (x)
(let (
encoded (encode_vector encode_export x)
) (concat [0x07] (encode_u_LEB128 (len encoded)) encoded ))
)
encode_start_section (lambda (x)
(cond (= 0 (len x)) []
(= 1 (len x)) (let (encoded (encode_u_LEB128 (idx x 0))) (concat [0x08] (encode_u_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_u_LEB128 filtered)
) (concat [0x03] (encode_u_LEB128 (len encoded)) encoded ))
)
encode_blocktype (lambda (type) (cond (symbol? type) (encode_valtype type)
(= [] type) [0x40] ; empty type
true (encode_s33_LEB128 typ)
))
encode_ins (rec-lambda recurse (ins)
(let (
op (idx ins 0)
) (cond (= op 'unreachable) [0x00]
(= op 'nop) [0x01]
(= op 'block) (concat [0x02] (encode_blocktype (idx ins 1)) (flat_map recurse (idx ins 2)) [0x0B])
(= op 'loop) (concat [0x03] (encode_blocktype (idx ins 1)) (flat_map recurse (idx ins 2)) [0x0B])
(= op 'if) (concat [0x04] (encode_blocktype (idx ins 1)) (flat_map recurse (idx ins 2)) (if (!= 3 (len ins)) (concat [0x05] (flat_map recurse (idx ins 3)))
[]) [0x0B])
(= op 'br) (concat [0x0C] (encode_u_LEB128 (idx ins 1)))
(= op 'br_if) (concat [0x0D] (encode_u_LEB128 (idx ins 1)))
;...
(= op 'return) [0x0F]
(= op 'call) (concat [0x10] (encode_u_LEB128 (idx ins 1)))
; call_indirect
; skipping a bunch
; Parametric Instructions
(= op 'drop) [0x1A]
; skip
; Variable Instructions
(= op 'local.get) (concat [0x20] (encode_u_LEB128 (idx ins 1)))
(= op 'local.set) (concat [0x21] (encode_u_LEB128 (idx ins 1)))
(= op 'local.tee) (concat [0x22] (encode_u_LEB128 (idx ins 1)))
(= op 'global.get) (concat [0x23] (encode_u_LEB128 (idx ins 1)))
(= op 'global.set) (concat [0x24] (encode_u_LEB128 (idx ins 1)))
; table
; memory
(= op 'i32.load) (concat [0x28] (encode_u_LEB128 (idx ins 1)) (encode_u_LEB128 (idx ins 2)))
(= op 'i64.load) (concat [0x29] (encode_u_LEB128 (idx ins 1)) (encode_u_LEB128 (idx ins 2)))
(= op 'i32.store) (concat [0x36] (encode_u_LEB128 (idx ins 1)) (encode_u_LEB128 (idx ins 2)))
(= op 'i64.store) (concat [0x37] (encode_u_LEB128 (idx ins 1)) (encode_u_LEB128 (idx ins 2)))
; Numeric Instructions
(= op 'i32.const) (concat [0x41] (encode_s32_LEB128 (idx ins 1)))
(= op 'i64.const) (concat [0x42] (encode_s64_LEB128 (idx ins 1)))
; skip
(= op 'i32.add) [0x6A]
))
)
encode_expr (lambda (expr) (concat (flat_map encode_ins expr) [0x0B]))
encode_code (lambda (x)
(let (
(locals body) x
enc_locals (encode_vector (lambda (loc)
(concat (encode_u_LEB128 (idx loc 0)) (encode_valtype (idx loc 1)))) locals)
enc_expr (encode_expr body)
code_bytes (concat enc_locals enc_expr)
) (concat (encode_u_LEB128 (len code_bytes)) code_bytes))
)
encode_code_section (lambda (x)
(let (
encoded (encode_vector encode_code x)
) (concat [0x0A] (encode_u_LEB128 (len encoded)) encoded ))
)
encode_global_type (lambda (t) (concat (encode_valtype (idx t 0)) (cond (= (idx t 1) 'const) [0x00]
(= (idx t 1) 'mut) [0x01]
true (error (str "bad mutablity " (idx t 1))))))
encode_global_section (lambda (global_section)
(let (
encoded (encode_vector (lambda (x) (concat (encode_global_type (idx x 0)) (encode_expr (idx x 1)))) global_section)
) (concat [0x06] (encode_u_LEB128 (len encoded)) encoded ))
)
; only supporting one type of element section for now, active funcrefs with offset
encode_element (lambda (x) (concat [0x00] (encode_expr (idx x 0)) (encode_vector encode_u_LEB128 (idx x 1))))
encode_element_section (lambda (x)
(let (
encoded (encode_vector encode_element x)
) (concat [0x09] (encode_u_LEB128 (len encoded)) encoded ))
)
encode_data (lambda (data) (cond (= 2 (len data)) (concat [0x00] (encode_expr (idx data 0)) (encode_bytes (idx data 1)))
(= 1 (len data)) (concat [0x01] (encode_bytes (idx data 0)))
(= 3 (len data)) (concat [0x02] (encode_u_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 [0x0B] (encode_u_LEB128 (len encoded)) encoded ))
)
wasm_to_binary (lambda (wasm_code)
(let (
(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 [ 0x00 0x61 0x73 0x6D ]
version [ 0x01 0x00 0x00 0x00 ]
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_u_LEB128 (len data_section))) (concat [0x0C] (encode_u_LEB128 (len body)) body))
data_count []
) (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)) [ type import function table memory global export start elem code data]
(let (
(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 args 0 empty_dict [] [] [] [] [] [] [] [] [] [] [])))
table (vau de (idx_name & limits_type) (lambda (name_dict type import function table memory global export start elem code data)
[ (put name_dict idx_name (len table)) type import function (concat table [[ (idx limits_type -1) (map (lambda (x) (eval x de)) (slice limits_type 0 -2)) ]]) memory global export start elem code data ]))
memory (vau de (idx_name & limits) (lambda (name_dict type import function table memory global export start elem code data)
[ (put name_dict idx_name (len memory)) type import function table (concat memory [(map (lambda (x) (eval x de)) limits)]) global export start elem code data ]))
func (vau de (name & inside) (lambda (name_dict type import function table memory global export start elem code data)
(let (
(params result locals body) ((rec-lambda recurse (i pe re)
(cond (and (= nil 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 (= nil pe) (= nil 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 (= nil 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) pe re)
true [ (slice inside 0 (or pe 0)) (slice inside (or pe 0) (or re pe 0)) (slice inside (or re pe 0) i) (slice inside i -1) ]
)
) 0 nil nil)
result (if (!= 0 (len result)) (idx result 0)
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) [(+ (idx a 0) 1) (put (idx a 1) (idx x 1) (idx a 0))]) [ 0 outer_name_dict ] params)
(num_locals inner_name_dict) (foldl (lambda (a x) [(+ (idx a 0) 1) (put (idx a 1) (idx x 1) (idx a 0))]) [ 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 [ [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 [[cur_num cur_typ]]) (idx (idx locals i) 2) 1 (+ 1 i)))
) [] nil 0 0)
inner_env (add-dict-to-env de (put inner_name_dict 'depth 0))
our_type [ (map (lambda (x) (idx x 2)) params) (slice result 1 -1) ]
_ (println "about to get our_code")
our_code (flat_map (lambda (x) (let (ins (eval x inner_env))
(cond (array? ins) ins
true (ins) ; un-evaled function, bare WAT
)))
body)
_ (println "resulting code " our_code)
) [
outer_name_dict
; type
(concat type [ our_type ])
; import
import
; function
(concat function [ (len function) ])
; table
table
; memory
memory
; global
global
; export
export
; start
start
; element
elem
; code
(concat code [ [ compressed_locals our_code ] ])
; data
data
])
))
drop (lambda () [['drop]])
i32.const (lambda (const) [['i32.const const]])
i64.const (lambda (const) [['i64.const const]])
local.get (lambda (const) [['local.get const]])
i32.add (lambda (& flatten) (concat (flat_map (lambda (x) x) flatten) [['i32.add]]))
i32.load (lambda (& flatten) (concat (flat_map (lambda (x) x) flatten) [['i32.load 2 0]]))
i64.load (lambda (& flatten) (concat (flat_map (lambda (x) x) flatten) [['i64.load 3 0]]))
i32.store (lambda (& flatten) (concat (flat_map (lambda (x) x) flatten) [['i32.store 2 0]]))
i64.store (lambda (& flatten) (concat (flat_map (lambda (x) x) flatten) [['i64.store 3 0]]))
flat_eval_ins (lambda (instructions de) (flat_map (lambda (x) (let (ins (eval x de)) (cond (array? ins) ins
true (ins)))) instructions))
block_like_body (lambda (name de inner) (let (
new_depth (+ 1 (eval 'depth de))
inner_env (add-dict-to-env de [[ name [new_depth] ] [ 'depth new_depth ]])
) (flat_eval_ins inner inner_env)))
block (vau de (name & inner) [['block [] (block_like_body name de inner)]])
loop (vau de (name & inner) [['loop [] (block_like_body name de inner)]])
_if (vau de (name & inner) (let (
(end_idx else_section) (if (= 'else (idx (idx inner -1) 0)) [ -2 (slice (idx inner -1) 1 -1) ]
[ -1 nil ])
(end_idx then_section) (if (= 'then (idx (idx inner end_idx) 0)) [ (- end_idx 1) (slice (idx inner end_idx) 1 -1) ]
[ (- end_idx 1) [ (idx inner end_idx) ] ])
flattened (flat_eval_ins (slice inner 0 end_idx) de)
_ (println "flattened " flattened " then_section " then_section " else_section " else_section)
then_block (block_like_body name de then_section)
else_block (if (!= nil else_section) [(block_like_body name de else_section)]
[])
) (concat flattened [(concat ['if [] then_block] else_block)])))
br (vau de (b) (let (block (eval b de)) (if (int? block) [['br block]]
[['br (eval [- 'depth (idx block 0)] de)]])))
br_if (vau de (b & flatten) (let (block (eval b de)
block_val (if (int? block) block
(eval [- 'depth (idx block 0)] de))
rest (flat_eval_ins flatten de)
) (concat rest [['br_if block_val]])))
call (lambda (f & flatten) (concat (flat_map (lambda (x) x) flatten) [['call f]]))
import (vau de (mod_name name t_idx_typ) (lambda (name_dict type import function table memory global export start elem code data) (let (
_ (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 [ (slice param_type 1 -1) (slice result_type 1 -1) ]
)
[ (put name_dict idx_name (len function)) (concat type [actual_type]) (concat import [ [mod_name name import_type actual_type_idx] ]) (concat function [nil]) table memory global export start elem code data ])
))
global (vau de (idx_name global_type expr) (lambda (name_dict type import function table memory global export start elem code data)
[ (put name_dict idx_name (len global))
type import function table memory
(concat global [[(if (array? global_type) (reverse global_type) [global_type 'const]) (eval expr de) ]])
export start elem code data ]
))
export (vau de (name t_v) (lambda (name_dict type import function table memory global export start elem code data)
[ name_dict type import function table memory global (concat export [ [ name (idx t_v 0) (get-value name_dict (idx t_v 1)) ] ]) start elem code data ]
))
start (vau de (name) (lambda (name_dict type import function table memory global export start elem code data)
[ name_dict type import function table memory global export (concat start [(get-value name_dict name)]) elem code data ]
))
elem (vau de (offset & entries) (lambda (name_dict type import function table memory global export start elem code data)
[ name_dict type import function table memory global export start (concat elem [[(eval offset de) (map (lambda (x) (get-value name_dict x)) entries)]]) code data ]
))
data (lambda (& it) (lambda (name_dict type import function table memory global export start elem code data)
[name_dict type import function table memory global export start elem code (concat data [it])]))
)
(provide wasm_to_binary
module import table memory start elem func global export data
drop i32.const i64.const local.get i32.add
i32.load i64.load
i32.store i64.store
block loop _if br br_if call)
))