ictk.erl

来自「OTP是开放电信平台的简称」· ERL 代码 · 共 872 行 · 第 1/2 页

%% ``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 via the world wide web 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.
%% 
%% The Initial Developer of the Original Code is Ericsson Utvecklings AB.
%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings
%% AB. All Rights Reserved.''
%% 
%%     $Id$
%%
-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 list(X) -> 
    reg_light_list(G, N, X);
reg_light(G, N, X) when record(X, module) ->
    reg_light_list(G, [get_id2(X) | N], get_body(X));
reg_light(G, N, X) when 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 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 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 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 list(X) -> reg2_list(G, S, N, C, V, X);

reg2(G, S, N, C, V, X) when 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 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 record(X, struct) ->
    do_struct(G, S, N, C, V, X, ic_forms:get_tk(X));

reg2(G, S, N, C, V, X) when record(X, except) ->
    do_except(G, S, N, C, V, X, ic_forms:get_tk(X));

reg2(G, S, N, C, V, X) when record(X, union) ->
    do_union(G, S, N, C, V, X, ic_forms:get_tk(X));

reg2(G, S, N, C, V, X) when 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 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 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 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 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 record(X, preproc) -> ok;

reg2(_G, _S, _N, _C, _V, X)  when 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 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 ->