aboutsummaryrefslogtreecommitdiffstats
path: root/lib/syntax_tools/examples/merl/lisp.erl
diff options
context:
space:
mode:
Diffstat (limited to 'lib/syntax_tools/examples/merl/lisp.erl')
-rw-r--r--lib/syntax_tools/examples/merl/lisp.erl160
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(_) ->
+ [].