ictype.erl

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

check_switch_tk(_G, _S, _N, _X, tk_longlong) -> true; %% LLONG
check_switch_tk(_G, _S, _N, _X, tk_short) -> true;
check_switch_tk(_G, _S, _N, _X, tk_ushort) -> true;
check_switch_tk(_G, _S, _N, _X, tk_ulong) -> true;
check_switch_tk(_G, _S, _N, _X, tk_ulonglong) -> true;  %% ULLONG
check_switch_tk(_G, _S, _N, _X, tk_boolean) -> true;
check_switch_tk(_G, _S, _N, _X, tk_char) -> true;
check_switch_tk(_G, _S, _N, _X, tk_wchar) -> true;  %% WCHAR
check_switch_tk(_G, _S, _N, _X, TK) when element(1, TK) == tk_enum -> true;
check_switch_tk(G, _S, _N, X, TK) -> ic_error:error(G, {illegal_switch_t, X, TK}),
				     false.



%% Lookup a name
name_lookup(G, S, N, X) ->
    case scoped_lookup(G, S, N, X) of
	T when tuple(T) -> element(1, T)
    end.


lookup(G, S, N, X, Id) ->
    N2 = Id ++ N,
    ?DBG("  Trying ~p ...~n", [N2]),
    case ets:lookup(S, N2) of
	[] ->	    
	    case look_for_interface(G, S, [hd(N2)], tl(N2)) of

		%% First attempt: filtering inherited members !
		[{_, member, _, _}] ->	    
		    case look_for_interface(G, S, [hd(N)], tl(N2)) of
			[T] -> 
			    ?DBG("    --  found ~p~n", [T]), 
			    T;
			_ ->
			    lookup(G, S, tl(N), X, Id)
		    end;
		%%

		[T] -> 
		    ?DBG("    --  found ~p~n", [T]), 
		    T;

		_ ->
		    if  N == [] -> 
			    ic_error:error(G, {tk_not_found, X});
			true ->
			    lookup(G, S, tl(N), X, Id)
		    end

	    end;

	%% Second attempt: filtering members !
	[{_, member, _, _}] ->	    
	    case look_for_interface(G, S, [hd(N2)], tl(N2)) of
		[T] -> 
		    ?DBG("    --  found ~p~n", [T]), 
		    T;
		_ ->
		    if  N == [] -> 
			    ic_error:error(G, {tk_not_found, X});
			true ->
			    lookup(G, S, tl(N), X, Id)
		    end
	    end;
	%%
	[T] -> 
	    ?DBG("    --  found ~p~n", [T]),
	    T
    end.


look_for_interface(_G, _S, _Hd, []) -> 
    false;
look_for_interface(G, S, Hd, Tl) ->
    case ets:lookup(S, Tl) of
	[{_, interface, _TK, Inh}] -> 
	    case look_in_inherit(G, S, Hd, Inh) of
		%% gather_inherit(G, S, Inh, [])) of
		[X] when tuple(X) -> 
		    [X];
		_ -> 
		    look_for_interface(G, S, Hd ++ [hd(Tl)], tl(Tl))
	    end;
	_ -> 
	    look_for_interface(G, S, Hd ++ [hd(Tl)], tl(Tl))
    end.

look_in_inherit(G, S, Id, [I | Is]) ->
    case ets:lookup(S, Id ++ I) of
	[X] when tuple(X) -> 
	    [X];
	[] ->  
	    look_in_inherit(G, S, Id, Is)
    end;
look_in_inherit(_G, _S, _Id, []) -> 
    false.


%% L is a list of names
mk_uppercase(L) ->
    lists:map(fun(Z) -> lists:map(fun(X) when X>=$a, X=<$z -> X-$a+$A;
				     (X) -> X end, Z) end, L).


%%--------------------------------------------------------------------
%%
%% Inheritance stuff
%%
%%
%%--------------------------------------------------------------------

%% InhBody is an accumulating parameter

calc_inherit_body(G, N, OrigBody, [X|Xs], InhBody) ->
    case ic_symtab:retrieve(G, X) of
	Intf when record(Intf, interface) ->
	    Body = filter_body(G, X, ic_forms:get_body(Intf), N, OrigBody, InhBody),
	    calc_inherit_body(G, N, OrigBody, Xs, [{X, Body} | InhBody]);
	XXX ->
	    io:format("Oops, not found ~p~n", [XXX]),
	    calc_inherit_body(G, N, OrigBody, Xs, InhBody)
    end;
calc_inherit_body(_G, _N, _OrigBody, [], InhBody) -> lists:reverse(InhBody).


filter_body(G, XPath, [X | Xs], OrigPath, OrigBody, InhBody) ->
    case complex_body_member(G, XPath, X, OrigPath, OrigBody, InhBody) of
	true -> 
	    %%io:format("NOT adding ~p~n", [ic_forms:get_id2(X)]),
	    filter_body(G, XPath, Xs, OrigPath, OrigBody, InhBody);
	{false, NewX} ->			% For those with idlist
	    %%io:format("Adding from idlist~n", []),
	    [NewX | filter_body(G, XPath, Xs, OrigPath, OrigBody, InhBody)];
	false ->
	    %%io:format("Adding: ~p~n", [ic_forms:get_id2(X)]),
	    [X | filter_body(G, XPath, Xs, OrigPath, OrigBody, InhBody)]
    end;
