forked from kanaka/mal
-
Notifications
You must be signed in to change notification settings - Fork 0
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
- Loading branch information
Showing
9 changed files
with
183 additions
and
40 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,129 @@ | ||
| module T = Types.Types | ||
|
|
||
| let repl_env = Env.make (Some Core.ns) | ||
|
|
||
| let rec quasiquote ast = | ||
| match ast with | ||
| | T.List { T.value = [T.Symbol {T.value = "unquote"}; ast] } -> ast | ||
| | T.Vector { T.value = [T.Symbol {T.value = "unquote"}; ast] } -> ast | ||
| | T.List { T.value = T.List { T.value = [T.Symbol {T.value = "splice-unquote"}; head]} :: tail } | ||
| | T.Vector { T.value = T.List { T.value = [T.Symbol {T.value = "splice-unquote"}; head]} :: tail } -> | ||
| Types.list [Types.symbol "concat"; head; quasiquote (Types.list tail)] | ||
| | T.List { T.value = head :: tail } | ||
| | T.Vector { T.value = head :: tail } -> | ||
| Types.list [Types.symbol "cons"; quasiquote head; quasiquote (Types.list tail) ] | ||
| | ast -> Types.list [Types.symbol "quote"; ast] | ||
|
|
||
| let rec macroexpand ast env = | ||
| match ast with | ||
| | T.List { T.value = s :: args } -> | ||
| (match (try Env.get env s with _ -> T.Nil) with | ||
| | T.Fn { T.f = f; T.is_macro = true } -> macroexpand (f args) env | ||
| | _ -> ast) | ||
| | _ -> ast | ||
|
|
||
| let rec eval_ast ast env = | ||
| match ast with | ||
| | T.Symbol s -> Env.get env ast | ||
| | T.List { T.value = xs; T.meta = meta } | ||
| -> T.List { T.value = (List.map (fun x -> eval x env) xs); T.meta = meta } | ||
| | T.Vector { T.value = xs; T.meta = meta } | ||
| -> T.Vector { T.value = (List.map (fun x -> eval x env) xs); T.meta = meta } | ||
| | T.Map { T.value = xs; T.meta = meta } | ||
| -> T.Map {T.meta = meta; | ||
| T.value = (Types.MalMap.fold | ||
| (fun k v m | ||
| -> Types.MalMap.add (eval k env) (eval v env) m) | ||
| xs | ||
| Types.MalMap.empty)} | ||
| | _ -> ast | ||
| and eval ast env = | ||
| match macroexpand ast env with | ||
| | T.List { T.value = [(T.Symbol { T.value = "def!" }); key; expr] } -> | ||
| let value = (eval expr env) in | ||
| Env.set env key value; value | ||
| | T.List { T.value = [(T.Symbol { T.value = "defmacro!" }); key; expr] } -> | ||
| (match (eval expr env) with | ||
| | T.Fn { T.f = f } -> | ||
| let fn = T.Fn { T.f = f; is_macro = true } in | ||
| Env.set env key fn; fn | ||
| | _ -> raise (Invalid_argument "devmacro! value must be a fn")) | ||
| | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.Vector { T.value = bindings }); body] } | ||
| | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.List { T.value = bindings }); body] } -> | ||
| (let sub_env = Env.make (Some env) in | ||
| let rec bind_pairs = (function | ||
| | sym :: expr :: more -> | ||
| Env.set sub_env sym (eval expr sub_env); | ||
| bind_pairs more | ||
| | _::[] -> raise (Invalid_argument "let* bindings must be an even number of forms") | ||
| | [] -> ()) | ||
| in bind_pairs bindings; | ||
| eval body sub_env) | ||
| | T.List { T.value = ((T.Symbol { T.value = "do" }) :: body) } -> | ||
| List.fold_left (fun x expr -> eval expr env) T.Nil body | ||
| | T.List { T.value = [T.Symbol { T.value = "if" }; test; then_expr; else_expr] } -> | ||
| if Types.to_bool (eval test env) then (eval then_expr env) else (eval else_expr env) | ||
| | T.List { T.value = [T.Symbol { T.value = "if" }; test; then_expr] } -> | ||
| if Types.to_bool (eval test env) then (eval then_expr env) else T.Nil | ||
| | T.List { T.value = [T.Symbol { T.value = "fn*" }; T.Vector { T.value = arg_names }; expr] } | ||
| | T.List { T.value = [T.Symbol { T.value = "fn*" }; T.List { T.value = arg_names }; expr] } -> | ||
| Types.fn | ||
| (function args -> | ||
| let sub_env = Env.make (Some env) in | ||
| let rec bind_args a b = | ||
| (match a, b with | ||
| | [T.Symbol { T.value = "&" }; name], args -> Env.set sub_env name (Types.list args); | ||
| | (name :: names), (arg :: args) -> | ||
| Env.set sub_env name arg; | ||
| bind_args names args; | ||
| | [], [] -> () | ||
| | _ -> raise (Invalid_argument "Bad param count in fn call")) | ||
| in bind_args arg_names args; | ||
| eval expr sub_env) | ||
| | T.List { T.value = [T.Symbol { T.value = "quote" }; ast] } -> ast | ||
| | T.List { T.value = [T.Symbol { T.value = "quasiquote" }; ast] } -> | ||
| eval (quasiquote ast) env | ||
| | T.List { T.value = [T.Symbol { T.value = "macroexpand" }; ast] } -> | ||
| macroexpand ast env | ||
| | T.List _ as ast -> | ||
| (match eval_ast ast env with | ||
| | T.List { T.value = ((T.Fn { T.f = f }) :: args) } -> f args | ||
| | _ -> raise (Invalid_argument "Cannot invoke non-function")) | ||
| | ast -> eval_ast ast env | ||
|
|
||
| let read str = Reader.read_str str | ||
| let print exp = Printer.pr_str exp true | ||
| let rep str env = print (eval (read str) env) | ||
|
|
||
| let rec main = | ||
| try | ||
| Core.init Core.ns; | ||
| Env.set repl_env (Types.symbol "*ARGV*") | ||
| (Types.list (if Array.length Sys.argv > 1 | ||
| then (List.map (fun x -> T.String x) (List.tl (List.tl (Array.to_list Sys.argv)))) | ||
| else [])); | ||
| Env.set repl_env (Types.symbol "eval") | ||
| (Types.fn (function [ast] -> eval ast repl_env | _ -> T.Nil)); | ||
|
|
||
| ignore (rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" repl_env); | ||
| ignore (rep "(def! not (fn* (a) (if a false true)))" repl_env); | ||
| ignore (rep "(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))" repl_env); | ||
| ignore (rep "(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))" repl_env); | ||
|
|
||
| if Array.length Sys.argv > 1 then | ||
| ignore (rep ("(load-file \"" ^ Sys.argv.(1) ^ "\")") repl_env) | ||
| else | ||
| while true do | ||
| print_string "user> "; | ||
| let line = read_line () in | ||
| try | ||
| print_endline (rep line repl_env); | ||
| with End_of_file -> () | ||
| | Invalid_argument x -> | ||
| output_string stderr ("Invalid_argument exception: " ^ x ^ "\n"); | ||
| flush stderr | ||
| | _ -> | ||
| output_string stderr ("Erroringness!\n"); | ||
| flush stderr | ||
| done | ||
| with End_of_file -> () |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters