((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 lapply (lambda (f p) (eval (concat (array (unwrap f)) p) (current-env))) (let1 vapply (lambda (f p ede) (eval (concat (array f) p) ede)) (let1 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))) ; 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))) 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 ( helper (rec-lambda recurse (s i result) (if (< i (len s)) (recurse s (+ i 1) (+ (* 10 result) (- (idx s i) (idx "0" 0)))) result ) )) (if (= (idx s 0) (idx "-" 0)) (- (helper s 1 0)) (helper s 0 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-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 concat map map_i flat_map 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))