filter_body(_G, _XPath, [], _OrigPath, _OrigBody, _InhBody) -> [].


complex_body_member(G, XPath, X, OrigPath, OrigBody, InhBody) ->
    case has_idlist(X) of
	true ->
	    idlist_member(G, XPath, X, OrigPath, OrigBody, InhBody);
	false ->
	    straight_member(G, XPath, X, OrigPath, OrigBody, InhBody)
    end.


idlist_member(G, XPath, X, OrigPath, OrigBody, InhBody) ->    
    XX = #id_of{type=X},
    F = fun(Id) ->
		not(straight_member(G, XPath, XX#id_of{id=Id}, OrigPath,
				    OrigBody, InhBody))
	end,
    case lists:filter(F, ic_forms:get_idlist(X)) of
	[] -> 
	    true;
	IdList ->
%%%	    io:format("Idlist added: ~p~n",[IdList]),
	    {false, replace_idlist(X, IdList)}
    end.


straight_member(G, XPath, X, OrigPath, OrigBody, InhBody) ->
    %%io:format("straight member: ~p~n", [ic_forms:get_id2(X)]),
    case body_member(G, XPath, X, OrigPath, OrigBody) of
	true ->
	    true;
	false -> 
	    inh_body_member(G, XPath, X, InhBody)
    end.


inh_body_member(G, XPath, X, [{Name, Body} | InhBody]) ->
    case body_member(G, XPath, X, Name, Body) of
	true ->
	    true;
	false -> 
	    inh_body_member(G, XPath, X, InhBody)
    end;
inh_body_member(_G, _XPath, _X, []) -> false.


