Include Merl in Syntax Tools

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(_) ->
+    [].