diff options
Diffstat (limited to 'lib/ic/src/ictk.erl')
| -rw-r--r-- | lib/ic/src/ictk.erl | 873 |
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)]). + + + |