body_member(G, XPath, X, YPath, [Y|Ys]) ->
    case has_idlist(Y) of
	true -> 
	    YY = #id_of{type=Y},
	    case list_and(fun(Y2) -> 
				  not(is_equal(G, XPath, X, YPath, 
					       YY#id_of{id=Y2})) end,
			  ic_forms:get_idlist(Y)) of
		true -> 
		    body_member(G, XPath, X, YPath, Ys);
		false ->
		    true
	    end;
	false ->
	    case is_equal(G, XPath, X, YPath, Y) of
		false ->
		    body_member(G, XPath, X, YPath, Ys);
		true ->
		    true
	    end
    end;
body_member(_G, _XPath, _X, _YPath, []) -> false.


is_equal(G, XPath, X, YPath, Y) ->
    case {ic_forms:get_id2(X), ic_forms:get_id2(Y)} of
	{ID, ID} ->
	    collision(G, XPath, X, YPath, Y),
	    true;
	_ -> 
	    false
    end.


%% X is the new item, Y is the old one. So it is X that collides with
%% Y and Y shadows X.
collision(G, XPath, X, YPath, Y) ->
    I1 = get_beef(X),
						%    I2 = get_beef(Y),
    if record(I1, op) -> %%, record(I2, op) ->
	    ic_error:error(G, {inherit_name_collision, 
			       {YPath, Y}, {XPath, X}});
       record(I1, attr) -> %%, record(I2, attr) ->
	    ic_error:error(G, {inherit_name_collision, 
			       {YPath, Y}, {XPath, X}});
       true ->
	    ?ifopt(G, warn_name_shadow, 
		   ic_error:warn(G, {inherit_name_shadow, 
				     {YPath, Y}, {XPath, X}}))
    end.

has_idlist(X) when record(X, typedef) -> true;
has_idlist(X) when record(X, member) -> true;
has_idlist(X) when record(X, case_dcl) -> true;
has_idlist(X) when record(X, attr) -> true;
has_idlist(_) -> false.

replace_idlist(X, IdList) when record(X, typedef) -> X#typedef{id=IdList};
replace_idlist(X, IdList) when record(X, attr) -> X#attr{id=IdList}.

get_beef(X) when record(X, id_of) -> X#id_of.type;
get_beef(X) -> X.


%% And among all elements in list
list_and(F, [X|Xs]) ->
    case F(X) of
	true -> list_and(F, Xs);
	false -> false
    end;
list_and(_F, []) -> true.





%%--------------------------------------------------------------------
%%
%%	resolve_inherit shall return a list of resolved inheritances,
%%	that is all names replaced with their global names.
%%

inherit_resolve(G, S, N, [X|Rest], Out) ->
    case scoped_lookup(G, S, N, X) of
	{Name, _T, _TK, Inh} ->
	    case lists:member(Name, Out) of
		true -> 
		    inherit_resolve(G, S, N, Rest, Out);
		false ->
		    case unique_append(Inh, [Name|Out]) of
			error ->
			    ic_error:error(G, {inherit_resolve, X, Name}),
			    inherit_resolve(G, S, N, Rest, []);
			UA ->
			    inherit_resolve(G, S, N, Rest, UA)
		    end
	    end;
	_ -> inherit_resolve(G, S, N, Rest, Out)
    end;
inherit_resolve(_G, _S, _N, [], Out) -> lists:reverse(Out).

unique_append([X|Xs], L) ->
    case lists:member(X, L) of
	true -> unique_append(Xs, L);
	false -> unique_append(Xs, [X|L])
    end;
unique_append([], L) -> L;
%% Error 
unique_append(_, _L) -> error.




%%--------------------------------------------------------------------
%%
%%	Utilities
%%

%% Must preserve order, therefore had to write my own (instead of lists:map)
check_list(G, S, N, [X|Xs]) ->
    X1 = check(G, S, N, X),
    [X1 | check_list(G, S, N, Xs)];
check_list(_G, _S, _N, []) -> [].



filter( [] ) ->
    error;
filter( [I | Is ] ) ->
    case I of
	{ _, member, { _, TKINFO }, _ } ->
	    fetchType( TKINFO );

        { _, struct, _, _ } ->
	    struct;

	{ _, typedef, TKINFO, _ } ->
	    fetchType( TKINFO );

	{ _, module, _, _ } ->
	    module;

	{ _, interface, _, _ } ->
	    interface;

	{ _, op, _, _ } ->
	    op;

	{ _,enum, _, _ } ->
	    enum;

	{ _, spellcheck } ->
	    filter( Is );

	_ ->
	    error
    end.


fetchType( { tk_sequence, _, _ } ) ->
    sequence;
fetchType( { tk_array, _, _ } ) ->
    array;
fetchType( { tk_struct, _, _, _} ) ->
    struct;
fetchType( { tk_string, _} ) ->
    string;
fetchType( { tk_wstring, _} ) ->  %% WSTRING
    wstring;
fetchType( { tk_fixed, _, _} ) ->
    fixed;
fetchType( tk_short ) ->
    short;
fetchType( tk_long ) ->
    long;
fetchType( tk_longlong ) ->  %% LLONG
    longlong;
fetchType( tk_ushort ) ->
    ushort;
fetchType( tk_ulong ) ->
    ulong;
fetchType( tk_ulonglong ) ->  %% ULLONG
    ulonglong;
fetchType( tk_float ) ->
    float;
fetchType( tk_double ) ->
    double;
fetchType( tk_boolean ) ->
    boolean;
fetchType( tk_char ) ->
    char;
fetchType( tk_wchar ) ->  %% WCHAR
    wchar;
fetchType( tk_octet ) ->
    octet;
fetchType( { tk_enum, _, _, _ } ) ->
    enum;
fetchType( { tk_union, _, _, _, _, _ } ) ->
    union;
fetchType( tk_any ) ->
    any;
fetchType( _ ) ->
    error.

%% Z is a single name
to_uppercase(Z) ->
    lists:map(fun(X) when X>=$a, X=<$z -> X-$a+$A;
		 (X) -> X end, Z).


%%------------------------------------------------------------
%%
%% Always fetchs TK of a record.
%%
%%------------------------------------------------------------
fetchTk(G,N,X) ->
    case ic_forms:get_tk(X) of
        undefined ->
            searchTk(G,ictk:get_IR_ID(G, N, X));
        TK ->
            TK
    end.


%%------------------------------------------------------------
%%
%% seek type code when not accessible by get_tk/1
%%
%%------------------------------------------------------------
searchTk(G,IR_ID) ->
    S = ic_genobj:tktab(G),
    case catch searchTk(S,IR_ID,typedef) of
        {value,TK} ->
            TK;
        _ -> %% false / exit
            case catch searchTk(S,IR_ID,struct) of
                {value,TK} ->
                    TK;
                _  ->  %% false / exit
                    case catch searchTk(S,IR_ID,union) of
                        {value,TK} ->
                            TK;
                        _ ->
                            undefined
                    end
            end
    end.


searchTk(S,IR_ID,Type) ->
    L = lists:flatten(ets:match(S,{'_',Type,'$1','_'})),
    case lists:keysearch(IR_ID,2,L) of
        {value,TK} ->
            {value,TK};
        false ->
            searchInsideTks(L,IR_ID)
    end.


searchInsideTks([],_IR_ID) ->
    false;
searchInsideTks([{tk_array,TK,_}|Xs],IR_ID) ->
    case searchIncludedTk(TK,IR_ID) of
        {value,TK} ->
            {value,TK};
        false ->
            searchInsideTks(Xs,IR_ID)
    end.


searchIncludedTk({tk_array,TK,_},IR_ID) ->
    searchIncludedTk(TK,IR_ID);
searchIncludedTk({tk_sequence,TK,_},IR_ID) ->
    searchIncludedTk(TK,IR_ID);
searchIncludedTk(TK, _IR_ID) when atom(TK) ->
    false;
searchIncludedTk(TK,IR_ID) ->
    case element(2,TK) == IR_ID of
        true ->
            {value,TK};
        false ->
            false
    end.