diff options
Diffstat (limited to 'lib/syntax_tools/examples')
| -rw-r--r-- | lib/syntax_tools/examples/merl/Makefile | 22 | ||||
| -rw-r--r-- | lib/syntax_tools/examples/merl/basic.erl | 77 | ||||
| -rw-r--r-- | lib/syntax_tools/examples/merl/basic_test.erl | 77 | ||||
| -rw-r--r-- | lib/syntax_tools/examples/merl/basicc.erl | 149 | ||||
| -rw-r--r-- | lib/syntax_tools/examples/merl/lisp.erl | 160 | ||||
| -rw-r--r-- | lib/syntax_tools/examples/merl/lisp_test.erl | 98 | ||||
| -rw-r--r-- | lib/syntax_tools/examples/merl/lispc.erl | 102 | ||||
| -rw-r--r-- | lib/syntax_tools/examples/merl/merl_build.erl | 104 |
8 files changed, 789 insertions, 0 deletions
diff --git a/lib/syntax_tools/examples/merl/Makefile b/lib/syntax_tools/examples/merl/Makefile new file mode 100644 index 0000000000..13a9703733 --- /dev/null +++ b/lib/syntax_tools/examples/merl/Makefile @@ -0,0 +1,22 @@ +EBIN=../../ebin +INCLUDES=../../include +SOURCES=merl_build.erl lisp.erl lispc.erl basic.erl basicc.erl +HEADERS=$(INCLUDES)/merl.hrl +OBJECTS=$(SOURCES:%.erl=%.beam) +ERLC_FLAGS=+debug_info -I$(INCLUDES) -pa $(EBIN) + +all: $(OBJECTS) test + +%.beam: %.erl $(HEADERS) Makefile + erlc $(ERLC_FLAGS) -o ./ $< + +# additional dependencies due to the parse transform +lispc.beam basicc.beam: $(EBIN)/merl_transform.beam $(EBIN)/merl.beam + +clean: + -rm -f $(OBJECTS) + +test: + erl -noshell -pa $(EBIN) \ + -eval 'eunit:test([lisp, lispc, basic, basicc],[])' \ + -s init stop diff --git a/lib/syntax_tools/examples/merl/basic.erl b/lib/syntax_tools/examples/merl/basic.erl new file mode 100644 index 0000000000..9030059d11 --- /dev/null +++ b/lib/syntax_tools/examples/merl/basic.erl @@ -0,0 +1,77 @@ +%% --------------------------------------------------------------------- +%% 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 Basic interpreter in Erlang + +-module(basic). + +-export([run/2]). + +-include_lib("eunit/include/eunit.hrl"). + +-define(INTERPRETED, true). +-include("basic_test.erl"). + +run(N, Prog) -> + ets:new(var, [private, named_table]), + ets:new(line, [private, named_table, ordered_set]), + lists:foreach(fun (T) -> ets:insert(line, T) end, Prog), + goto(N). + +stop(N) -> + ets:delete(var), + ets:delete(line), + N. + +goto('$end_of_table') -> stop(0); +goto(L) -> + L1 = ets:next(line, L), + %% user-supplied line numbers might not exist + case ets:lookup(line, L) of + [{_, X}] -> + stmt(X, L1); + _ -> + goto(L1) + end. + +stmt({print, S, As}, L) -> io:format(S, [expr(A) || A <- As]), goto(L); +stmt({set, V, X}, L) -> ets:insert(var, {V, expr(X)}), goto(L); +stmt({goto, X}, _L) -> goto(expr(X)); +stmt({stop, X}, _L) -> stop(expr(X)); +stmt({iff, X, A, B}, _L) -> + case expr(X) of + 0 -> goto(B); + _ -> goto(A) + end. + +expr(X) when is_number(X) ; is_list(X) -> + X; +expr(X) when is_atom(X) -> + case ets:lookup(var, X) of + [] -> 0; + [{_,V}] -> V + end; +expr({plus, X, Y}) -> + expr(X) + expr(Y); +expr({equal, X, Y}) -> + bool(expr(X) == expr(Y)); +expr({gt, X, Y}) -> + bool(expr(X) > expr(Y)); +expr({knot, X}) -> + case expr(X) of + 0 -> 1; + _ -> 0 + end. + +bool(true) -> 1; +bool(false) -> 0. diff --git a/lib/syntax_tools/examples/merl/basic_test.erl b/lib/syntax_tools/examples/merl/basic_test.erl new file mode 100644 index 0000000000..ff35de6325 --- /dev/null +++ b/lib/syntax_tools/examples/merl/basic_test.erl @@ -0,0 +1,77 @@ +%% --------------------------------------------------------------------- +%% 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 Tests. For including in another module. + +%-module(basic_test). +%-import(basic, run/1) + +-export([basic_fib/1]). + +-include_lib("eunit/include/eunit.hrl"). + +basics_test_() -> + [?_assertEqual(42, run(1,[{1,{stop, 42}}])), + ?_assertEqual("hello", run(1,[{1,{stop,"hello"}}])), + ?_assertEqual(0, run(1,[{1,{print, "hello ~w", [42]}}])), + ?_assertEqual(5, run(1,[{1,{stop, {plus, 2, 3}}}])), + ?_assertEqual(5, run(1,[{1,{stop,{plus, 8, -3}}}])), + ?_assertEqual(0, run(1,[{1,{stop,{equal, 0, 1}}}])), + ?_assertEqual(1, run(1,[{1,{stop,{equal, 1, 1}}}])), + ?_assertEqual(0, run(1,[{1,{stop,{gt, 0, 1}}}])), + ?_assertEqual(0, run(1,[{1,{stop,{gt, 1, 1}}}])), + ?_assertEqual(1, run(1,[{1,{stop,{gt, 2, 1}}}])), + ?_assertEqual(0, run(1,[{1,{stop,{knot, 42}}}])), + ?_assertEqual(1, run(1,[{1,{stop,{knot, 0}}}])), + ?_assertEqual(42, run(1,[{1,{set, x, 42}}, {2,{stop,x}}])), + ?_assertEqual(17, run(1,[{1,{iff, 1, 2, 3}}, + {2,{stop, 17}}, + {3,{stop, 42}}])), + ?_assertEqual(42, run(1,[{1,{iff, 0, 2, 3}}, + {2,{stop, 17}}, + {3,{stop, 42}}])), + ?_assertEqual(17, run(1,[{1,{iff, 1, 2, 3}}, + {2,{stop, 17}}, + {3,{stop, -1}}])), + ?_assertEqual(42, run(1,[{1,{iff, 0, 2, 3}}, + {2,{stop, -1}}, + {3,{stop, 42}}])) + + + ]. + + +fib_test_() -> + [?_assertEqual(fib(N), basic_fib(N)) || N <- lists:seq(1,15) + ]. + + +fib(N) when N > 1 -> + fib(N-1) + fib(N-2); +fib(_) -> + 1. + +basic_fib(N) -> + run(1, + [{1,{set,x,0}}, + {2,{set,a,1}}, + {3,{set,b,0}}, + {10,{iff, {equal, x, N}, 20, 30}}, + {20,{stop,a}}, + {30,{print,"~w, ~w, ~w\n",[x,a,b]}}, + {31,{set,t,a}}, + {32,{set,a,{plus,a,b}}}, + {33,{set,b,t}}, + {34,{set,x,{plus,x,1}}}, + {40,{goto,10}} + ]). 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. 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(_) -> + []. diff --git a/lib/syntax_tools/examples/merl/lisp_test.erl b/lib/syntax_tools/examples/merl/lisp_test.erl new file mode 100644 index 0000000000..cab8134b8f --- /dev/null +++ b/lib/syntax_tools/examples/merl/lisp_test.erl @@ -0,0 +1,98 @@ +%% --------------------------------------------------------------------- +%% 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 Tests. For including in another module. + +%-module(lisp_test). +%-import(lisp, eval/1) + +-export([fib/1, lisp_fib/1]). + +-include_lib("eunit/include/eunit.hrl"). + +basics_test_() -> + [?_assertEqual(42, eval(42)), + ?_assertEqual("hello", eval([quote, "hello"])), + ?_assertEqual(print, eval([quote, print])), + ?_assertMatch([17,[1,2],42], eval([list,17,[list,1,2],42])), + ?_assertEqual([], eval([print, [quote, "hello ~w"], [list, 42]])), + ?_assertEqual(5, eval([plus, 2, 3])), + ?_assertEqual(5, eval([plus, 8, -3])), + ?_assertEqual([], eval([equal, 0, 1])), + ?_assertEqual(1, eval([equal, 1, 1])), + ?_assertEqual([], eval([gt, 0, 1])), + ?_assertEqual([], eval([gt, 1, 1])), + ?_assertEqual(1, eval([gt, 2, 1])), + ?_assertEqual([], eval([knot, 42])), + ?_assertEqual(1, eval([knot, []])), + ?_assertEqual(42, eval([do, 17, 42])), + ?_assertEqual([], eval([apply, print, [quote, ["~p", [42]]]])), + ?_assertEqual(42, eval([iff, [], 17, 42])), + ?_assertEqual(17, eval([iff, 1, 17, 42])), + ?_assertEqual(42, eval([iff, [], [apply], 42])), + ?_assertEqual(17, eval([iff, 1, 17, [apply]])), + ?_assertEqual(17, eval([def, foo, 17, foo])), + ?_assertEqual(17, eval([def, bar, 42, [def, foo, 17, foo]])), + ?_assertEqual(42, eval([def, bar, 42, [def, foo, 17, bar]])), + ?_assertEqual(17, eval([def, foo, 42, [def, foo, 17, foo]])) + ]. + +-ifdef(INTERPRETED). +interpreter_basics_test_() -> + [?_assertThrow({undefined, foo}, eval(foo)), + ?_assertMatch({builtin,_}, eval(print)), + ?_assertThrow(bad_do, eval([do])), + ?_assertThrow(bad_apply, eval([apply])), + ?_assertThrow({undefined, foo}, eval([def, bar, 17, foo])) + ]. + +interpreter_lambda_test_() -> + [?_assertMatch({lambda,_,_,_}, eval([lambda, [], 42])), + ?_assertMatch({lambda,_,_,_}, eval([lambda, [x], x])), + ?_assertMatch({lambda,_,_,_}, eval([lambda, [x,y], 42])) + ]. +-endif. + +lambda_test_() -> + [?_assertThrow(bad_lambda, eval([lambda])), + ?_assertThrow(bad_lambda, eval([lambda, []])), + ?_assertThrow(bad_lambda, eval([lambda, [], 17, 42])), + ?_assertThrow(bad_lambda, eval([lambda, 17, 42])), + ?_assertThrow(bad_lambda, eval([lambda, [17], 42])), + ?_assertThrow(bad_lambda, eval([lambda, [foo, foo], 42])), + ?_assertEqual(42, eval([[lambda, [x], x], 42])), + ?_assertEqual([42, 17], eval([[lambda, [x], [list, x, 17]], 42])), + ?_assertEqual([42, 17], eval([def, f, [def, y, 42, + [lambda, [x], [list, y, x]]], + [f, 17]])) + ]. + +fib_test_() -> + [?_assertEqual(fib(N), lisp_fib(N)) || N <- lists:seq(1,15) + ]. + + +fib(N) when N > 1 -> + fib(N-1) + fib(N-2); +fib(_) -> + 1. + +lisp_fib(N) -> + eval([def, fib, + [y, [lambda, [f], [lambda, [x], + [iff, [gt, x, 1], + [plus, [f, [plus,x,-1]], [f, [plus,x,-2]]], + 1] + ]]], + [fib, N] + ]). diff --git a/lib/syntax_tools/examples/merl/lispc.erl b/lib/syntax_tools/examples/merl/lispc.erl new file mode 100644 index 0000000000..97072cdab7 --- /dev/null +++ b/lib/syntax_tools/examples/merl/lispc.erl @@ -0,0 +1,102 @@ +%% --------------------------------------------------------------------- +%% 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 Lisp compiler in Erlang. + +-module(lispc). + +-export([eval/1]). + +-record(st, {}). + +-include("lisp_test.erl"). + +-include("merl.hrl"). + +eval(Lisp) -> + compile(Lisp, tmp), + tmp:eval(). + +compile(Lisp, ModName) -> + {Code, _} = gen(Lisp, #st{}), + Main = ?Q(["() ->", + " __print = fun (S, Xs) -> io:format(S,Xs), [] end,", + " __apply = fun erlang:apply/2,", + " __plus = fun erlang:'+'/2,", + " __equal = fun lisp:equal/2,", + " __gt = fun lisp:gt/2,", + " __knot = fun lisp:knot/1,", + " __y = fun (F) ->", + " (fun (X) -> F(fun (Y) -> (X(X))(Y) end) end)", + " (fun (X) -> F(fun (Y) -> (X(X))(Y) end) end)", + " end,", + " _@Code"]), + Forms = merl_build:module_forms( + merl_build:add_function(true, eval, [Main], + merl_build:init_module(ModName))), + %% %% 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]). + +var(Atom) -> + merl:var(list_to_atom("__" ++ atom_to_list(Atom))). + +gen([lambda, Ps, B], St) when is_list(Ps) -> + case lists:all(fun is_atom/1, Ps) andalso + (length(Ps) =:= length(lists:usort(Ps))) of + true -> + Vars = [var(P) || P <- Ps], + {Body, St1} = gen(B, St), + {?Q("fun (_@Vars) -> _@Body end"), St1}; + false -> + throw(bad_lambda) + end; +gen([lambda | _], _) -> + throw(bad_lambda); +gen([def, A, V, B], St) when is_atom(A) -> + Var = var(A), + {Val, St1} = gen(V, St), + {Body, St2} = gen(B, St1), + {?Q("(fun (_@Var) -> _@Body end)(_@Val)"), St2}; +gen([def | _], _) -> + throw(bad_def); +gen([quote, A], St) -> + {merl:term(A), St}; +gen([quote | _], _) -> + throw(bad_quote); +gen([iff, X, A, B], St) -> + {Cond, St1} = gen(X, St), + {True, St2} = gen(A, St1), + {False, St3} = gen(B, St2), + {?Q(["case _@Cond of", + " [] -> _@False;", + " _ -> _@True", + "end"]), + St3}; +gen([do], _) -> + throw(bad_do); +gen([do | As], St0) -> + {Body, St1} = lists:mapfoldl(fun gen/2, St0, As), + {?Q("begin _@Body end"), St1}; +gen([list | As], St0) -> + {Elem, St1} = lists:mapfoldl(fun gen/2, St0, As), + {?Q("[ _@Elem ]"), St1}; +gen([_|_]=L, St) -> + {[F | As], St1} = lists:mapfoldl(fun gen/2, St, L), + {?Q("((_@F)(_@As))"), St1}; +gen(A, St) when is_atom(A) -> + {var(A), St}; +gen(C, St) -> + {merl:term(C), St}. diff --git a/lib/syntax_tools/examples/merl/merl_build.erl b/lib/syntax_tools/examples/merl/merl_build.erl new file mode 100644 index 0000000000..c539f8e2af --- /dev/null +++ b/lib/syntax_tools/examples/merl/merl_build.erl @@ -0,0 +1,104 @@ +%% --------------------------------------------------------------------- +%% 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 Making it simple to build a module with merl + +-module(merl_build). + +-export([init_module/1, module_forms/1, add_function/4, add_record/3, + add_import/3, add_attribute/3, set_file/2]). + +-import(merl, [term/1]). + +-include("merl.hrl"). + +-type filename() :: string(). + +-record(module, { name :: atom() + , file :: filename() + , exports=[] :: [{atom(), integer()}] + , imports=[] :: [{atom(), [{atom(), integer()}]}] + , attributes=[] :: [{filename(), atom(), [term()]}] + , records=[] :: [{filename(), atom(), + [{atom(), merl:tree()}]}] + , functions=[] :: [{filename(), atom(), [merl:tree()]}] + }). + +%% TODO: init module from a list of forms (from various sources) + +%% @doc Create a new module representation, using the given module name. +init_module(Name) when is_atom(Name) -> + %% use the module name as the default file name - better than nothing + #module{name=Name, file=atom_to_list(Name)}. + +%% @doc Get the list of syntax tree forms for a module representation. This can +%% be passed to compile/2. +module_forms(#module{name=Name, + exports=Xs, + imports=Is, + records=Rs, + attributes=As, + functions=Fs}) + when is_atom(Name), Name =/= undefined -> + Module = ?Q("-module('@Name@')."), + Exported = [erl_syntax:arity_qualifier(term(N), term(A)) + || {N,A} <- ordsets:from_list(Xs)], + Export = ?Q("-export(['@_Exported'/1])."), + Imports = [?Q("-import('@M@', ['@_NAs'/1]).") + || {M, Ns} <- Is, + NAs <- [[erl_syntax:arity_qualifier(term(N), term(A)) + || {N,A} <- ordsets:from_list(Ns)]] + ], + Attrs = [?Q("-file(\"'@File@\",1). -'@N@'('@T@').") + || {File, N, T} <- lists:reverse(As)], + Records = [?Q("-file(\"'@File@\",1). -record('@N@',{'@_RFs'=[]}).") + || {File, N, Es} <- lists:reverse(Rs), + RFs <- [[erl_syntax:record_field(term(F), V) + || {F,V} <- Es]] + ], + Functions = [?Q("-file(\"'@File@\",1). '@_F'() -> [].") + || {File, N, Cs} <- lists:reverse(Fs), + F <- [erl_syntax:function(term(N), Cs)]], + lists:flatten([Module, Export, Imports, Attrs, Records, Functions]). + +%% @doc Set the source file name for all subsequently added functions, +%% records, and attributes. +set_file(Filename, #module{}=M) -> + M#module{file=filename:flatten(Filename)}. + +%% @doc Add a function to a module representation. +add_function(Exported, Name, Clauses, + #module{file=File, exports=Xs, functions=Fs}=M) + when is_boolean(Exported), is_atom(Name), Clauses =/= [] -> + Arity = length(erl_syntax:clause_patterns(hd(Clauses))), + Xs1 = case Exported of + true -> [{Name,Arity} | Xs]; + false -> Xs + end, + M#module{exports=Xs1, functions=[{File, Name, Clauses} | Fs]}. + +%% @doc Add a record declaration to a module representation. +add_record(Name, Fields, #module{file=File, records=Rs}=M) + when is_atom(Name) -> + M#module{records=[{File, Name, Fields} | Rs]}. + +%% @doc Add a "wild" attribute, such as `-compile(Opts)' to a module +%% representation. Note that such attributes can only have a single argument. +add_attribute(Name, Term, #module{file=File, attributes=As}=M) + when is_atom(Name) -> + M#module{attributes=[{File, Name, Term} | As]}. + +%% @doc Add an import declaration to a module representation. +add_import(From, Names, #module{imports=Is}=M) + when is_atom(From), is_list(Names) -> + M#module{imports=[{From, Names} | Is]}. |