279 lines
17 KiB
Plaintext
279 lines
17 KiB
Plaintext
|
|
((wrap (vau root_env (quote)
|
|
((wrap (vau _ (let1)
|
|
|
|
(let1 lambda (vau se (p b) (wrap (eval (array vau (quote _) 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))
|
|
|
|
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 (x i) (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))) (idx vs i))
|
|
)
|
|
(recurse (concat new_vs (slice vs (+ i 2) -1)) 0 (concat r (array bad_sym (idx vs (+ i 1))))))
|
|
true (recurse vs (+ i 2) (concat r (slice vs i (+ i 2))))
|
|
))) (vau de (vs b) (vapply let (array (destructure_helper vs 0 (array)) b) de)))
|
|
|
|
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
|
|
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
|
|
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 (quote _) (array s) b) (eval v de)) de)))
|
|
; impl of quote
|
|
)) (vau _ (x) x))
|
|
|