aboutsummaryrefslogtreecommitdiffstats
path: root/lib/ic/src/ictk.erl
diff options
context:
space:
mode:
authorErlang/OTP <[email protected]>2009-11-20 14:54:40 +0000
committerErlang/OTP <[email protected]>2009-11-20 14:54:40 +0000
commit84adefa331c4159d432d22840663c38f155cd4c1 (patch)
treebff9a9c66adda4df2106dfd0e5c053ab182a12bd /lib/ic/src/ictk.erl
downloadotp-84adefa331c4159d432d22840663c38f155cd4c1.tar.gz
otp-84adefa331c4159d432d22840663c38f155cd4c1.tar.bz2
otp-84adefa331c4159d432d22840663c38f155cd4c1.zip
The R13B03 release.OTP_R13B03
Diffstat (limited to 'lib/ic/src/ictk.erl')
-rw-r--r--lib/ic/src/ictk.erl873
1 files changed, 873 insertions, 0 deletions
diff --git a/lib/ic/src/ictk.erl b/lib/ic/src/ictk.erl
new file mode 100644
index 0000000000..63a7705699
--- /dev/null
+++ b/lib/ic/src/ictk.erl
@@ -0,0 +1,873 @@
+%%
+%% %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)]).
+
+
+