Include Merl in Syntax Tools

1 files changed, 149 insertions, 0 deletions

diff --git a/lib/syntax_tools/examples/merl/basicc.erl b/lib/syntax_tools/examples/merl/basicc.erl
new file mode 100644
index 0000000000..531ac51538
--- /dev/null
+++ b/lib/syntax_tools/examples/merl/basicc.erl
@@ -0,0 +1,149 @@
+%% ---------------------------------------------------------------------
+%% 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 Basic compiler in Erlang.
+
+-module(basicc).
+
+-export([run/2, make_lines/1, bool/1]).
+
+-include_lib("eunit/include/eunit.hrl").
+
+-define(INTERPRETED, true).
+-include("basic_test.erl").
+
+-include("merl.hrl").
+
+run(N, Prog) ->
+    compile(Prog, tmp),
+    tmp:run(N, Prog).
+
+make_lines(Prog) ->
+    ets:new(line, [private, named_table, ordered_set]),
+    lists:foreach(fun ({L,_}) -> ets:insert(line, {L,label(L)}) end, Prog).
+
+compile(Prog, ModName) ->
+    make_lines(Prog),
+    Fs0 = lists:map(fun ({L, X}) ->
+                            {true, label(L),
+                             case stmt(X) of
+                                 {Stmt, false} ->
+                                     [?Q("() -> _@Stmt")];
+                                 {Stmt, true} ->
+                                     Next = case ets:next(line, L) of
+                                                '$end_of_table' ->
+                                                    ?Q("stop(0)");
+                                                L1 ->
+                                                    Label = label(L1),
+                                                    ?Q("_@Label@()")
+                                            end,
+                                     [?Q("() -> _@Stmt, _@Next")]
+                             end}
+                    end, Prog),
+    ets:delete(line),
+    Run = ?Q(["(N, Prog) ->",
+              " ets:new(var, [private, named_table]),",
+              " basicc:make_lines(Prog),",
+              " goto(N)"
+             ]),
+    Stop = ?Q(["(R) ->",
+               " ets:delete(var),",
+               " ets:delete(line),",
+               " R"
+              ]),
+    Goto =  ?Q(["(L) ->",
+                " case ets:lookup(line, L) of",
+                "  [{_, X}] -> apply(tmp, X, []);",
+                "  _ ->",
+                "   case ets:next(line, L) of",
+                "    '$end_of_table' -> stop(0);",
+                "    L1 -> goto(L1)",
+                "   end",
+                " end"]),
+    Fs = [{true, run, [Run]},
+          {false, stop, [Stop]},
+          {true, goto, [Goto]}
+          | Fs0],
+    Forms = merl_build:module_forms(
+              lists:foldl(fun ({X, Name, Cs}, S) ->
+                                  merl_build:add_function(X, Name, Cs, S)
+                          end,
+                          merl_build:init_module(ModName),
+                          Fs)),
+    %% %% Write source to file for debugging
+    %% file:write_file(lists:concat([ModName, "_gen.erl"]),
+    %%                 erl_prettypr:format(erl_syntax:form_list(Forms),
+    %%                                     [{paper,160},{ribbon,80}])),
+    merl:compile_and_load(Forms, [verbose]).
+
+label(L) ->
+    list_to_atom("label_" ++ integer_to_list(L)).
+
+stmt({print, S, As}) ->
+    Exprs = [expr(A) || A <- As],
+    {[?Q(["io:format(_@S@, [_@Exprs])"])], true};
+stmt({set, V, X}) ->
+    Expr = expr(X),
+    {[?Q(["ets:insert(var, {_@V@, _@Expr})"])], true};
+stmt({goto, X}) ->
+    {[jump(X)], false};
+stmt({stop, X}) ->
+    Expr = expr(X),
+    {[?Q(["stop(_@Expr)"])], false};
+stmt({iff, X, A, B}) ->
+    Cond = expr(X),
+    True = jump(A),
+    False = jump(B),
+    {?Q(["case _@Cond of",
+         "  0 -> _@False;",
+         "  _ -> _@True",
+         "end"]),
+     false}.
+
+jump(X) ->
+    case ets:lookup(line, X) of
+        [{_, F}] ->
+            ?Q(["_@F@()"]);
+        true ->
+            Expr = expr(X),
+            [?Q(["goto(_@Expr)"])]
+    end.
+
+expr(X) when is_number(X) ; is_list(X) ->
+    ?Q("_@X@");
+expr(X) when is_atom(X) ->
+    ?Q(["case ets:lookup(var, _@X@) of",
+        " [] -> 0;",
+        " [{_,V}] -> V",
+        "end"]);
+expr({plus, X, Y}) ->
+    ExprX = expr(X),
+    ExprY = expr(Y),
+    ?Q("_@ExprX + _@ExprY");
+expr({equal, X, Y}) ->
+    ExprX = expr(X),
+    ExprY = expr(Y),
+    ?Q("basicc:bool(_@ExprX == _@ExprY)");
+expr({gt, X, Y}) ->
+    ExprX = expr(X),
+    ExprY = expr(Y),
+    ?Q("basicc:bool(_@ExprX > _@ExprY)");
+expr({knot, X}) ->
+    Expr = expr(X),
+    ?Q(["case _@Expr of",
+        " 0 -> 1;",
+        " _ -> 0",
+        "end"]).
+
+bool(true) -> 1;
+bool(false) -> 0.