diff options
Diffstat (limited to 'lib/syntax_tools/examples/merl/lisp.erl')
| -rw-r--r-- | lib/syntax_tools/examples/merl/lisp.erl | 160 |
1 files changed, 160 insertions, 0 deletions
diff --git a/lib/syntax_tools/examples/merl/lisp.erl b/lib/syntax_tools/examples/merl/lisp.erl new file mode 100644 index 0000000000..371dc6b261 --- /dev/null +++ b/lib/syntax_tools/examples/merl/lisp.erl @@ -0,0 +1,160 @@ +%% --------------------------------------------------------------------- +%% Licensed under the Apache License, Version 2.0 (the "License"); you may +%% not use this file except in compliance with the License. You may obtain +%% a copy of the License at <http://www.apache.org/licenses/LICENSE-2.0> +%% +%% Unless required by applicable law or agreed to in writing, software +%% distributed under the License is distributed on an "AS IS" BASIS, +%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +%% See the License for the specific language governing permissions and +%% limitations under the License. +%% +%% @author Richard Carlsson <[email protected]> +%% @copyright 2012 Richard Carlsson +%% @doc Trivial Lisp interpreter in Erlang. + +-module(lisp). + +-export([eval/1]). + +-export([init/0, equal/2, gt/2, knot/1]). + +-record(st, {env}). + +-define(INTERPRETED, true). +-include("lisp_test.erl"). + +eval(P) -> + {X, _} = eval(P, init()), + X. + +init() -> + Env = [{print, {builtin, fun do_print/2}} + ,{list, {builtin, fun do_list/2}} + ,{apply, {builtin, fun do_apply/2}} + ,{plus, {builtin, fun do_plus/2}} + ,{equal, {builtin, fun do_equal/2}} + ,{gt, {builtin, fun do_gt/2}} + ,{knot, {builtin, fun do_knot/2}} + ,{y, y()} + ], + #st{env=dict:from_list(Env)}. + +eval([lambda, Ps, B], #st{env=E}=St) when is_list(Ps) -> + case lists:all(fun is_atom/1, Ps) andalso + (length(Ps) =:= length(lists:usort(Ps))) of + true -> {{lambda, Ps, B, E}, St}; + false -> throw(bad_lambda) + end; +eval([lambda | _], _) -> + throw(bad_lambda); +eval([def, A, V, B], #st{env=E0}=St) when is_atom(A) -> + {V1, St1} = eval(V, St), + E1 = bind(A, V1, E0), + {X, St2} = eval(B, St1#st{env=E1}), + {X, St2#st{env=E0}}; +eval([def | _], _) -> + throw(bad_def); +eval([quote, A], St) -> + {A, St}; +eval([quote | _], _) -> + throw(bad_quote); +eval([iff, X, A, B], St) -> + case eval(X, St) of + {[], St1} -> eval(B, St1); + {_, St1} -> eval(A, St1) + end; +eval([do], _St0) -> + throw(bad_do); +eval([do | As], St0) -> + lists:foldl(fun (X, {_,St}) -> eval(X, St) end, {[],St0}, As); +eval([_|_]=L, St) -> + {[F | As], St1} = lists:mapfoldl(fun eval/2, St, L), + call(F, As, St1); +eval(A, St) when is_atom(A) -> + {deref(A, St), St}; +eval(C, St) -> + {C, St}. + +%% UTILITY FUNCTIONS + +deref(A, #st{env=E}) -> + case dict:find(A, E) of + {ok, V} -> V; + error -> throw({undefined, A}) + end. + +bind(A, V, E) -> + dict:store(A, V, E). + +bind_args([P | Ps], [A | As], E) -> + bind_args(Ps, As, dict:store(P, A, E)); +bind_args([], [], E) -> + E; +bind_args(_, _, _) -> + throw(bad_arity). + +call({lambda, Ps, B, E}, As, #st{env=E0}=St) -> + {X, St1} = eval(B, St#st{env=bind_args(Ps, As, E)}), + {X, St1#st{env=E0}}; +call({builtin, F}, As, St) -> + F(As, St); +call(X, _, _) -> + throw({bad_fun, X}). + +bool(true) -> 1; +bool(false) -> []. + +%% BUILTINS + +y() -> + {Y, _} = eval([lambda, [f], + [[lambda, [x], [f, [lambda, [y], [[x, x], y]]]], + [lambda, [x], [f, [lambda, [y], [[x, x], y]]]]]], + #st{env=dict:new()}), + Y. + +do_print([S | Xs], St) -> + io:format(S, Xs), + {[], St}; +do_print(_, _) -> + throw(bad_print). + +do_list(As, St) -> + {As, St}. + +do_apply([F, As], St) -> + call(F, As, St); +do_apply(_, _) -> + throw(bad_apply). + +do_plus([X, Y], St) when is_number(X), is_number(Y) -> + {X + Y, St}; +do_plus(As, _) -> + throw({bad_plus, As}). + +do_equal([X, Y], St) -> + {equal(X, Y), St}; +do_equal(As, _) -> + throw({bad_equal, As}). + +equal(X, Y) -> + bool(X =:= Y). + +do_gt([X, Y], St) -> + {gt(X, Y), St}; +do_gt(As, _) -> + throw({bad_gt, As}). + +gt(X, Y) -> + bool(X > Y). + +do_knot([X], St) -> + {knot(X), St}; +do_knot(As, _) -> + throw({bad_gt, As}). + +knot([]) -> + 1; +knot(_) -> + []. |