aboutsummaryrefslogtreecommitdiffstats
path: root/lib/syntax_tools/examples/merl/basicc.erl
diff options
context:
space:
mode:
authorRichard Carlsson <[email protected]>2014-12-23 14:23:35 +0100
committerRichard Carlsson <[email protected]>2015-05-22 12:43:53 +0200
commite533ea29e80a641f247022f321a3bf1a1456c56e (patch)
tree2681e4a828e5393d1cc5c539efd5285b92419fa2 /lib/syntax_tools/examples/merl/basicc.erl
parent9a81b28598fadc44bf506354c9227e41aac786f6 (diff)
downloadotp-e533ea29e80a641f247022f321a3bf1a1456c56e.tar.gz
otp-e533ea29e80a641f247022f321a3bf1a1456c56e.tar.bz2
otp-e533ea29e80a641f247022f321a3bf1a1456c56e.zip
Include Merl in Syntax Tools
Diffstat (limited to 'lib/syntax_tools/examples/merl/basicc.erl')
-rw-r--r--lib/syntax_tools/examples/merl/basicc.erl149
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.