%%
%% %CopyrightBegin%
%%
%% Copyright Ericsson AB 1997-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(ictk).
%% Toplevel generation functions
-export([reg_gen/3, unreg_gen/3]).
%% Utilities
-export([get_IR_ID/3, get_IR_VSN/3, register_name/1, unregister_name/1]).
-import(ic_forms, [get_id2/1, get_body/1, get_idlist/1]).
-import(ic_util, [mk_name/2, mk_oe_name/2, to_atom/1, to_list/1]).
-import(ic_codegen, [emit/2, emit/3, nl/1]).
-include("icforms.hrl").
-include("ic.hrl").
%%--------------------------------------------------------------------
%%
%% IFR Registration Generation
%%
%%
%%--------------------------------------------------------------------
-define(IFRID(G), mk_name(G, "IFR")).
-define(VARID(G), mk_name(G, "VAR")).
-define(IFRMOD, orber_ifr).
reg_gen(G, N, X) ->
S = ic_genobj:tktab(G),
Light = ic_options:get_opt(G, light_ifr),
init_var(),
case ic_genobj:is_stubfile_open(G) of
true when Light == false ->
Var = ?IFRID(G),
Fd = ic_genobj:stubfiled(G),
nl(Fd), nl(Fd), nl(Fd),
emit(Fd, "~p() ->\n", [to_atom(register_name(G))]),
emit(Fd, " ~s = ~p:find_repository(),\n",
[Var, ?IFRMOD]),
nl(Fd),
%% Write call function that checks if included
%% modules and interfaces are created.
emit(Fd, " register_tests(~s),\n",[?IFRID(G)]),
reg2(G, S, N, Var, X),
nl(Fd),
emit(Fd, " ok.\n"),
%% Write general register test function.
register_tests(Fd,G),
%% Write functopn that registers modules only if
%% they are not registered.
register_if_unregistered(Fd);
true when Light == true ->
Fd = ic_genobj:stubfiled(G),
nl(Fd), nl(Fd), nl(Fd),
Regname = to_atom(register_name(G)),
emit(Fd, "~p() ->\n\t~p([]).\n\n", [Regname, Regname]),
emit(Fd, "~p(OE_Options) ->\n\t~p:add_items(?MODULE, OE_Options,\n\t[",
[Regname, ?IFRMOD]),
reg_light(G, N, X),
emit(Fd, "ok]),\n\tok.\n");
false ->
ok
end.
reg_light(G, N, X) when is_list(X) ->
reg_light_list(G, N, X);
reg_light(G, N, X) when is_record(X, module) ->
reg_light_list(G, [get_id2(X) | N], get_body(X));
reg_light(G, N, X) when is_record(X, struct) ->
emit(ic_genobj:stubfiled(G), "{~p, ~p, struct},\n\t",
[get_IR_ID(G, N, X), get_module(X, N)]);
reg_light(G, N, X) when is_record(X, except) ->
emit(ic_genobj:stubfiled(G), "{~p, ~p, except},\n\t",
[get_IR_ID(G, N, X), get_module(X, N)]);
reg_light(G, N, X) when is_record(X, union) ->
emit(ic_genobj:stubfiled(G), "{~p, ~p, union},\n\t",
[get_IR_ID(G, N, X), get_module(X, N)]);
reg_light(G, N, X) when is_record(X, interface) ->
emit(ic_genobj:stubfiled(G), "{~p, ~p, interface},\n\t",
[get_IR_ID(G, N, X), get_module(X, N)]),
reg_light_list(G, [get_id2(X)|N], get_body(X));
reg_light(_G, _N, _X) ->
ok.
get_module(X, N) ->
List = [get_id2(X) | N],
list_to_atom(lists:foldl(fun(E, Acc) -> E++"_"++Acc end,
hd(List), tl(List))).
%% This function filters off all "#include <FileName>.idl" code that
%% come along from preprocessor and scanner. Produces code ONLY for
%% the actuall file. See ticket OTP-2133
reg_light_list(_G, _N, []) -> [];
reg_light_list(G, N, List ) ->
CurrentFileName = ic_genobj:idlfile(G),
reg_light_list(G, N, {CurrentFileName,true}, List).
%% The filter function + loop
reg_light_list(_G, _N, {_CFN, _Status}, []) -> [];
reg_light_list(G, N, {CFN,Status}, [X | Xs]) ->
case Status of
true ->
case X of
{preproc,_,{_,_,_FileName},[{_,_,"1"}]} ->
reg_light_list(G, N, {CFN,false}, Xs);
_ ->
reg_light(G, N, X),
reg_light_list(G, N, {CFN,Status}, Xs)
end;
false ->
case X of
{preproc,_,{_,_,CFN},[{_,_,"2"}]} ->
reg_light(G, N, X),
reg_light_list(G, N, {CFN,true}, Xs);
_ ->
reg_light_list(G, N, {CFN,Status}, Xs)
end
end.
%% reg2 is top level registration
reg2(G, S, N, Var, X) ->
reg2(G, S, N, "Repository_create_", Var, X).
reg2(G, S, N, C, V, X) when is_list(X) -> reg2_list(G, S, N, C, V, X);
reg2(G, S, N, C, V, X) when is_record(X, module) ->
NewV = r_emit2(G, S, N, C, V, X, "", []),
reg2_list(G, S, [get_id2(X) | N], "ModuleDef_create_", NewV, get_body(X));
reg2(G, S, N, C, V, X) when is_record(X, const) ->
r_emit2(G, S, N, C, V, X, ", ~s, ~p",
[get_idltype(G, S, N, X), {X#const.tk, X#const.val}]);
reg2(G, S, N, C, V, X) when is_record(X, struct) ->
do_struct(G, S, N, C, V, X, ic_forms:get_tk(X));
reg2(G, S, N, C, V, X) when is_record(X, except) ->
do_except(G, S, N, C, V, X, ic_forms:get_tk(X));
reg2(G, S, N, C, V, X) when is_record(X, union) ->
do_union(G, S, N, C, V, X, ic_forms:get_tk(X));
reg2(G, S, N, C, V, X) when is_record(X, enum) ->
r_emit2(G, S, N, C, V, X, ", ~p",
[get_enum_member_list(G, S, N, get_body(X))]);
reg2(G, S, N, C, V, X) when is_record(X, typedef) ->
do_typedef(G, S, N, C, V, X),
look_for_types(G, S, N, C, V, get_body(X));
reg2(G, S, N, C, V, X) when is_record(X, attr) ->
XX = #id_of{type=X},
lists:foreach(fun(Id) -> r_emit2(G, S, N, C, V, XX#id_of{id=Id}, ", ~s, ~p",
[get_idltype(G, S, N, X), get_mode(G, N, X)])
end,
get_idlist(X));
reg2(G, S, N, C, V, X) when is_record(X, interface) ->
N2 = [get_id2(X) | N],
Body = get_body(X),
BIs = get_base_interfaces(G,X), %% produce code for the interface inheritance
NewV = r_emit2(G, S, N, C, V, X, ", " ++ BIs,[]),
reg2_list(G, S, N2, "InterfaceDef_create_", NewV, Body);
reg2(G, S, N, C, V, X) when is_record(X, op) ->
r_emit2(G, S, N, C, V, X, ", ~s, ~p, [~s], [~s], ~p",
[get_idltype(G, S, N, X), get_mode(G, N, X),
get_params(G, S, N, X#op.params), get_exceptions(G, S, N, X),
get_context(G, S, N, X)]);
reg2(_G, _S, _N, _C, _V, X) when is_record(X, preproc) -> ok;
reg2(_G, _S, _N, _C, _V, X) when is_record(X, pragma) -> ok;
reg2(_G, _S, _N, _C, _V, _X) -> ok.
%% This function filters off all "#include <FileName>.idl" code that
%% come along from preprocessor and scanner. Produces code ONLY for
%% the actuall file. See ticket OTP-2133
reg2_list(_G, _S, _N, _C, _V, []) -> [];
reg2_list(G, S, N, C, V, List ) ->
CurrentFileName = ic_genobj:idlfile(G),
reg2_list(G, S, N, C, V, {CurrentFileName,true}, List).
%% The filter function + loop
reg2_list(_G, _S, _N, _C, _V, {_CFN, _Status}, []) -> [];
reg2_list(G, S, N, C, V, {CFN,Status}, [X | Xs]) ->
case Status of
true ->
case X of
{preproc,_,{_,_,_FileName},[{_,_,"1"}]} ->
reg2_list(G, S, N, C, V, {CFN,false}, Xs);
_ ->
F = reg2(G, S, N, C, V, X),
[F | reg2_list(G, S, N, C, V, {CFN,Status}, Xs)]
end;
false ->
case X of
{preproc,_,{_,_,CFN},[{_,_,"2"}]} ->
F = reg2(G, S, N, C, V, X),
[F | reg2_list(G, S, N, C, V, {CFN,true}, Xs)];
_ ->
reg2_list(G, S, N, C, V, {CFN,Status}, Xs)
end
end.
%% General registration tests
register_tests(Fd,G) ->
IfrId = ?IFRID(G),
emit(Fd,"\n\n%% General IFR registration checks.\n", []),
emit(Fd,"register_tests(~s)->\n",[IfrId]),
emit(Fd," re_register_test(~s),\n",[IfrId]),
emit(Fd," include_reg_test(~s).\n\n",[IfrId]),
emit(Fd,"\n%% IFR type Re-registration checks.\n", []),
case ic_pragma:fetchRandomLocalType(G) of
{ok,TypeId} ->
emit(Fd,"re_register_test(~s)->\n",[IfrId]),
emit(Fd," case orber_ifr:'Repository_lookup_id'(~s,~p) of\n", [IfrId,TypeId]),
emit(Fd," [] ->\n true;\n",[]),
emit(Fd," _ ->\n exit({allready_registered,~p})\n end.\n\n", [TypeId]);
false ->
emit(Fd,"re_register_test(_)-> true.\n",[])
end,
emit(Fd,"~s",[check_include_regs(G)]).
%% This function produces code for existance check over
%% top level included modules and interfaces
check_include_regs(G) ->
IfrId = ?IFRID(G),
case ic_pragma:get_incl_refs(G) of
none ->
io_lib:format("\n%% No included idl-files detected.\n", []) ++
io_lib:format("include_reg_test(_~s) -> true.\n",[IfrId]);
IMs ->
io_lib:format("\n%% IFR registration checks for included idl files.\n", []) ++
io_lib:format("include_reg_test(~s) ->\n",[IfrId]) ++
check_incl_refs(G,IfrId,IMs)
end.
check_incl_refs(_,_,[]) ->
io_lib:format(" true.\n",[]);
check_incl_refs(G,IfrId,[[First]|Rest]) ->
ModId = ic_pragma:scope2id(G,First),
io_lib:format(" case orber_ifr:'Repository_lookup_id'(~s,~p) of~n", [IfrId,ModId]) ++
io_lib:format(" [] ->~n exit({unregistered,~p});~n", [ModId]) ++
io_lib:format(" _ ->~n true~n end,~n",[]) ++
check_incl_refs(G,IfrId,Rest).
%% This function will return module ref, it will
%% also register module if not registered.
register_if_unregistered(Fd) ->
emit(Fd, "\n\n%% Fetch top module reference, register if unregistered.\n"),
emit(Fd, "oe_get_top_module(OE_IFR, ID, Name, Version) ->\n"),
emit(Fd, " case orber_ifr:'Repository_lookup_id'(OE_IFR, ID) of\n"),
emit(Fd, " [] ->\n"),
emit(Fd, " orber_ifr:'Repository_create_module'(OE_IFR, ID, Name, Version);\n"),
emit(Fd, " Mod ->\n"),
emit(Fd, " Mod\n",[]),
emit(Fd, " end.\n\n"),
emit(Fd, "%% Fetch module reference, register if unregistered.\n"),
emit(Fd, "oe_get_module(OE_IFR, OE_Parent, ID, Name, Version) ->\n"),
emit(Fd, " case orber_ifr:'Repository_lookup_id'(OE_IFR, ID) of\n"),
emit(Fd, " [] ->\n"),
emit(Fd, " orber_ifr:'ModuleDef_create_module'(OE_Parent, ID, Name, Version);\n"),
emit(Fd, " Mod ->\n"),
emit(Fd, " Mod\n",[]),
emit(Fd, " end.\n").
do_typedef(G, S, N, C, V, X) ->
case ic_genobj:is_stubfile_open(G) of
false -> ok;
true ->
Fd = ic_genobj:stubfiled(G),
Thing = get_thing_name(X),
IR_VSN = get_IR_VSN(G, N, X),
TK = ic_forms:get_tk(X),
lists:foreach(
fun(Id) ->
r_emit_raw(G, X, Fd, "", C, Thing, V,
get_IR_ID(G, N, Id), get_id2(Id),
IR_VSN, ", ~s",
[get_idltype_tk(G, S, N,
ictype:maybe_array(G, S, N,
Id, TK))])
end, get_idlist(X))
end.
do_union(G, S, N, C, V, X, {tk_union, _IFRID, _Name, DiscrTK, _DefNr, L}) ->
N2 = [get_id2(X) | N],
r_emit2(G, S, N, C, V, X, ", ~s, [~s]",
[get_idltype_tk(G, S, N, DiscrTK),
get_union_member_def(G, S, N2, L)]),
look_for_types(G, S, N2, C, V, get_body(X)).
do_struct(G, S, N, C, V, X, {tk_struct, _IFRID, _Name, ElemList}) ->
N2 = [get_id2(X) | N],
r_emit2(G, S, N, C, V, X, ", [~s]",
[get_member_def(G, S, N, ElemList)]),
look_for_types(G, S, N2, C, V, get_body(X)).
do_except(G, S, N, C, V, X, {tk_except, _IFRID, _Name, ElemList}) ->
N2 = [get_id2(X) | N],
r_emit2(G, S, N, C, V, X, ", [~s]",
[get_member_def(G, S, N, ElemList)]),
look_for_types(G, S, N2, C, V, get_body(X)).
%% new_var finds an unused Erlang variable name by increasing a
%% counter.
new_var(_G) ->
lists:flatten(["_OE_", integer_to_list(put(var_count, get(var_count) + 1))]).
init_var() ->
put(var_count, 1).
%% Public interface. The name of the register function.
register_name(G) ->
mk_oe_name(G, "register").
unregister_name(G) ->
mk_oe_name(G, "unregister").
look_for_types(G, S, N, C, V, L) when is_list(L) ->
lists:foreach(fun(X) -> look_for_types(G, S, N, C, V, X) end, L);
look_for_types(G, S, N, C, V, {_Name, TK}) -> % member
look_for_types(G, S, N, C, V, TK);
look_for_types(_G, _S, _N, _C, _V, {tk_union, _IFRID, _Name, _DT, _Def, _L}) ->
ok;
look_for_types(G, S, N, C, V, {_Label, _Name, TK}) -> % case_dcl
look_for_types(G, S, N, C, V, TK);
look_for_types(_G, _S, _N, _C, _V, {tk_struct, _IFRID, _Name, _L}) ->
ok;
look_for_types(_G, _S, _N, _C, _V, _X) ->
ok.
%% This function produces code for the interface inheritance registration.
%% It produces a string that represents a list of function calls.
%% This list becomes a list of object references when the main function
%% "orber_ifr:ModuleDef_create_interface" is called.
get_base_interfaces(G,X) ->
case element(3,X) of
[] ->
"[]";
L ->
"[" ++
lists:flatten(
lists:foldl(
fun(E, Acc) -> [call_fun_str(G,E), ", " | Acc] end,
call_fun_str(G,hd(L)),
tl(L)
)
) ++ "]"
end.
call_fun_str(G,S) ->
lists:flatten(
io_lib:format("orber_ifr:lookup_id(~s,\"~s\")",
[ ?IFRID(G),
ic_pragma:scope2id(G,S)] )).
%%--------------------------------------------------------------------
%%
%% r_emit emits an IFR register function call. It returns a new
%% variable (if further defs should be added to that one)
%%
%% G is genobj
%%
%% S is symbol table (ets)
%%
%% N is list of ids describing scope
%%
%% C is create stub (eg. "Repository_create_")
%%
%% V is variable name where current def should be added,
%%
%% X is the current def item,
%%
%% F and A is auxillary format and args that will be io_lib
%% formatted and inserted as a string (don't forget to start with
%% ", ")
%%
r_emit2(G, _S, N, C, V, X, F, A) ->
case ic_genobj:is_stubfile_open(G) of
false -> ok;
true ->
{NewV, Str} = get_assign(G, V, X),
r_emit_raw(G, X, ic_genobj:stubfiled(G), Str,
C, get_thing_name(X), V,
get_IR_ID(G, N, X), get_id2(X), get_IR_VSN(G, N, X),
F, A),
NewV
end.
%%--------------------------------------------------------------------
%%
%% An IFR register line registers an entity (Thing) into the IFR. The
%% thing is registered INTO something, an type is registered into a
%% module for instance, and this is reflected in the Var parameter
%% below. The var parameter is the name of the parent IFR object. The
%% Thing parameter is the name of the thing we're trying to register,
%% a typdef is called an alias and an interface is called an
%% interface. Sometimes we need to store the thing we're registering
%% into a variable because we're going to add other things to it
%% later, modules and interfaces are such containers, so we must
%% remember that variable for later use.
%%
%% All parameters shall be strings unless otherwise noted
%%
%% Fd - File descriptor
%% AssignStr - Assign or not, empty except for interfaces and modules
%% Create - Create has diff. names dep. on into what we register
%% Thing - WHAT is registered, interface
%% Var - The name of the variable we register into
%% IR_ID - The IFR identifier (may be "")
%% Id - The identifier (name) of the object
%% IR_VSN - The IFR version as a string
%% AuxStr - An auxillary string
%%
%%r_emit_raw(Fd, AssignStr, Create, Thing, Var, IR_ID, Id, IR_VSN) ->
%% r_emit_raw(Fd, AssignStr, Create, Thing, Var, IR_ID, Id, IR_VSN, "", []).
r_emit_raw(_G, X, Fd, AssignStr, "Repository_create_", Thing, Var, IR_ID, Id, IR_VSN, F, A)
when is_record(X, module) ->
emit(Fd, "~n ~s~p(~s, \"~s\", \"~s\", \"~s\"~s),~n",
[AssignStr, to_atom("oe_get_top_"++Thing), Var, IR_ID, Id,
IR_VSN, io_lib:format(F, A)]);
r_emit_raw(G, X, Fd, AssignStr, "ModuleDef_create_", Thing, Var, IR_ID, Id, IR_VSN, F, A)
when is_record(X, module) ->
emit(Fd, "~n ~s~p(~s, ~s, \"~s\", \"~s\", \"~s\"~s),~n",
[AssignStr, to_atom("oe_get_"++Thing), ?IFRID(G), Var, IR_ID, Id,
IR_VSN, io_lib:format(F, A)]);
r_emit_raw(_G, _X, Fd, AssignStr, Create, Thing, Var, IR_ID, Id, IR_VSN, F, A) ->
emit(Fd, "~n ~s~p:~p(~s, \"~s\", \"~s\", \"~s\"~s),~n",
[AssignStr, ?IFRMOD, to_atom(Create++Thing), Var, IR_ID, Id,
IR_VSN, io_lib:format(F, A)]).
%% Used by r_emit. Returns tuple {Var, Str} where Var is the resulting
%% output var (if any, otherwise same as input arg) and Str is a
%% string of the assignment if any ("" or "Var = ")
get_assign(G, _V, X) when is_record(X, module) ->
mk_assign(G);
get_assign(G, _V, X) when is_record(X, interface) ->
mk_assign(G);
get_assign(_G, V, _X) -> {V, ""}.
mk_assign(G) ->
V = new_var(G),
{V, io_lib:format("~s = ", [V])}.
%% Returns a list of strings of all enum members (suitable for ~p)
get_enum_member_list(_G, _S, _N, L) ->
lists:map(fun(M) -> get_id2(M) end, L).
%% Will output a string of the union members.
get_union_member_def(_G, _S, _N, []) -> [];
get_union_member_def(G, S, N, L) ->
[union_member2str(G, S, N, hd(L)) |
lists:map(fun(M) -> [", ", union_member2str(G, S, N, M)] end, tl(L))].
%% lists:foldl(fun(M, Acc) ->
%% [union_member2str(G, S, N, M),", " | Acc] end,
%% union_member2str(G, S, N, hd(L)), tl(L)).
union_member2str(G, S, N, {Label, Name, TK}) ->
io_lib:format("~s{name=~p, label=~p, type=~p, type_def=~s}",
["#unionmember", Name, Label, TK,
get_idltype_tk(G, S, N, TK)]).
%% Will output a string of the struct members. Works for exceptions
%% and structs
%%
get_member_def(_G, _S, _N, []) -> [];
get_member_def(G, S, N, L) ->
[member2str(G, S, N, hd(L)) |
lists:map(fun(M) -> [", ", member2str(G, S, N, M)] end, tl(L))].
member2str(G, S, N, {Id, TK}) ->
io_lib:format("~s{name=~p, type=~p, type_def=~s}",
["#structmember", Id, TK, get_idltype_tk(G, S, N, TK)]).
%% Translates between record names and create operation names.
get_thing_name(X) when is_record(X, op) -> "operation";
get_thing_name(X) when is_record(X, const) -> "constant";
get_thing_name(X) when is_record(X, typedef) -> "alias";
get_thing_name(X) when is_record(X, attr) -> "attribute";
get_thing_name(X) when is_record(X, except) -> "exception";
get_thing_name(X) when is_record(X, id_of) -> get_thing_name(X#id_of.type);
get_thing_name(X) -> to_list(element(1,X)).
%% Returns the mode (in, out, oneway etc) of ops and params. Return
%% value is an atom.
get_mode(_G, _N, X) when is_record(X, op) ->
case X#op.oneway of
{oneway, _} -> 'OP_ONEWAY';
_ -> 'OP_NORMAL'
end;
get_mode(_G, _N, X) when is_record(X, attr) ->
case X#attr.readonly of
{readonly, _} -> 'ATTR_READONLY';
_ -> 'ATTR_NORMAL'
end;
get_mode(_G, _N, X) when is_record(X, param) ->
case X#param.inout of
{in, _} -> 'PARAM_IN';
{inout, _} -> 'PARAM_INOUT';
{out, _} -> 'PARAM_OUT'
end.
%% Returns a string form of idltype creation.
%%get_idltype_id(G, S, N, X, Id) ->
%% TK = ictype:tk_lookup(G, S, N, Id),
%% get_idltype_tk(G, S, N, TK).
get_idltype(G, S, N, X) ->
get_idltype_tk(G, S, N, ic_forms:get_tk(X)).
get_idltype_tk(G, _S, _N, TK) ->
io_lib:format("~p:~p(~s, ~p)", [orber_ifr, 'Repository_create_idltype',
?IFRID(G), TK]).
%% Returns a string form of typecode creation. This shall be found in
%% the type code symbol table.
%%get_typecode(G, S, N, X) -> typecode.
%%get_typecode(G, S, N, X) -> tk(G, S, N, get_type(X)).
%% Returns the string form of a list of parameters.
get_params(_G, _S, _N, []) -> "";
get_params(G, S, N, L) ->
lists:foldl(fun(X, Acc) -> param2str(G, S, N, X)++", "++Acc end,
param2str(G, S, N, hd(L)), tl(L)).
%% Converts a parameter to a string.
param2str(G, S, N, X) ->
io_lib:format("~s{name=~p, type=~p, type_def=~s, mode=~p}~n",
["#parameterdescription", get_id2(X),
ic_forms:get_tk(X),
%%tk_lookup(G, S, N, get_type(X)),
get_idltype(G, S, N, X),
get_mode(G, N, X)]).
%% Public interface. Returns the IFR ID of an object. This
%% is updated to comply with CORBA 2.0 pragma directives.
get_IR_ID(G, N, X) ->
ScopedId = [get_id2(X) | N],
case ic_pragma:get_alias(G,ScopedId) of
none ->
case ic_pragma:pragma_id(G, N, X) of
none ->
case ic_pragma:pragma_prefix(G, N, X) of
none ->
IR_ID = lists:flatten(
io_lib:format("IDL:~s:~s",
[slashify(ScopedId),
get_IR_VSN(G, N, X)])),
ic_pragma:mk_alias(G,IR_ID,ScopedId),
IR_ID;
PF ->
IR_ID = lists:flatten(
io_lib:format("IDL:~s:~s",
[ PF ++ "/" ++
get_id2(X),
get_IR_VSN(G, N, X)])),
ic_pragma:mk_alias(G,IR_ID,ScopedId),
IR_ID
end;
PI ->
ic_pragma:mk_alias(G,PI,ScopedId),
PI
end;
Alias ->
Alias
end.
%% Public interface. Returns the IFR Version of an object. This
%% is updated to comply with CORBA 2.0 pragma directives.
get_IR_VSN(G, N, X) ->
ic_pragma:pragma_version(G,N,X).
%% Returns a slashified name, [I1, M1] becomes "M1/I1"
%slashify(List) -> lists:foldl(fun(X, Acc) -> get_id2(X)++"/"++Acc end,
% hd(List), tl(List)).
%% Returns a slashified name, [I1, M1] becomes "M1/I1"
slashify(List) -> lists:foldl(fun(X, Acc) -> X++"/"++Acc end,
hd(List), tl(List)).
%% Returns the context literals of an op
get_context(_G, _S, _N, X) ->
lists:map(fun(C) -> element(3, C) end, X#op.ctx).
%% Returns the list of the exceptions of an operation
get_exceptions(G, S, N, X) ->
case X#op.raises of
[] ->
"";
L ->
lists:flatten(
lists:foldl(
fun(E, Acc) -> [excdef(G, S, N, X, E), ", " | Acc] end,
excdef(G, S, N, X, hd(L)),
tl(L)
)
)
end.
%% Returns the definition of an exception of an operation
excdef(G, S, N, X, L) ->
io_lib:format("orber_ifr:lookup_id(~s,\"~s\")",
[ ?IFRID(G),
get_EXC_ID(G, S, N, X, L) ] ).
%% This function produces code for the exception registration.
%% It produces a string that represents a list of function calls.
%% This list becomes a list of object references when the main function
%% "orber_ifr:InterfaceDef_create_operation" is called.
get_EXC_ID(G, _S, N, X, ScopedId) ->
case ic_pragma:get_alias(G,ScopedId) of
none ->
case ic_pragma:pragma_id(G, N, X) of
none ->
case ic_pragma:pragma_prefix(G, N, X) of
none ->
EXC_ID = lists:flatten(
io_lib:format("IDL:~s:~s", [slashify(ScopedId),
get_IR_VSN(G, N, X)])),
ic_pragma:mk_alias(G,EXC_ID,ScopedId),
EXC_ID;
PF ->
EXC_ID = lists:flatten(
io_lib:format("IDL:~s:~s", [ PF ++ "/" ++
hd(ScopedId),
get_IR_VSN(G, N, X)])),
ic_pragma:mk_alias(G,EXC_ID,ScopedId),
EXC_ID
end;
PI ->
ic_pragma:mk_alias(G,PI,ScopedId),
PI
end;
Alias ->
Alias
end.
%% unreg_gen/1 uses the information stored in pragma table
%% to decide which modules are to be unregistered
unreg_gen(G, N, X) ->
Light = ic_options:get_opt(G, light_ifr),
case ic_genobj:is_stubfile_open(G) of
true when Light == false ->
Var = ?IFRID(G),
Fd = ic_genobj:stubfiled(G),
nl(Fd), nl(Fd), nl(Fd),
emit(Fd, "~p() ->\n", [to_atom(unregister_name(G))]),
emit(Fd, " ~s = ~p:find_repository(),\n",
[Var, ?IFRMOD]),
nl(Fd),
unreg2(G, N, X),
emit(Fd, " ok.\n\n"),
destroy(Fd);
true ->
Fd = ic_genobj:stubfiled(G),
nl(Fd), nl(Fd),
Unregname = to_atom(unregister_name(G)),
emit(Fd, "~p() ->\n\t~p([]).\n\n~p(OE_Options) ->\n",
[Unregname, Unregname, Unregname]),
emit(Fd, "\t~p:remove(?MODULE, OE_Options),\n\tok.\n\n", [?IFRMOD]);
false -> ok
end.
destroy(Fd) ->
emit(Fd,"
oe_destroy_if_empty(OE_IFR,IFR_ID) ->
case orber_ifr:'Repository_lookup_id'(OE_IFR, IFR_ID) of
[] ->
ok;
Ref ->
case orber_ifr:contents(Ref, \'dk_All\', \'true\') of
[] ->
orber_ifr:destroy(Ref),
ok;
_ ->
ok
end
end.
oe_destroy(OE_IFR,IFR_ID) ->
case orber_ifr:'Repository_lookup_id'(OE_IFR, IFR_ID) of
[] ->
ok;
Ref ->
orber_ifr:destroy(Ref),
ok
end.
",[]).
%% unreg2 is top level registration
unreg2(G, N, X) ->
emit(ic_genobj:stubfiled(G),"~s",[lists:flatten(unreg3(G, N, X))]).
unreg3(G, N, X) when is_list(X) ->
unreg3_list(G, N, X, []);
unreg3(G, N, X) when is_record(X, module) ->
unreg3_list(G, [get_id2(X) | N], get_body(X), [unreg_collect(G, N, X)]);
unreg3(G, N, X) when is_record(X, const) ->
unreg_collect(G, N, X);
unreg3(G, N, X) when is_record(X, struct) ->
unreg_collect(G, N, X);
unreg3(G, N, X) when is_record(X, except) ->
unreg_collect(G, N, X);
unreg3(G, N, X) when is_record(X, union) ->
unreg_collect(G, N, X);
unreg3(G, N, X) when is_record(X, enum) ->
unreg_collect(G, N, X);
unreg3(G, N, X) when is_record(X, typedef) ->
unreg_collect(G, N, X);
unreg3(G, N, X) when is_record(X, interface) ->
unreg_collect(G, N, X);
unreg3(_G, _N, X) when is_record(X, op) -> [];
unreg3(_G, _N, X) when is_record(X, attr) -> [];
unreg3(_G, _N, X) when is_record(X, preproc) -> [];
unreg3(_G, _N, X) when is_record(X, pragma) -> [];
unreg3(_G, _N, _X) -> [].
unreg3_list(_G, _N, [], Found) ->
Found;
unreg3_list(G, N, List, Found) ->
CurrentFileName = ic_genobj:idlfile(G),
unreg3_list(G, N, {CurrentFileName,true}, List, Found).
%% The filter function + loop
unreg3_list(_G, _N, {_CFN, _Status}, [], Found) ->
Found;
unreg3_list(G, N, {CFN,Status}, [X | Xs], Found) ->
case Status of
true ->
case X of
{preproc,_,{_,_,_FileName},[{_,_,"1"}]} ->
unreg3_list(G, N, {CFN,false}, Xs, Found);
_ ->
unreg3_list(G, N, {CFN,Status}, Xs, [unreg3(G, N, X) | Found])
end;
false ->
case X of
{preproc,_,{_,_,CFN},[{_,_,"2"}]} ->
unreg3_list(G, N, {CFN,true}, Xs,[unreg3(G, N, X) | Found]);
_ ->
unreg3_list(G, N, {CFN,Status}, Xs, Found)
end
end.
unreg_collect(G, N, X) when is_record(X, module) ->
io_lib:format(" oe_destroy_if_empty(OE_IFR, ~p),\n",
[get_IR_ID(G, N, X)]);
unreg_collect(G, N, X) when is_record(X, typedef) ->
lists:map(fun(Id) ->
io_lib:format(" oe_destroy(OE_IFR, ~p),\n",
[get_IR_ID(G, N, Id)])
end,
ic_forms:get_idlist(X));
unreg_collect(G, N, X) ->
io_lib:format(" oe_destroy(OE_IFR, ~p),\n",
[get_IR_ID(G, N, X)]).
