diff options
Diffstat (limited to 'lib/ic/src/ictk.erl')
| -rw-r--r-- | lib/ic/src/ictk.erl | 874 |
1 files changed, 0 insertions, 874 deletions
diff --git a/lib/ic/src/ictk.erl b/lib/ic/src/ictk.erl deleted file mode 100644 index 701d662776..0000000000 --- a/lib/ic/src/ictk.erl +++ /dev/null @@ -1,874 +0,0 @@ -%% -%% %CopyrightBegin% -%% -%% Copyright Ericsson AB 1997-2016. All Rights Reserved. -%% -%% Licensed under the Apache License, Version 2.0 (the "License"); -%% you may not use this file except in compliance with the License. -%% You may obtain a copy of the License at -%% -%% http://www.apache.org/licenses/LICENSE-2.0 -%% -%% Unless required by applicable law or agreed to in writing, software -%% distributed under the License is distributed on an "AS IS" BASIS, -%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -%% See the License for the specific language governing permissions 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)]). - - - |