diff options
Diffstat (limited to 'lib/ic/src/ic_erlbe.erl')
| -rw-r--r-- | lib/ic/src/ic_erlbe.erl | 1141 |
1 files changed, 1141 insertions, 0 deletions
diff --git a/lib/ic/src/ic_erlbe.erl b/lib/ic/src/ic_erlbe.erl new file mode 100644 index 0000000000..75c87929db --- /dev/null +++ b/lib/ic/src/ic_erlbe.erl @@ -0,0 +1,1141 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1998-2009. All Rights Reserved. +%% +%% The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved online at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% %CopyrightEnd% +%% +%% +-module(ic_erlbe). + + +-export([do_gen/3]). +%%------------------------------------------------------------ +%% +%% Internal stuff +%% +%%------------------------------------------------------------ + +-export([unfold/1, mk_attr_func_names/2]). + + +-import(ic_util, [mk_name/2, mk_var/1, mk_oe_name/2, to_atom/1, to_list/1]). +-import(ic_forms, [get_id/1, get_id2/1, get_body/1, is_oneway/1]). +-import(ic_codegen, [emit/2, emit/3, nl/1]). +-import(ic_options, [get_opt/2]). + +-import(lists, [foreach/2, foldr/3, map/2]). + + +-include("icforms.hrl"). +-include("ic.hrl"). + +-include_lib("stdlib/include/erl_compile.hrl"). + + +%%------------------------------------------------------------ +%% +%% Generate the client side Erlang stubs. +%% +%% Each module is generated to a separate file. +%% +%% Export declarations for all interface functions must be +%% generated. Each function then needs to generate a function head and +%% a body. IDL parameters must be converted into Erlang parameters +%% (variables, capitalised) and a type signature list must be +%% generated (for later encode/decode). +%% +%%------------------------------------------------------------ +do_gen(G, File, Form) -> + GT = get_opt(G, be), + G2 = ic_file:filename_push(G, [], mk_oe_name(G, + ic_file:remove_ext(to_list(File))), + erlang), + Light = ic_options:get_opt(G, light_ifr), + R = if + GT == erl_corba, Light == false -> + case ic_genobj:is_stubfile_open(G2) of + true -> + emit(ic_genobj:stubfiled(G2), "-include_lib(\"~s/include/~s\").\n\n", + [?ORBNAME, ?IFRTYPESHRL]); + false -> ok + end, + gen_head(G2, [], Form), + ic_codegen:export(ic_genobj:stubfiled(G2), + [{ictk:register_name(G2), 0}, + {ictk:unregister_name(G2), 0}, + {oe_get_module,5}, + {oe_dependency,0}]), + R0= gen(G2, [], Form), + ictk:reg_gen(G2, [], Form), + ictk:unreg_gen(G2, [], Form), % "new" unreg_gen/3 + genDependency(G2), % creates code for dependency list + R0; + GT == erl_corba, Light == true -> + case ic_genobj:is_stubfile_open(G2) of + true -> + emit(ic_genobj:stubfiled(G2), "-include_lib(\"~s/include/~s\").\n\n", + [?ORBNAME, ?IFRTYPESHRL]); + false -> ok + end, + gen_head(G2, [], Form), + ic_codegen:export(ic_genobj:stubfiled(G2), + [{ictk:register_name(G2), 0}, + {ictk:register_name(G2), 1}, + {ictk:unregister_name(G2), 0}, + {ictk:unregister_name(G2), 1}]), + R0= gen(G2, [], Form), + ictk:reg_gen(G2, [], Form), + ictk:unreg_gen(G2, [], Form), % "new" unreg_gen/3 + R0; + true -> + gen_head(G2, [], Form), + gen(G2, [], Form) + end, + ic_file:filename_pop(G2, erlang), + R. + + +gen(G, N, [X|Xs]) when is_record(X, preproc) -> + NewG = ic:handle_preproc(G, N, X#preproc.cat, X), + gen(NewG, N, Xs); + +gen(G, N, [X|Xs]) when is_record(X, module) -> + CD = ic_code:codeDirective(G,X), + G2 = ic_file:filename_push(G, N, X, CD), + N2 = [get_id2(X) | N], + gen_head(G2, N2, X), + gen(G2, N2, get_body(X)), + G3 = ic_file:filename_pop(G2, CD), + gen(G3, N, Xs); + +gen(G, N, [X|Xs]) when is_record(X, interface) -> + G2 = ic_file:filename_push(G, N, X, erlang), + N2 = [get_id2(X) | N], + gen_head(G2, N2, X), + gen(G2, N2, get_body(X)), + foreach(fun({_Name, Body}) -> gen(G2, N2, Body) end, + X#interface.inherit_body), + gen_serv(G2, N, X), + G3 = ic_file:filename_pop(G2, erlang), + gen(G3, N, Xs); + +gen(G, N, [X|Xs]) when is_record(X, const) -> +% N2 = [get_id2(X) | N], + emit_constant_func(G, X#const.id, X#const.val), + gen(G, N, Xs); %% N2 or N? + +gen(G, N, [X|Xs]) when is_record(X, op) -> + {Name, ArgNames, TypeList, OutArgs} = extract_info(G, N, X), + emit_stub_func(G, N, X, Name, ArgNames, TypeList, OutArgs, + is_oneway(X), get_opt(G, be)), + gen(G, N, Xs); + +gen(G, N, [X|Xs]) when is_record(X, attr) -> + emit_attr(G, N, X, fun emit_stub_func/9), + gen(G, N, Xs); + +gen(G, N, [X|Xs]) when is_record(X, except) -> + icstruct:except_gen(G, N, X, erlang), + gen(G, N, Xs); + +gen(G, N, [X|Xs]) -> + case may_contain_structs(X) of + true -> icstruct:struct_gen(G, N, X, erlang); + false -> ok + end, + gen(G, N, Xs); + +gen(_G, _N, []) -> ok. + + +may_contain_structs(X) when is_record(X, typedef) -> true; +may_contain_structs(X) when is_record(X, struct) -> true; +may_contain_structs(X) when is_record(X, union) -> true; +may_contain_structs(_X) -> false. + + + +%%-------------------------------------------------------------------- +%% +%% Generate the server side (handle_call and handle_cast) +%% + +gen_serv(G, N, X) -> + case ic_genobj:is_stubfile_open(G) of + true -> + GT = get_opt(G, be), + gen_oe_is_a(G, N, X, GT), + N2 = [get_id2(X) | N], + gen_oe_tc(G, N2, X, GT), + + emit_serv_std(GT, G, N, X), + + gen_calls(G, N2, get_body(X)), + lists:foreach(fun({_Name, Body}) -> + gen_calls(G, N2, Body) end, + X#interface.inherit_body), + gen_end_of_call(GT, G), + + gen_casts(G, N2, get_body(X)), + lists:foreach(fun({_Name, Body}) -> + gen_casts(G, N2, Body) end, + X#interface.inherit_body), + gen_end_of_cast(GT, G), + emit_skel_footer(GT, G, N, X); % Note N instead of N2 + false -> + ok + end. + +gen_oe_is_a(G, N, X, erl_corba) when is_record(X, interface) -> + Fd = ic_genobj:stubfiled(G), + ic_codegen:mcomment(Fd, ["Inherited Interfaces"]), + emit(Fd, "oe_is_a(~p) -> true;\n", [ictk:get_IR_ID(G, N, X)]), + lists:foreach(fun(ScopedName) -> + emit(Fd, "oe_is_a(~p) -> true;\n", + [ic_pragma:scope2id(G, ScopedName)]) + end, X#interface.inherit), + emit(Fd, "oe_is_a(_) -> false.\n"), + nl(Fd), + ok; +gen_oe_is_a(_G, _N, _X, _BE) -> ok. + + +%% Generates the oe_tc function +gen_oe_tc(G, N, X, erl_corba) -> + Fd = ic_genobj:stubfiled(G), + ic_codegen:mcomment(Fd, ["Interface TypeCode"]), + LocalInterface = gen_oe_tc2(G, N, get_body(X), Fd, []), + CompleteInterface = + lists:foldl(fun({Name, Body}, FunAcc) -> + AName = ic_util:to_atom(ic_util:to_undersc(Name)), + gen_oe_tc3(G, AName, Body, Fd, FunAcc) + end, LocalInterface, X#interface.inherit_body), + emit(Fd, "oe_tc(_) -> undefined.\n"), + nl(Fd), + emit(Fd, "oe_get_interface() -> \n\t["), + emit_oe_get_interface(Fd, CompleteInterface), + nl(Fd), + ok; +gen_oe_tc(_, _, _, _) -> + ok. + +emit_oe_get_interface(Fd, []) -> + emit(Fd, "].\n"); +emit_oe_get_interface(Fd, [Item]) -> + emit(Fd, "~s].\n", [lists:flatten(Item)]); +emit_oe_get_interface(Fd, [H|T]) -> + emit(Fd, "~s,\n\t", [lists:flatten(H)]), + emit_oe_get_interface(Fd, T). + +gen_oe_tc2(_,_,[],_, Acc) -> + Acc; +gen_oe_tc2(G, N, [X|Rest], Fd, Acc) when is_record(X, op) -> + R = ic_forms:get_tk(X), + IN = lists:map(fun(P) -> ic_forms:get_tk(P) end, + ic:filter_params([in, inout], X#op.params)), + OUT = lists:map(fun(P) -> ic_forms:get_tk(P) end, + ic:filter_params([out, inout], X#op.params)), + Function = get_id2(X), + FunctionAtom = ic_util:to_atom(Function), + emit(Fd, "oe_tc(~p) -> \n\t~p;\n",[FunctionAtom, {R, IN, OUT}]), + GI = io_lib:format("{~p, oe_tc(~p)}",[Function, FunctionAtom]), + gen_oe_tc2(G, N, Rest, Fd, [GI|Acc]); + +gen_oe_tc2(G, N, [X|Rest], Fd, Acc) when is_record(X, attr) -> + {GetT, SetT} = mk_attr_func_types([], X), + NewAcc = + lists:foldl(fun(Id, FunAcc) -> + {Get, Set} = mk_attr_func_names([], get_id(Id)), + GetAttrAtom = ic_util:to_atom(Get), + emit(Fd, "oe_tc(~p) -> \n\t~p;\n", + [GetAttrAtom, GetT]), + case X#attr.readonly of + {readonly, _} -> + GI = io_lib:format("{~p, oe_tc(~p)}", + [Get, GetAttrAtom]), + [GI|FunAcc]; + _ -> + SetAttrAtom = ic_util:to_atom(Set), + + emit(Fd, "oe_tc(~p) -> \n\t~p;\n", + [SetAttrAtom, SetT]), + GetGI = io_lib:format("{~p, oe_tc(~p)}", + [Get, GetAttrAtom]), + SetGI = io_lib:format("{~p, oe_tc(~p)}", + [Set, SetAttrAtom]), + [GetGI, SetGI|FunAcc] + end + end, Acc, ic_forms:get_idlist(X)), + gen_oe_tc2(G, N, Rest, Fd, NewAcc); + +gen_oe_tc2(G,N,[_X|Rest], Fd, Acc) -> + gen_oe_tc2(G,N,Rest, Fd, Acc). + + +gen_oe_tc3(_,_,[],_, Acc) -> + Acc; +gen_oe_tc3(G, N, [X|Rest], Fd, Acc) when is_record(X, op) -> + Function = get_id2(X), + FunctionAtom = ic_util:to_atom(get_id2(X)), + GI = io_lib:format("{~p, ~p:oe_tc(~p)}",[Function, N, FunctionAtom]), + emit(Fd, "oe_tc(~p) -> ~p:oe_tc(~p);\n", + [FunctionAtom, N, FunctionAtom]), + gen_oe_tc3(G, N, Rest, Fd, [GI|Acc]); + +gen_oe_tc3(G, N, [X|Rest], Fd, Acc) when is_record(X, attr) -> + NewAcc = lists:foldl(fun(Id, FunAcc) -> + {Get, Set} = mk_attr_func_names([], get_id(Id)), + GetAttrAtom = ic_util:to_atom(Get), + emit(Fd, "oe_tc(~p) -> ~p:oe_tc(~p);\n", + [GetAttrAtom, N, GetAttrAtom]), + case X#attr.readonly of + {readonly, _} -> + [io_lib:format("{~p, ~p:oe_tc(~p)}", + [Get, N, GetAttrAtom])|FunAcc]; + _ -> + SetAttrAtom = ic_util:to_atom(Set), + emit(Fd, "oe_tc(~p) -> ~p:oe_tc(~p);\n", + [SetAttrAtom, N, SetAttrAtom]), + [io_lib:format("{~p, ~p:oe_tc(~p)}", + [Get, N, GetAttrAtom]), + io_lib:format("{~p, ~p:oe_tc(~p)}", + [Set, N, SetAttrAtom])|FunAcc] + end + end, Acc, ic_forms:get_idlist(X)), + gen_oe_tc3(G, N, Rest, Fd, NewAcc); + +gen_oe_tc3(G,N,[_X|Rest], Fd, Acc) -> + gen_oe_tc3(G,N,Rest, Fd, Acc). + +gen_calls(G, N, [X|Xs]) when is_record(X, op) -> + case is_oneway(X) of + false -> + {Name, ArgNames, TypeList, OutArgs} = extract_info(G, N, X), + emit_skel_func(G, N, X, Name, ArgNames, TypeList, OutArgs, false, + get_opt(G, be)), + gen_calls(G, N, Xs); + true -> + gen_calls(G, N, Xs) + end; + +gen_calls(G, N, [X|Xs]) when is_record(X, attr) -> + emit_attr(G, N, X, fun emit_skel_func/9), + gen_calls(G, N, Xs); + +gen_calls(G, N, [_X|Xs]) -> gen_calls(G, N, Xs); +gen_calls(_G, _N, []) -> ok. + +gen_casts(G, N, [X|Xs]) when is_record(X, op) -> + case is_oneway(X) of + true -> + {Name, ArgNames, TypeList, OutArgs} = extract_info(G, N, X), + emit_skel_func(G, N, X, Name, ArgNames, TypeList, OutArgs, true, + get_opt(G, be)), + gen_casts(G, N, Xs); + false -> + gen_casts(G, N, Xs) + end; + +gen_casts(G, N, [_X|Xs]) -> gen_casts(G, N, Xs); +gen_casts(_G, _N, []) -> ok. + +emit_attr(G, N, X, F) -> + XX = #id_of{type=X}, + BE = get_opt(G, be), + {GetType, SetType} = mk_attr_func_types(N, X), + lists:foreach(fun(Id) -> + X2 = XX#id_of{id=Id}, + {Get, Set} = mk_attr_func_names(N, get_id(Id)), + F(G, N, X2, Get, [], GetType, [], + is_oneway(X2), BE), + case X#attr.readonly of + {readonly, _} -> ok; + _ -> + F(G, N, X2, Set, [mk_name(G, "Value")], + SetType, [], + is_oneway(X2), BE) + end end, ic_forms:get_idlist(X)). + + +extract_info(G, _N, X) when is_record(X, op) -> + Name = get_id2(X), + InArgs = ic:filter_params([in,inout], X#op.params), + OutArgs = ic:filter_params([out,inout], X#op.params), + ArgNames = mk_erl_vars(G, InArgs), + TypeList = {ic_forms:get_tk(X), + map(fun(Y) -> ic_forms:get_tk(Y) end, InArgs), + map(fun(Y) -> ic_forms:get_tk(Y) end, OutArgs) + }, + {Name, ArgNames, TypeList, OutArgs}. + + + +%% This function generates the standard functions of an object +%% gen_server +emit_serv_std(erl_corba, G, N, X) -> + Fd = ic_genobj:stubfiled(G), + Impl = ic_genobj:impl(G), + TypeID = ictk:get_IR_ID(G, N, X), + + nl(Fd), nl(Fd), nl(Fd), + ic_codegen:mcomment(Fd, ["Object server implementation."]), + nl(Fd), nl(Fd), + ic_codegen:mcomment(Fd, ["Function for fetching the interface type ID."]), + nl(Fd), + emit(Fd, "typeID() ->\n"), + emit(Fd, " \"~s\".\n", [TypeID]), + nl(Fd), nl(Fd), + ic_codegen:mcomment(Fd, ["Object creation functions."]), + nl(Fd), + emit(Fd, "oe_create() ->\n"), + emit(Fd, " corba:create(?MODULE, \"~s\").\n", [TypeID]), + nl(Fd), + emit(Fd, "oe_create_link() ->\n"), + emit(Fd, " corba:create_link(?MODULE, \"~s\").\n", [TypeID]), + nl(Fd), + emit(Fd, "oe_create(Env) ->\n"), + emit(Fd, " corba:create(?MODULE, \"~s\", Env).\n", [TypeID]), + nl(Fd), + emit(Fd, "oe_create_link(Env) ->\n"), + emit(Fd, " corba:create_link(?MODULE, \"~s\", Env).\n", [TypeID]), + nl(Fd), + emit(Fd, "oe_create(Env, RegName) ->\n"), + emit(Fd, " corba:create(?MODULE, \"~s\", Env, RegName).\n", [TypeID]), + nl(Fd), + emit(Fd, "oe_create_link(Env, RegName) ->\n"), + emit(Fd, " corba:create_link(?MODULE, \"~s\", Env, RegName).\n", [TypeID]), + nl(Fd), + ic_codegen:mcomment(Fd, ["Init & terminate functions."]), + nl(Fd), + emit(Fd, "init(Env) ->\n"), + ic_codegen:comment(Fd, "Call to implementation init"), + emit(Fd, " corba:handle_init(~p, Env).\n", [to_atom(Impl)]), + nl(Fd), + emit(Fd, "terminate(Reason, State) ->\n"), + emit(Fd, " corba:handle_terminate(~p, Reason, State).\n", + [to_atom(Impl)]), + nl(Fd), nl(Fd), + Fd; +emit_serv_std(erl_genserv, G, N, X) -> + Fd = ic_genobj:stubfiled(G), + Impl = ic_genobj:impl(G), + TypeID = ictk:get_IR_ID(G, N, X), + + nl(Fd), nl(Fd), nl(Fd), + ic_codegen:mcomment(Fd, ["Server implementation."]), + nl(Fd), nl(Fd), + ic_codegen:mcomment(Fd, ["Function for fetching the interface type ID."]), + nl(Fd), + emit(Fd, "typeID() ->\n"), + emit(Fd, " \"~s\".\n", [TypeID]), + nl(Fd), nl(Fd), + ic_codegen:mcomment(Fd, ["Server creation functions."]), + nl(Fd), + emit(Fd, "oe_create() ->\n"), + emit(Fd, " start([], []).\n", []), + nl(Fd), + emit(Fd, "oe_create_link() ->\n"), + emit(Fd, " start_link([], []).\n", []), + nl(Fd), + emit(Fd, "oe_create(Env) ->\n"), + emit(Fd, " start(Env, []).\n", []), + nl(Fd), + emit(Fd, "oe_create_link(Env) ->\n"), + emit(Fd, " start_link(Env, []).\n", []), + nl(Fd), + emit(Fd, "oe_create(Env, RegName) ->\n"), + emit(Fd, " start(RegName, Env, []).\n", []), + nl(Fd), + emit(Fd, "oe_create_link(Env, RegName) ->\n"), + emit(Fd, " start_link(RegName, Env, []).\n", []), + nl(Fd), + ic_codegen:mcomment(Fd, ["Start functions."]), + nl(Fd), + emit(Fd, "start(Env, Opt) ->\n"), + emit(Fd, " gen_server:start(?MODULE, Env, Opt).\n"), + nl(Fd), + emit(Fd, "start_link(Env, Opt) ->\n"), + emit(Fd, " gen_server:start_link(?MODULE, Env, Opt).\n"), + nl(Fd), + emit(Fd, "start(RegName, Env, Opt) ->\n"), + emit(Fd, " gen_server:start(RegName, ?MODULE, Env, Opt).\n"), + nl(Fd), + emit(Fd, "start_link(RegName, Env, Opt) ->\n"), + emit(Fd, " gen_server:start_link(RegName, ?MODULE, Env, Opt).\n"), + nl(Fd), + ic_codegen:comment(Fd, "Standard gen_server termination"), + emit(Fd, "stop(OE_THIS) ->\n"), + emit(Fd, " gen_server:cast(OE_THIS,stop).\n"), + nl(Fd), + ic_codegen:comment(Fd, "Call to implementation init"), + emit(Fd, "init(Env) ->\n"), + emit(Fd, " ~p:~p(Env).\n", [to_atom(Impl), init]), + nl(Fd), + emit(Fd, "terminate(Reason, State) ->\n"), + emit(Fd, " ~p:~p(Reason, State).\n", + [to_atom(Impl), terminate]), + nl(Fd), nl(Fd), + Fd. + +gen_end_of_call(erl_corba, G) -> + Fd = ic_genobj:stubfiled(G), + nl(Fd), nl(Fd), + ic_codegen:mcomment_light(Fd, ["Standard gen_server call handle"]), + emit(Fd, "handle_call(stop, _, State) ->\n"), + emit(Fd, " {stop, normal, ok, State}"), + case get_opt(G, serv_last_call) of + exception -> + emit(Fd, ";\n"), + nl(Fd), + emit(Fd, "handle_call(_, _, State) ->\n"), + emit(Fd, " {reply, catch corba:raise(#'BAD_OPERATION'{minor=1163001857, completion_status='COMPLETED_NO'}), State}.\n"); + exit -> + emit(Fd, ".\n"), + nl(Fd), + nl(Fd) + end, + ok; +gen_end_of_call(erl_genserv, G) -> + Fd = ic_genobj:stubfiled(G), + nl(Fd), nl(Fd), + ic_codegen:mcomment_light(Fd, ["Standard gen_server call handle"]), + emit(Fd, "handle_call(stop, _, State) ->\n"), + emit(Fd, " {stop, normal, ok, State}"), + emit(Fd, ".\n"), + nl(Fd), nl(Fd), + ok. + +gen_end_of_cast(erl_corba, G) -> + Fd = ic_genobj:stubfiled(G), + nl(Fd), nl(Fd), + ic_codegen:mcomment_light(Fd, ["Standard gen_server cast handle"]), + emit(Fd, "handle_cast(stop, State) ->\n"), + emit(Fd, " {stop, normal, State}"), + case get_opt(G, serv_last_call) of + exception -> + emit(Fd, ";\n"), + nl(Fd), + emit(Fd, "handle_cast(_, State) ->\n"), + emit(Fd, " {noreply, State}.\n"); + exit -> + emit(Fd, ".\n"), + nl(Fd), nl(Fd) + end, + ok; +gen_end_of_cast(erl_genserv, G) -> + Fd = ic_genobj:stubfiled(G), + nl(Fd), nl(Fd), + ic_codegen:mcomment_light(Fd, ["Standard gen_server cast handle"]), + emit(Fd, "handle_cast(stop, State) ->\n"), + emit(Fd, " {stop, normal, State}"), + emit(Fd, ".\n"), + nl(Fd), nl(Fd), + ok. + +emit_skel_footer(erl_corba, G, N, X) -> + Fd = ic_genobj:stubfiled(G), + nl(Fd), nl(Fd), + ic_codegen:mcomment_light(Fd, ["Standard gen_server handles"]), + case use_impl_handle_info(G, N, X) of + true -> + emit(Fd, "handle_info(Info, State) ->\n"), + emit(Fd, " corba:handle_info(~p, Info, State).\n\n", + [list_to_atom(ic_genobj:impl(G))]); + false -> + emit(Fd, "handle_info(_, State) ->\n"), + emit(Fd, " {noreply, State}.\n\n") + end, + nl(Fd), + case get_opt(G, no_codechange) of + false -> + emit(Fd, "code_change(OldVsn, State, Extra) ->\n"), + emit(Fd, " corba:handle_code_change(~p, OldVsn, State, Extra).\n\n", + [list_to_atom(ic_genobj:impl(G))]); + true -> + emit(Fd, "code_change(_, State, _) ->\n"), + emit(Fd, " {ok, State}.\n\n") + end, + ok; +emit_skel_footer(erl_genserv, G, N, X) -> + Fd = ic_genobj:stubfiled(G), + nl(Fd), nl(Fd), + ic_codegen:mcomment_light(Fd, ["Standard gen_server handles"]), + case use_impl_handle_info(G, N, X) of + true -> + emit(Fd, "handle_info(Info, State) ->\n"), + emit(Fd, " ~p:handle_info(Info, State).\n\n", + [list_to_atom(ic_genobj:impl(G))]); + false -> + emit(Fd, "handle_info(_, State) ->\n"), + emit(Fd, " {noreply, State}.\n\n") + end, + nl(Fd), nl(Fd), + case get_opt(G, no_codechange) of + false -> + emit(Fd, "code_change(OldVsn, State, Extra) ->\n"), + emit(Fd, " ~p:code_change(OldVsn, State, Extra).\n\n", + [list_to_atom(ic_genobj:impl(G))]); + true -> + emit(Fd, "code_change(_, State, _) ->\n"), + emit(Fd, " {ok, State}.\n\n") + end, + ok. + + +use_impl_handle_info(G, N, X) -> + FullName = ic_util:to_colon([get_id2(X) | N]), + case {get_opt(G, {handle_info, true}), get_opt(G, {handle_info, FullName})} of + {_, force_false} -> false; + {false, false} -> false; + _ -> true + end. + +use_timeout(G, N, _X) -> + FullName = ic_util:to_colon(N), + case {get_opt(G, {timeout, true}), get_opt(G, {timeout, FullName})} of + {_, force_false} -> false; + {false, false} -> false; + _ -> true + end. + +use_precond(G, N, X) -> + FullName = ic_util:to_colon([get_id2(X) | N]), + case get_opt(G, {precond, FullName}) of + false -> + InterfaceName = ic_util:to_colon(N), + case get_opt(G, {precond, InterfaceName}) of + false -> + case get_opt(G, precond) of + false -> false; + V2 -> V2 + end; + V2 -> V2 + end; + V1 -> V1 + end. + +use_postcond(G, N, X) -> + FullName = ic_util:to_colon([get_id2(X) | N]), + case get_opt(G, {postcond, FullName}) of + false -> + InterfaceName = ic_util:to_colon(N), + case get_opt(G, {postcond, InterfaceName}) of + false -> + case get_opt(G, postcond) of + false -> false; + V3 -> V3 + end; + V2 -> V2 + end; + V1 -> V1 + end. + + +%%------------------------------------------------------------ +%% +%% Export stuff +%% +%% Gathering of all names that should be exported from a stub +%% file. +%% + + +gen_head_special(G, N, X) when is_record(X, interface) -> + Fd = ic_genobj:stubfiled(G), + + foreach(fun({Name, Body}) -> + ic_codegen:comment(Fd, "Exports from ~p", + [ic_util:to_colon(Name)]), + ic_codegen:export(Fd, exp_top(G, N, Body, [], get_opt(G, be))), + nl(Fd) + end, X#interface.inherit_body), + + ic_codegen:comment(Fd, "Type identification function"), + ic_codegen:export(Fd, [{typeID, 0}]), + nl(Fd), + ic_codegen:comment(Fd, "Used to start server"), + ic_codegen:export(Fd, [{oe_create, 0}, {oe_create_link, 0}, {oe_create, 1}, {oe_create_link, 1}, + {oe_create, 2}, {oe_create_link, 2}]), + nl(Fd), + case get_opt(G, be) of + erl_corba -> + ic_codegen:comment(Fd, "TypeCode Functions and inheritance"), + ic_codegen:export(Fd, [{oe_tc, 1}, {oe_is_a, 1}, {oe_get_interface, 0}]); + _ -> + ic_codegen:export(Fd, [{start, 2}, {start_link, 3}]) + end, + nl(Fd), + ic_codegen:comment(Fd, "gen server export stuff"), + emit(Fd, "-behaviour(gen_server).\n"), + + case get_opt(G, be) of + erl_genserv -> %% stop/1 is only for erl_genserv backend + ic_codegen:export(Fd, [{stop, 1}, {init, 1}, {terminate, 2}, {handle_call, 3}, + {handle_cast, 2}, {handle_info, 2}, {code_change, 3}]); + _ -> + ic_codegen:export(Fd, [{init, 1}, {terminate, 2}, {handle_call, 3}, + {handle_cast, 2}, {handle_info, 2}, {code_change, 3}]) + end, + + case get_opt(G, be) of + erl_corba -> + nl(Fd), + emit(Fd, "-include_lib(\"~s/include/~s\").\n", [?ORBNAME, ?CORBAHRL]); + _ -> + ok + end, + nl(Fd), nl(Fd), + ic_codegen:mcomment(Fd, ["Object interface functions."]), + nl(Fd), nl(Fd), nl(Fd), + Fd; +gen_head_special(_G, _N, _X) -> ok. + + + +%% Shall generate all export declarations +gen_head(G, N, X) -> + case ic_genobj:is_stubfile_open(G) of + true -> + F = ic_genobj:stubfiled(G), + ic_codegen:comment(F, "Interface functions"), + ic_codegen:export(F, exp_top(G, N, X, [], get_opt(G, be))), + nl(F), + gen_head_special(G, N, X); + false -> ok + end. + +exp_top(_G, _N, X, Acc, _) when element(1, X) == preproc -> + Acc; +exp_top(G, N, L, Acc, BE) when is_list(L) -> + exp_list(G, N, L, Acc, BE); +exp_top(G, N, M, Acc, BE) when is_record(M, module) -> + exp_list(G, N, get_body(M), Acc, BE); +exp_top(G, N, I, Acc, BE) when is_record(I, interface) -> + exp_list(G, N, get_body(I), Acc, BE); +exp_top(G, N, X, Acc, BE) -> + exp3(G, N, X, Acc, BE). + +exp3(_G, _N, C, Acc, _BE) when is_record(C, const) -> + [{get_id(C#const.id), 0} | Acc]; +exp3(_G, _N, Op, Acc, erl_corba) when is_record(Op, op) -> + FuncName = get_id(Op#op.id), + Arity = length(ic:filter_params([in, inout], Op#op.params)) + 1, + [{FuncName, Arity}, {FuncName, Arity+1} | Acc]; +exp3(G, N, Op, Acc, _BE) when is_record(Op, op) -> + FuncName = get_id(Op#op.id), + Arity = + case use_timeout(G,N,Op) of + true -> + %% NO TimeOut on ONEWAYS here !!!! + case is_oneway(Op) of + true -> + length(ic:filter_params([in, inout], Op#op.params)) + 1; + false -> + length(ic:filter_params([in, inout], Op#op.params)) + 2 + end; + false -> + length(ic:filter_params([in, inout], Op#op.params)) + 1 + end, + [{FuncName, Arity} | Acc]; + +exp3(_G, _N, A, Acc, erl_corba) when is_record(A, attr) -> + lists:foldr(fun(Id, Acc2) -> + {Get, Set} = mk_attr_func_names([], get_id(Id)), + case A#attr.readonly of + {readonly, _} -> [{Get, 1}, {Get, 2} | Acc2]; + _ -> [{Get, 1}, {Get, 2}, + {Set, 2}, {Set, 3} | Acc2] + end end, Acc, ic_forms:get_idlist(A)); +exp3(_G, _N, A, Acc, _BE) when is_record(A, attr) -> + lists:foldr(fun(Id, Acc2) -> + {Get, Set} = mk_attr_func_names([], get_id(Id)), + case A#attr.readonly of + {readonly, _} -> [{Get, 1} | Acc2]; + _ -> [{Get, 1}, {Set, 2} | Acc2] + end end, Acc, ic_forms:get_idlist(A)); + +exp3(_G, _N, _X, Acc, _BE) -> Acc. + +exp_list(G, N, L, OrigAcc, BE) -> + lists:foldr(fun(X, Acc) -> exp3(G, N, X, Acc, BE) end, OrigAcc, L). + + + + +%%------------------------------------------------------------ +%% +%% Emit stuff +%% +%% Low level generation primitives +%% + +emit_stub_func(G, N, X, Name, ArgNames, _TypeList, OutArgs, Oneway, Backend) -> + case ic_genobj:is_stubfile_open(G) of + false -> + ok; + true -> + Fd = ic_genobj:stubfiled(G), + StubName = list_to_atom(Name), + UsingTimeout = use_timeout(G, N, X), + Timeout = case UsingTimeout of + true -> + mk_name(G, "Timeout"); + false -> + "infinity" + end, + Options = mk_name(G, "Options"), + This = mk_name(G, "THIS"), + CallOrCast = + case is_oneway(X) of + true -> ?CAST; + _ -> ?CALL + end, + emit_op_comment(G, Fd, X, StubName, ArgNames, OutArgs), + case Backend of + erl_corba -> + emit(Fd, "~p(~s) ->\n", + [StubName, mk_list([This | ArgNames])]), + emit(Fd, " ~s:~s(~s, ~p, [~s], ?MODULE).\n\n", + [?CORBAMOD, CallOrCast, This, StubName, mk_list(ArgNames)]), + emit(Fd, "~p(~s) ->\n", + [StubName, mk_list([This, Options| ArgNames])]), + emit(Fd, " ~s:~s(~s, ~p, [~s], ?MODULE, ~s).\n\n", + [?CORBAMOD, CallOrCast, This, StubName, mk_list(ArgNames), + Options]); + _ -> + FunName = case ic_options:get_opt(G, scoped_op_calls) of + true -> + list_to_atom(ic_util:to_undersc([Name | N])); + false -> + StubName + end, + %% NO TimeOut on ONEWAYS here !!!! + case Oneway of + true -> + emit(Fd, "~p(~s) ->\n", + [StubName, mk_list([This | ArgNames])]); + false -> + case UsingTimeout of + true -> + emit(Fd, "~p(~s) ->\n", + [StubName, mk_list([This, Timeout| ArgNames])]); + false -> + emit(Fd, "~p(~s) ->\n", + [StubName, mk_list([This | ArgNames])]) + end + end, + + %% NO TimeOut on ONEWAYS here !!!! + if + length(ArgNames) == 0 -> + case is_oneway(X) of + true -> + emit(Fd, " ~s:~s(~s, ~p).\n\n", + [?GENSERVMOD, CallOrCast, This, FunName]); + false -> + emit(Fd, " ~s:~s(~s, ~p, ~s).\n\n", + [?GENSERVMOD, CallOrCast, This, FunName, Timeout]) + end; + true -> + case is_oneway(X) of + true -> + emit(Fd, " ~s:~s(~s, {~p, ~s}).\n\n", + [?GENSERVMOD, CallOrCast, This, FunName, + mk_list(ArgNames)]); + false -> + emit(Fd, " ~s:~s(~s, {~p, ~s}, ~s).\n\n", + [?GENSERVMOD, CallOrCast, This, FunName, + mk_list(ArgNames), Timeout]) + end + end + end + end. + +emit_skel_func(G, N, X, OpName, ArgNames, TypeList, OutArgs, Oneway, Backend) -> + case ic_genobj:is_stubfile_open(G) of + false -> + ok; + true -> + emit_skel_func_helper(G, N, X, OpName, ArgNames, TypeList, OutArgs, + Oneway, Backend) + end. + +emit_skel_func_helper(G, N, X, OpName, ArgNames, _TypeList, OutArgs, Oneway, + erl_corba) -> + Fd = ic_genobj:stubfiled(G), + Name = list_to_atom(OpName), + ImplF = Name, + ImplM = list_to_atom(ic_genobj:impl(G)), + ThisStr = mk_name(G, "THIS"), + FromStr = mk_name(G, "From"), + State = mk_name(G, "State"), + Context = mk_name(G, "Context"), + + {UseFrom, From} = + case Oneway of + false -> + case use_from(G, N, OpName) of + true -> + {FromStr, FromStr}; + false -> + {"false", "_"} + end; + true -> + {"false", "_"} + end, + {UseThis, This} = + case use_this(G, N, OpName) of + true -> + {ThisStr, ThisStr}; + false -> + {"false", "_"} + end, + %% Create argument list string + CallArgs = mk_list(ArgNames), + emit_op_comment(G, Fd, X, Name, ArgNames, OutArgs), + + %% Check if pre and post conditions are specified for this operation + Precond = use_precond(G, N, X), + Postcond = use_postcond(G, N, X), + + case Oneway of + true -> + emit(Fd, "handle_cast({~s, ~s, ~p, [~s]}, ~s) ->\n", + [This, Context, Name, CallArgs, State]), + case {Precond, Postcond} of + {false, false} -> + emit(Fd, " corba:handle_cast(~p, ~p, [~s], ~s, ~s, ~s);\n\n", + [ImplM, ImplF, CallArgs, State, Context, UseThis]); + _ -> + emit(Fd, " corba:handle_cast(~p, ~p, [~s], ~s, ~s, ~s, ~p, ~p, ?MODULE);\n\n", + [ImplM, ImplF, CallArgs, State, Context, UseThis, + Precond, Precond]) + end; + false -> + emit(Fd, "handle_call({~s, ~s, ~p, [~s]}, ~s, ~s) ->\n", + [This, Context, Name, CallArgs, From, State]), + case {Precond, Postcond} of + {false, false} -> + emit(Fd, " corba:handle_call(~p, ~p, [~s], ~s, ~s, ~s, ~s);\n\n", + [ImplM, ImplF, CallArgs, State, Context, UseThis, UseFrom]); + _-> + emit(Fd, " corba:handle_call(~p, ~p, [~s], ~s, ~s, ~s, ~s, ~p, ~p, ?MODULE);\n\n", + [ImplM, ImplF, CallArgs, State, Context, UseThis, UseFrom, + Precond, Postcond]) + end + end; +emit_skel_func_helper(G, N, X, OpName, ArgNames, _TypeList, OutArgs, Oneway, + _Backend) -> + Fd = ic_genobj:stubfiled(G), + Name = list_to_atom(OpName), + ImplF = Name, + ImplM = list_to_atom(ic_genobj:impl(G)), + FromStr = mk_name(G, "From"), + State = mk_name(G, "State"), + + %% Create argument list + CallArgs1 = [State | ArgNames], + {CallArgs2, From} = + case is_oneway(X) of + false -> + case use_from(G, N, OpName) of + true -> + {[FromStr | CallArgs1], FromStr}; + false -> + {CallArgs1, "_"} + end; + true -> + {CallArgs1, "_"} + end, + %% Create argument list string + CallArgs = mk_list(CallArgs2), + emit_op_comment(G, Fd, X, Name, ArgNames, OutArgs), + FunName = case ic_options:get_opt(G, scoped_op_calls) of + true -> + list_to_atom(ic_util:to_undersc([OpName | N])); + false -> + list_to_atom(OpName) + end, + case Oneway of + true -> + if + length(ArgNames) == 0 -> + emit(Fd, "handle_cast(~p, ~s) ->\n", [FunName, State]); + true -> + emit(Fd, "handle_cast({~p, ~s}, ~s) ->\n", + [FunName, mk_list(ArgNames), State]) + end, + emit(Fd, " ~p:~p(~s);\n\n", [ImplM, ImplF, CallArgs]); + false -> + if + length(ArgNames) == 0 -> + emit(Fd, "handle_call(~p, ~s, ~s) ->\n", + [FunName, From, State]); + true -> + emit(Fd, "handle_call({~p, ~s}, ~s, ~s) ->\n", + [FunName, mk_list(ArgNames), From, State]) + end, + emit(Fd, " ~p:~p(~s);\n\n", [ImplM, ImplF, CallArgs]) + end. + +use_this(G, N, OpName) -> + FullOp = ic_util:to_colon([OpName|N]), + FullIntf = ic_util:to_colon(N), + case {get_opt(G, {this, FullIntf}), get_opt(G, {this, FullOp}), + get_opt(G, {this, true})} of + {_, force_false, _} -> false; + {force_false, false, _} -> false; + {false, false, false} -> false; + _ -> true + end. + +use_from(G, N, OpName) -> + FullOp = ic_util:to_colon([OpName|N]), + FullIntf = ic_util:to_colon(N), + case {get_opt(G, {from, FullIntf}), get_opt(G, {from, FullOp}), + get_opt(G, {from, true})} of + {_, force_false, _} -> false; + {force_false, false, _} -> false; + {false, false, false} -> false; + _ -> true + end. + + +emit_constant_func(G, Id, Val) -> + case ic_genobj:is_stubfile_open(G) of + false -> ok; + true -> + Fd = ic_genobj:stubfiled(G), + N = list_to_atom(get_id(Id)), + emit_const_comment(G, Fd, Id, N), + emit(Fd, "~p() -> ~p.\n\n", [N, Val]) + end. + + + +emit_const_comment(_G, F, _X, Name) -> + ic_codegen:mcomment_light(F, + [io_lib:format("Constant: ~p", [Name])]). + + +emit_op_comment(G, F, X, Name, InP, OutP) -> + ic_codegen:mcomment_light(F, + [io_lib:format("~s: ~p", [get_title(X), Name]), + "", + get_returns(G, X, InP, OutP) | + get_raises(X)]). + +get_title(X) when is_record(X, attr) -> "Attribute Operation"; +get_title(_X) -> "Operation". + +get_raises(X) when is_record(X, op) -> + if X#op.raises == [] -> []; + true -> + [" Raises: " ++ + mk_list(lists:map(fun(E) -> ic_util:to_colon(E) end, + X#op.raises))] + end; +get_raises(_X) -> []. + +get_returns(_G, _X, _InP, []) -> + " Returns: RetVal"; +get_returns(G, _X, _InP, OutP) -> + " Returns: "++mk_list(["RetVal" | mk_erl_vars(G, OutP)]). + + + + +%%------------------------------------------------------------ +%% +%% Utilities +%% +%% Convenient little go-get functions +%% +%%------------------------------------------------------------ + +%% The automaticly generated get and set operation names for an +%% attribute. +mk_attr_func_names(_Scope, Name) -> + {"_get_" ++ Name, "_set_" ++ Name}. +%% {scoped_name(Scope, "_get_"++Name), scoped_name(Scope, "_set_"++Name)}. + +%% Returns TK of the Get and Set attribute functions. +mk_attr_func_types(_N, X) -> + TK = ic_forms:get_tk(X), + {{TK, [], []}, {tk_void, [TK], []}}. + + + +%%------------------------------------------------------------ +%% +%% Generation utilities and common stuff +%% +%% Convenient stuff for generation +%% +%%------------------------------------------------------------ + + +%% Input is a list of parameters (in parse form) and output is a list +%% of capitalised variable names. mk_var is in icgen +mk_erl_vars(_G, Params) -> + map(fun(P) -> mk_var(get_id(P#param.id)) end, Params). + + +%% mk_list produces a nice comma separated string of variable names +mk_list([]) -> []; +mk_list([Arg | Args]) -> + Arg ++ mk_list2(Args). +mk_list2([Arg | Args]) -> + ", " ++ Arg ++ mk_list2(Args); +mk_list2([]) -> []. + + +%%------------------------------------------------------------ +%% +%% Parser utilities +%% +%% Called from the yecc parser. Expands the identifier list of an +%% attribute so that the attribute generator never has to handle +%% lists. +%% +%%------------------------------------------------------------ + + +%% Unfold identifier lists or nested lists. Note that many records +%% contain an entry named id that is a list before unfold and a single +%% id afterwards. +unfold(L) when is_list(L) -> + lists:flatten(map(fun(X) -> unfold2(X) end, L)); +unfold(X) -> unfold2(X). + +unfold2(A) when is_record(A, attr) -> + map(fun(Id) -> A#attr{id=Id} end, A#attr.id); +unfold2(M) when is_record(M, member) -> + map(fun(Id) -> M#member{id=Id} end, M#member.id); +unfold2(M) when is_record(M, case_dcl) -> + map(fun(Id) -> M#case_dcl{label=Id} end, M#case_dcl.label); +unfold2(T) when is_record(T, typedef) -> + map(fun(Id) -> T#typedef{id=Id} end, T#typedef.id). + + + + +%% Code produce for dependency function +genDependency(G) -> + Fd = ic_genobj:stubfiled(G), + nl(Fd),nl(Fd), + ic_codegen:comment(Fd, "Idl file dependency list function"), + emit(Fd, "oe_dependency() ->\n\n", []), + emit(Fd, " ~p.\n\n", [ic_pragma:get_dependencies(G)]). |