bootstrap

#!/usr/bin/env escript
%% -*- mode: erlang;erlang-indent-level: 4;indent-tabs-mode: nil -*-
%% ex: ft=erlang ts=4 sw=4 et

main(_Args) ->
    io:format("==> gmperl (generate)~n"),
    io:format("~s~n", [os:cmd("./rebar get-deps compile")]),
    true = code:add_path("ebin"),
    true = code:add_path("deps/erlydtl/ebin"),
    Defs = case file:consult("priv/definitions/gmperl") of
               {ok, Terms}     -> Terms;
               {error, Reason} ->
                   io:format(standard_error, "Invalid syntax in"
                             " priv/definitions/gmperl: ~p~n", [Reason]),
                   halt(1)
           end,
    {value, {nifs, Nifs}} = lists:keysearch(nifs, 1, Defs),
    {value, {templates, Templates}} = lists:keysearch(templates, 1, Defs),
    Ctx = get_nif_ctx(Nifs),
    lists:foreach(
      fun({Dir, Files}) ->
              lists:foreach(
                fun(Template) ->
                        Target = atom_to_list(Dir) ++ "/" ++ Template,
                        io:format("Generating ~s~n", [Target]),
                        {ok, Tpl} = file:read_file("priv/templates/" ++ Template),
                        ok = file:write_file(Target, render(Template, Tpl, Ctx))
                end, Files)
      end, Templates),
    io:format("~s~n", [os:cmd("./rebar compile eunit")]),
    0.

render(ModuleName, Bin, Context) ->
    Mod = list_to_atom(binary_to_list(iolist_to_binary(re:replace(ModuleName, "\\.", "_")))),
    {ok, Mod} = erlydtl:compile(Bin, Mod),
    {ok, Val} = Mod:render(Context),
    Val.

get_nif_ctx(Defs) -> [{A, [get_nif_fun(X) || X <- Fs]} || {A, Fs} <- Defs].

get_nif_fun(Vars) -> get_nif_fun_ver(Vars) ++ get_nif_list(Vars).

get_nif_fun_ver({_, _, _, _, _, _, {Maj, Min, Pat}}) ->
    [{version, [{major, Maj}, {minor, Min}, {patchlevel, Pat}]}];
get_nif_fun_ver(_) -> [].

get_nif_list(Vars) ->
    {Name, Args, RetType, CArgs, CRetType, CRet} =
        case Vars of
            {A, B, C, D, E, F, _} -> {A, B, C, D, E, F};
            {A, B, C, D, E, F} -> {A, B, C, D, E, F}
        end,
    [{name, Name},
     {ret_type, tname(RetType)},
     {return, return(CRet)},
     {ccall, call(CRetType, CArgs)},
     {locals, locals(CArgs)},
     {arity, length(Args)}] ++
        case Args of
            []    -> [];
            [H]   -> [head_arg(H)];
            [H|T] -> [head_arg(H), {tail_args, erl_args(T)}]
        end ++
        case needs_badarg(CArgs) of
            true  -> [{needs_badarg, true}];
            false -> []
        end ++
        case needs_priv(CArgs) of
            true  -> [{needs_priv, true}];
            false -> []
        end.

needs_priv(L) ->
    lists:any(
      fun({_, mpf_t}) -> true;
         ({_, mpq_t}) -> true;
         ({_, mpz_t}) -> true;
         (new_mpz_t)  -> true;
         (new_mpq_t)  -> true;
         (new_mpf_t)  -> true;
         (_)          -> false
      end, L).

return(ok) -> [{type, ok}];
return({I, T}) -> [{type, T}, {index, I}];
return([{I, T}, {I2, T2}]) ->
    [{tuple2, [{first, return({I, T})}, {second, return({I2, T2})}]}];
return(X) ->
    io:format(standard_error, "Warning: Return type ~p not"
              " supported!~n", [X]),
    [].

needs_badarg(L) -> lists:any(fun({_, _}) -> true; (_) -> false end, L).

head_arg(H) -> {head_arg, [{type, tname(H)}]}.

local({{In, Type}, I}) ->
    [{type, Type}, {index, I}, {in_index, In - 1}, {ctype, ctype(Type)}];
local({Type, I}) ->
    [{type, Type}, {index, I}, {ctype, ctype(Type)}] ++
        case lists:member(Type, [new_mpz_t, new_mpq_t, new_mpf_t]) of
            true  -> [{dealloc, true}];
            false -> []
        end.

locals(CArgs) -> [local(L) || L <- seqzip(CArgs)].

seqzip(L) -> lists:zip(L, lists:seq(1, length(L))).

call(RetType, Args) ->
    case seqzip(Args) of
            []    -> [];
            [H]   -> [{head, head_c_arg(H)}];
            [H|T] ->
                [{head, head_c_arg(H)},
                 {tail, [head_c_arg(A) || A <- T]}]
    end ++
        case RetType of
            void        -> [];
            _ -> [{retval, RetType},
                  {cretval, cretval(RetType)}]
        end.

head_c_arg({X, I}) ->
    [{type, X},
     {ctype, ctype(X)},
     {index, I}] ++
        case c_ptr(X) of
            []   -> [];
            CPtr -> [{pointer, CPtr}]
        end ++
        case c_ref(X) of
            []   -> [];
            CRef -> [{reference, CRef}]
        end.

c_ref(double_out) -> true;
c_ref(long_out)   -> true;
c_ref(uint_out)   -> true;
c_ref(int_out)    -> true;
c_ref(_)          -> [].

c_ptr(new_mpz_t)  -> [{target, "z"}];
c_ptr({_, mpz_t}) -> [{target, "z"}];
c_ptr(new_mpq_t)  -> [{target, "q"}];
c_ptr({_, mpq_t}) -> [{target, "q"}];
c_ptr(new_mpf_t)  -> [{target, "f"}];
c_ptr({_, mpf_t}) -> [{target, "f"}];
c_ptr(_)          -> [].

tname(ok)     -> ok;
tname({A, B}) -> io_lib:format("{~s, ~s}", [tname(A), tname(B)]);
tname(A)      -> atom_to_list(A) ++ "()".

erl_args(L) -> [[{type, tname(X)}] || X <- L].

ctype(uint) -> "unsigned int";
ctype(int_out) -> "int";
ctype(uint_out) -> "unsigned int";
ctype(long_out) -> "long";
ctype(ulong) -> "unsigned long";
ctype(string) -> "char";
ctype(num_base) -> "unsigned";
ctype(mpz_t) -> "gmperl_mpz_t *";
ctype(mpq_t) -> "gmperl_mpq_t *";
ctype(mpf_t) -> "gmperl_mpf_t *";
ctype(new_mpz_t) -> "gmperl_mpz_t *";
ctype(new_mpq_t) -> "gmperl_mpq_t *";
ctype(new_mpf_t) -> "gmperl_mpf_t *";
ctype(char_ptr) -> "char *";
ctype(X) -> X.

cretval(string) -> "char *";
cretval(assert_zero) -> "int";
cretval(boolean) -> "int";
cretval(X) -> ctype(X).