3 let repl_env = Env.make
(Some
Core.ns
)
5 let rec quasiquote ast
=
7 | T.List
{ T.value = [T.Symbol
{T.value = "unquote"}; ast
] } -> ast
8 | T.List
{T.value = xs
} -> List.fold_right qq_folder xs
(Types.list
[])
9 | T.Vector
{T.value = xs
} -> Types.list
[Types.symbol
"vec";
10 List.fold_right qq_folder xs
(Types.list
[])]
11 | T.Map _
-> Types.list
[Types.symbol
"quote"; ast
]
12 | T.Symbol _
-> Types.list
[Types.symbol
"quote"; ast
]
14 and qq_folder elt acc
=
16 | T.List
{T.value = [T.Symbol
{T.value = "splice-unquote"}; x
]} -> Types.list
[Types.symbol
"concat"; x
; acc
]
17 | _
-> Types.list
[Types.symbol
"cons"; quasiquote elt
; acc
]
19 let rec eval_ast ast env
=
21 | T.Symbol s
-> Env.get env ast
22 | T.List
{ T.value = xs
; T.meta
= meta
}
23 -> T.List
{ T.value = (List.map
(fun x
-> eval x env
) xs
);
25 | T.Vector
{ T.value = xs
; T.meta
= meta
}
26 -> T.Vector
{ T.value = (List.map
(fun x
-> eval x env
) xs
);
28 | T.Map
{ T.value = xs
; T.meta
= meta
}
29 -> T.Map
{T.meta
= meta
;
30 T.value = (Types.MalMap.fold
32 -> Types.MalMap.add
(eval k env
) (eval v env
) m
)
38 | T.List
{ T.value = [] } -> ast
39 | T.List
{ T.value = [(T.Symbol
{ T.value = "def!" }); key
; expr
] } ->
40 let value = (eval expr env
) in
41 Env.set env key
value; value
42 | T.List
{ T.value = [(T.Symbol
{ T.value = "let*" }); (T.Vector
{ T.value = bindings
}); body
] }
43 | T.List
{ T.value = [(T.Symbol
{ T.value = "let*" }); (T.List
{ T.value = bindings
}); body
] } ->
44 (let sub_env = Env.make
(Some env
) in
45 let rec bind_pairs = (function
46 | sym
:: expr
:: more
->
47 Env.set
sub_env sym
(eval expr
sub_env);
49 | _
::[] -> raise
(Invalid_argument
"let* bindings must be an even number of forms")
51 in bind_pairs bindings
;
53 | T.List
{ T.value = ((T.Symbol
{ T.value = "do" }) :: body
) } ->
54 List.fold_left
(fun x expr
-> eval expr env
) T.Nil body
55 | T.List
{ T.value = [T.Symbol
{ T.value = "if" }; test
; then_expr
; else_expr
] } ->
56 if Types.to_bool
(eval test env
) then (eval then_expr env
) else (eval else_expr env
)
57 | T.List
{ T.value = [T.Symbol
{ T.value = "if" }; test
; then_expr
] } ->
58 if Types.to_bool
(eval test env
) then (eval then_expr env
) else T.Nil
59 | T.List
{ T.value = [T.Symbol
{ T.value = "fn*" }; T.Vector
{ T.value = arg_names
}; expr
] }
60 | T.List
{ T.value = [T.Symbol
{ T.value = "fn*" }; T.List
{ T.value = arg_names
}; expr
] } ->
63 let sub_env = Env.make
(Some env
) in
64 let rec bind_args a b
=
66 | [T.Symbol
{ T.value = "&" }; name
], args
-> Env.set
sub_env name
(Types.list args
);
67 | (name
:: names
), (arg
:: args
) ->
68 Env.set
sub_env name arg
;
71 | _
-> raise
(Invalid_argument
"Bad param count in fn call"))
72 in bind_args arg_names args
;
74 | T.List
{ T.value = [T.Symbol
{ T.value = "quote" }; ast
] } -> ast
75 | T.List
{ T.value = [T.Symbol
{ T.value = "quasiquoteexpand" }; ast
] } ->
77 | T.List
{ T.value = [T.Symbol
{ T.value = "quasiquote" }; ast
] } ->
78 eval
(quasiquote ast
) env
80 (match eval_ast ast env
with
81 | T.List
{ T.value = ((T.Fn
{ T.value = f
}) :: args
) } -> f args
82 | _
-> raise
(Invalid_argument
"Cannot invoke non-function"))
83 | _
-> eval_ast ast env
85 let read str
= Reader.read_str str
86 let print exp
= Printer.pr_str exp
true
87 let rep str env
= print (eval
(read str
) env
)
92 Env.set
repl_env (Types.symbol
"*ARGV*")
93 (Types.list
(if Array.length
Sys.argv
> 1
94 then (List.map
(fun x
-> T.String x
) (List.tl
(List.tl
(Array.to_list
Sys.argv
))))
96 Env.set
repl_env (Types.symbol
"eval")
97 (Types.fn
(function [ast
] -> eval ast
repl_env | _
-> T.Nil
));
98 ignore
(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" repl_env);
99 ignore
(rep "(def! not (fn* (a) (if a false true)))" repl_env);
101 if Array.length
Sys.argv
> 1 then
102 ignore
(rep ("(load-file \"" ^
Sys.argv
.(1) ^
"\")") repl_env)
105 print_string
"user> ";
106 let line = read_line
() in
108 print_endline
(rep line repl_env);
109 with End_of_file
-> ()
110 | Invalid_argument x
->
111 output_string stderr
("Invalid_argument exception: " ^ x ^
"\n");
114 with End_of_file
-> ()