diff options
Diffstat (limited to 'lib/ic/src/ictype.erl')
-rw-r--r-- | lib/ic/src/ictype.erl | 1413 |
1 files changed, 1413 insertions, 0 deletions
diff --git a/lib/ic/src/ictype.erl b/lib/ic/src/ictype.erl new file mode 100644 index 0000000000..4704191bee --- /dev/null +++ b/lib/ic/src/ictype.erl @@ -0,0 +1,1413 @@ +%% +%% %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(ictype). + + +-include("ic.hrl"). +-include("icforms.hrl"). + +%%----------------------------------------------------------------- +%% External exports +%%----------------------------------------------------------------- +-export([type_check/2, scoped_lookup/4, maybe_array/5, to_uppercase/1]). + +-export([name2type/2, member2type/3, isBasicTypeOrEterm/3, isEterm/3]). +-export([isBasicType/1, isBasicType/2, isBasicType/3, isString/3, isWString/3, + isArray/3, isStruct/3, isUnion/3, isEnum/3, isSequence/3, isBoolean/3 ]). +-export([fetchTk/3, fetchType/1, tk/4]). +%%----------------------------------------------------------------- +%% Internal exports +%%----------------------------------------------------------------- +-export([]). + +%%----------------------------------------------------------------- +%% Macros +%%----------------------------------------------------------------- +%%-define(DBG(F,A), io:format(F,A)). +-define(DBG(F,A), true). +-define(STDDBG, ?DBG(" dbg: ~p: ~p~n", [element(1,X), ic_forms:get_id2(X)])). + +%%----------------------------------------------------------------- +%% External functions +%%----------------------------------------------------------------- + +type_check(G, Forms) -> + S = ic_genobj:tktab(G), + check_list(G, S, [], Forms). + +scoped_lookup(G, S, N, X) -> + Id = ic_symtab:scoped_id_strip(X), + case ic_symtab:scoped_id_is_global(X) of + true -> + lookup(G, S, [], X, Id); + false -> + lookup(G, S, N, X, Id) + end. + + +%%-------------------------------------------------------------------- +%% maybe_array +%% +%% Array declarators are indicated on the declarator and not on +%% the type, therefore the declarator decides if the array type +%% kind is added or not. +%% +maybe_array(G, S, N, X, TK) when is_record(X, array) -> + mk_array(G, S, N, X#array.size, TK); +maybe_array(_G, _S, _N, _, TK) -> TK. + + + +name2type(G, Name) -> + S = ic_genobj:tktab(G), + ScopedName = lists:reverse(string:tokens(Name, "_")), + InfoList = ets:lookup(S, ScopedName ), + filter( InfoList ). + + +%% This is en overloaded function, +%% differs in input on unions +member2type(_G, X, I) when is_record(X, union)-> + Name = ic_forms:get_id2(I), + case lists:keysearch(Name,2,element(6,X#union.tk)) of + false -> + error; + {value,Rec} -> + fetchType(element(3,Rec)) + end; +member2type( G, SName, MName ) -> + + S = ic_genobj:tktab( G ), + SNList = lists:reverse(string:tokens(SName,"_")), + ScopedName = [MName | SNList], + InfoList = ets:lookup( S, ScopedName ), + + case filter( InfoList ) of + error -> + %% Try a little harder, seeking inside tktab + case lookup_member_type_in_tktab(S, ScopedName, MName) of + error -> + %% Check if this is the "return to return1" case + case MName of + "return1" -> + %% Do it all over again ! + ScopedName2 = ["return" | SNList], + InfoList2 = ets:lookup( S, ScopedName2 ), + case filter( InfoList2 ) of + error -> + %% Last resort: seek in pragma table + lookup_type_in_pragmatab(G, SName); + + Other -> + Other + end; + _ -> + %% Last resort: seek in pragma table + lookup_type_in_pragmatab(G, SName) + end; + Other -> + Other + end; + Other -> + Other + end. + + +lookup_member_type_in_tktab(S, ScopedName, MName) -> + case ets:match_object(S, {'_',member,{MName,'_'},nil}) of + [] -> + error; + [{_FullScopedName,member,{MName,TKInfo},nil}]-> + fetchType( TKInfo ); + List -> + lookup_member_type_in_tktab(List,ScopedName) + end. + +lookup_member_type_in_tktab([], _ScopedName) -> + error; +lookup_member_type_in_tktab([{FullScopedName,_,{_,TKInfo},_}|Rest],ScopedName) -> + case lists:reverse(string:tokens(ic_util:to_undersc(FullScopedName),"_")) of + ScopedName -> + fetchType(TKInfo); + _ -> + lookup_member_type_in_tktab(Rest,ScopedName) + end. + + +lookup_type_in_pragmatab(G, SName) -> + S = ic_genobj:pragmatab(G), + + %% Look locally first + case ets:match(S,{file_data_local,'_','_','$2','_','_',SName,'_','_'}) of + [] -> + %% No match, seek included + case ets:match(S,{file_data_included,'_','_','$2','_','_',SName,'_','_'}) of + + [] -> + error; + [[Type]] -> + io:format("1 Found(~p) : ~p~n",[SName,Type]), + Type + end; + + [[Type]] -> + io:format("2 Found(~p) : ~p~n",[SName,Type]), + Type + end. + + + + +isString(G, N, T) when element(1, T) == scoped_id -> + case ic_symtab:get_full_scoped_name(G, N, T) of + {_FullScopedName, _, {'tk_string',_}, _} -> + true; + _ -> + false + end; +isString(_G, _N, T) when is_record(T, string) -> + true; +isString(_G, _N, _Other) -> + false. + + +isWString(G, N, T) when element(1, T) == scoped_id -> %% WSTRING + case ic_symtab:get_full_scoped_name(G, N, T) of + {_FullScopedName, _, {'tk_wstring',_}, _} -> + true; + _ -> + false + end; +isWString(_G, _N, T) when is_record(T, wstring) -> + true; +isWString(_G, _N, _Other) -> + false. + + +isArray(G, N, T) when element(1, T) == scoped_id -> + case ic_symtab:get_full_scoped_name(G, N, T) of + {_FullScopedName, _, {'tk_array', _, _}, _} -> + true; + _ -> + false + end; +isArray(_G, _N, T) when is_record(T, array) -> + true; +isArray(_G, _N, _Other) -> + false. + + +isSequence(G, N, T) when element(1, T) == scoped_id -> + case ic_symtab:get_full_scoped_name(G, N, T) of + {_FullScopedName, _, {'tk_sequence', _, _}, _} -> + true; + _ -> + false + end; +isSequence(_G, _N, T) when is_record(T, sequence) -> + true; +isSequence(_G, _N, _Other) -> + false. + + +isStruct(G, N, T) when element(1, T) == scoped_id -> + case ic_symtab:get_full_scoped_name(G, N, T) of + {_FullScopedName, _, {'tk_struct', _, _, _}, _} -> + true; + _ -> + false + end; +isStruct(_G, _N, T) when is_record(T, struct) -> + true; +isStruct(_G, _N, _Other) -> + false. + + +isUnion(G, N, T) when element(1, T) == scoped_id -> + case ic_symtab:get_full_scoped_name(G, N, T) of + {_FullScopedName, _, {'tk_union', _, _, _,_,_}, _} -> + true; + _Other -> + false + end; +isUnion(_G, _N, T) when is_record(T, union) -> + true; +isUnion(_G, _N, _Other) -> + false. + + + +isEnum(G, N, T) when element(1, T) == scoped_id -> + case ic_symtab:get_full_scoped_name(G, N, T) of + {_FullScopedName, _, {'tk_enum',_,_,_}, _} -> + true; + _Other -> + false + end; +isEnum(_G, _N, T) when is_record(T, enum) -> + true; +isEnum(_G, _N, _Other) -> + false. + + + +isBoolean(G, N, T) when element(1, T) == scoped_id -> + {_, _, TK, _} = + ic_symtab:get_full_scoped_name(G, N, T), + case fetchType(TK) of + 'boolean' -> + true; + _ -> + false + end; +isBoolean(_, _, {'tk_boolean',_}) -> + true; +isBoolean(_, _, {'boolean',_}) -> + true; +isBoolean(_, _, _) -> + false. + + +%%% Just used for C + +isBasicTypeOrEterm(G, N, S) -> + case isBasicType(G, N, S) of + true -> + true; + false -> + isEterm(G, N, S) + end. + +isEterm(G, N, S) when element(1, S) == scoped_id -> + {FullScopedName, _, _TK, _} = ic_symtab:get_full_scoped_name(G, N, S), + case ic_code:get_basetype(G, ic_util:to_undersc(FullScopedName)) of + "erlang_term" -> + true; + "ETERM*" -> + true; + _X -> + false + end; +isEterm(_G, _Ni, _X) -> + false. + +isBasicType(_G, _N, {scoped_id,_,_,["term","erlang"]}) -> + false; +isBasicType(G, N, S) when element(1, S) == scoped_id -> + {_, _, TK, _} = ic_symtab:get_full_scoped_name(G, N, S), + isBasicType(fetchType(TK)); +isBasicType(_G, _N, {string, _} ) -> + false; +isBasicType(_G, _N, {wstring, _} ) -> %% WSTRING + false; +isBasicType(_G, _N, {unsigned, {long, _}} ) -> + true; +isBasicType(_G, _N, {unsigned, {short, _}} ) -> + true; +isBasicType(_G, _N, {Type, _} ) -> + isBasicType(Type); +isBasicType(_G, _N, _X) -> + false. + + +isBasicType( G, Name ) -> + isBasicType( name2type( G, Name ) ). + + +isBasicType( Type ) -> + lists:member(Type, + [tk_short,short, + tk_long,long, + tk_longlong,longlong, %% LLONG + tk_ushort,ushort, + tk_ulong,ulong, + tk_ulonglong,ulonglong, %% ULLONG + tk_float,float, + tk_double,double, + tk_boolean,boolean, + tk_char,char, + tk_wchar,wchar, %% WCHAR + tk_octet,octet, + tk_any,any]). %% Fix for any + + + +%%----------------------------------------------------------------- +%% Internal functions +%%----------------------------------------------------------------- +check(G, _S, N, X) when is_record(X, preproc) -> + handle_preproc(G, N, X#preproc.cat, X), + X; + +check(G, S, N, X) when is_record(X, op) -> + ?STDDBG, + TK = tk_base(G, S, N, ic_forms:get_type(X)), + tktab_add(G, S, N, X), + N2 = [ic_forms:get_id2(X) | N], + Ps = lists:map(fun(P) -> + tktab_add(G, S, N2, P), + P#param{tk=tk_base(G, S, N, ic_forms:get_type(P))} end, + X#op.params), + %% Check for exception defs. + Raises = lists:map(fun(E) -> name_lookup(G, S, N, E) end, + X#op.raises), + case ic_forms:is_oneway(X) of + true -> + if TK /= tk_void -> + ic_error:error(G, {bad_oneway_type, X, TK}); + true -> ok + end, + case ic:filter_params([inout, out], X#op.params) of + [] -> ok; % No out parameters! + _ -> + ic_error:error(G, {oneway_outparams, X}) + end, + case X#op.raises of + [] -> ok; + _ -> + ic_error:error(G, {oneway_raises, X}) + end; + false -> + ok + end, + X#op{params=Ps, tk=TK, raises=Raises}; + +check(G, S, N, X) when is_record(X, interface) -> + ?STDDBG, + N2 = [ic_forms:get_id2(X) | N], + TK = {tk_objref, ictk:get_IR_ID(G, N, X), ic_forms:get_id2(X)}, + Inherit = inherit_resolve(G, S, N, X#interface.inherit, []), + tktab_add(G, S, N, X, TK, Inherit), + CheckedBody = check_list(G, S, N2, ic_forms:get_body(X)), + InhBody = calc_inherit_body(G, N2, CheckedBody, Inherit, []), + X2 = X#interface{inherit=Inherit, tk=TK, body=CheckedBody, + inherit_body=InhBody}, + ic_symtab:store(G, N, X2), + X2; + +check(G, S, N, X) when is_record(X, forward) -> + ?STDDBG, + tktab_add(G, S, N, X, {tk_objref, ictk:get_IR_ID(G, N, X), ic_forms:get_id2(X)}), + X; + + +check(G, S, N, X) when is_record(X, const) -> + ?STDDBG, + case tk_base(G, S, N, ic_forms:get_type(X)) of + Err when element(1, Err) == error -> X; + TK -> + check_const_tk(G, S, N, X, TK), + case iceval:eval_const(G, S, N, TK, X#const.val) of + Err when element(1, Err) == error -> X; + {ok, NewTK, Val} -> + V = iceval:get_val(Val), + tktab_add(G, S, N, X, NewTK, V), + X#const{val=V, tk=NewTK}; + Val -> + V = iceval:get_val(Val), + tktab_add(G, S, N, X, TK, V), + X#const{val=V, tk=TK} + end + end; + +check(G, S, N, X) when is_record(X, const) -> + ?STDDBG, + case tk_base(G, S, N, ic_forms:get_type(X)) of + Err when element(1, Err) == error -> X; + TK -> + check_const_tk(G, S, N, X, TK), + case iceval:eval_const(G, S, N, TK, X#const.val) of + Err when element(1, Err) == error -> X; + Val -> + V = iceval:get_val(Val), + tktab_add(G, S, N, X, TK, V), + X#const{val=V, tk=TK} + end + end; + +check(G, S, N, X) when is_record(X, except) -> + ?STDDBG, + TK = tk(G, S, N, X), + X#except{tk=TK}; + +check(G, S, N, X) when is_record(X, struct) -> + ?STDDBG, + TK = tk(G, S, N, X), + X#struct{tk=TK}; + +check(G, S, N, X) when is_record(X, enum) -> + ?STDDBG, + TK = tk(G, S, N, X), + X#enum{tk=TK}; + +check(G, S, N, X) when is_record(X, union) -> + ?STDDBG, + TK = tk(G, S, N, X), + X#union{tk=TK}; + +check(G, S, N, X) when is_record(X, attr) -> + ?STDDBG, + TK = tk_base(G, S, N, ic_forms:get_type(X)), + XX = #id_of{type=X}, + lists:foreach(fun(Id) -> tktab_add(G, S, N, XX#id_of{id=Id}) end, + ic_forms:get_idlist(X)), + X#attr{tk=TK}; + +check(G, S, N, X) when is_record(X, module) -> + ?STDDBG, + tktab_add(G, S, N, X), + X#module{body=check_list(G, S, [ic_forms:get_id2(X) | N], ic_forms:get_body(X))}; + +check(G, S, N, X) when is_record(X, typedef) -> + ?STDDBG, + TKbase = tk(G, S, N, X), + X#typedef{tk=TKbase}; + +check(_G, _S, _N, X) -> + ?DBG(" dbg: ~p~n", [element(1,X)]), + X. + +handle_preproc(G, _N, line_nr, X) -> ic_genobj:set_idlfile(G, ic_forms:get_id2(X)); +handle_preproc(_G, _N, _C, _X) -> ok. + + +%%-------------------------------------------------------------------- +%% +%% TK calculation +%% +%%-------------------------------------------------------------------- + +tk(G, S, N, X) when is_record(X, union) -> + N2 = [ic_forms:get_id2(X) | N], + DisrcTK = tk(G, S, N, ic_forms:get_type(X)), + case check_switch_tk(G, S, N, X, DisrcTK) of + true -> + do_special_enum(G, S, N2, ic_forms:get_type(X)), + BodyTK = lists:reverse( + tk_caselist(G, S, N2, DisrcTK, ic_forms:get_body(X))), + tktab_add(G, S, N, X, + {tk_union, ictk:get_IR_ID(G, N, X), ic_forms:get_id2(X), + DisrcTK, default_count(ic_forms:get_body(X)), BodyTK}); + false -> + tk_void + end; + +tk(G, S, N, X) when is_record(X, enum) -> + N2 = [ic_forms:get_id2(X) | N], + tktab_add(G, S, N, X, + {tk_enum, ictk:get_IR_ID(G, N, X), ic_forms:get_id2(X), + enum_body(G, S, N2, ic_forms:get_body(X))}); + + +%% Note that the TK returned from this function is the base TK. It +%% must be modified for each of the identifiers in the idlist (for +%% array reasons). +tk(G, S, N, X) when is_record(X, typedef) -> + case X of + %% Special case only for term and java backend ! + {typedef,{any,_},[{'<identifier>',_,"term"}],undefined} -> + case ic_options:get_opt(G, be) of + java -> + tktab_add(G, S, N, X, tk_term), + tk_term; + _ -> + TK = tk(G, S, N, ic_forms:get_body(X)), + lists:foreach(fun(Id) -> + tktab_add(G, S, N, #id_of{id=Id, type=X}, + maybe_array(G, S, N, Id, TK)) + end, + X#typedef.id), + TK + end; + _ -> + TK = tk(G, S, N, ic_forms:get_body(X)), + lists:foreach(fun(Id) -> + tktab_add(G, S, N, #id_of{id=Id, type=X}, + maybe_array(G, S, N, Id, TK)) + end, + X#typedef.id), + TK + end; + +tk(G, S, N, X) when is_record(X, struct) -> + N2 = [ic_forms:get_id2(X) | N], + tktab_add(G, S, N, X, {tk_struct, ictk:get_IR_ID(G, N, X), ic_forms:get_id2(X), + tk_memberlist(G, S, N2, ic_forms:get_body(X))}); + +tk(G, S, N, X) when is_record(X, except) -> + N2 = [ic_forms:get_id2(X) | N], + tktab_add(G, S, N, X, {tk_except, ictk:get_IR_ID(G, N, X), ic_forms:get_id2(X), + tk_memberlist(G, S, N2, ic_forms:get_body(X))}); + +tk(G, S, N, X) -> tk_base(G, S, N, X). + + +tk_base(G, S, N, X) when is_record(X, sequence) -> + {tk_sequence, tk(G, S, N, X#sequence.type), + len_eval(G, S, N, X#sequence.length)}; + +tk_base(G, S, N, X) when is_record(X, string) -> + {tk_string, len_eval(G, S, N, X#string.length)}; + +tk_base(G, S, N, X) when is_record(X, wstring) -> %% WSTRING + {tk_wstring, len_eval(G, S, N, X#wstring.length)}; + +%% Fixed constants can be declared as: +%% (1) const fixed pi = 3.14D; or +%% (2) typedef fixed<3,2> f32; +%% const f32 pi = 3.14D; +tk_base(G, S, N, X) when is_record(X, fixed) -> + %% Case 2 + {tk_fixed, len_eval(G, S, N, X#fixed.digits), len_eval(G, S, N, X#fixed.scale)}; +tk_base(_G, _S, _N, {fixed, _}) -> + %% Case 1 + tk_fixed; + + +%% Special case, here CORBA::TypeCode is built in +%% ONLY when erl_corba is the backend of choice +tk_base(G, S, N, {scoped_id,V1,V2,["TypeCode","CORBA"]}) -> + case ic_options:get_opt(G, be) of + false -> + tk_TypeCode; + erl_corba -> + tk_TypeCode; + erl_template -> + tk_TypeCode; + _ -> + case scoped_lookup(G, S, N, {scoped_id,V1,V2,["TypeCode","CORBA"]}) of + T when element(1, T) == error -> T; + T when is_tuple(T) -> element(3, T) + end + end; + +tk_base(G, S, N, X) when element(1, X) == scoped_id -> + case scoped_lookup(G, S, N, X) of + T when element(1, T) == error -> T; + T when is_tuple(T) -> element(3, T) + end; +tk_base(_G, _S, _N, {long, _}) -> tk_long; +tk_base(_G, _S, _N, {'long long', _}) -> tk_longlong; %% LLONG +tk_base(_G, _S, _N, {short, _}) -> tk_short; +tk_base(_G, _S, _N, {'unsigned', {short, _}}) -> tk_ushort; +tk_base(_G, _S, _N, {'unsigned', {long, _}}) -> tk_ulong; +tk_base(_G, _S, _N, {'unsigned', {'long long', _}})-> tk_ulonglong; %% ULLONG +tk_base(_G, _S, _N, {float, _}) -> tk_float; +tk_base(_G, _S, _N, {double, _}) -> tk_double; +tk_base(_G, _S, _N, {boolean, _}) -> tk_boolean; +tk_base(_G, _S, _N, {char, _}) -> tk_char; +tk_base(_G, _S, _N, {wchar, _}) -> tk_wchar; %% WCHAR +tk_base(_G, _S, _N, {octet, _}) -> tk_octet; +tk_base(_G, _S, _N, {null, _}) -> tk_null; +tk_base(_G, _S, _N, {void, _}) -> tk_void; +tk_base(_G, _S, _N, {any, _}) -> tk_any; +tk_base(_G, _S, _N, {'Object', _}) -> {tk_objref, "", "Object"}. + + +%%-------------------------------------------------------------------- +%% +%% Special handling of idlists. Note that the recursion case is given +%% as accumulator to foldr. Idlists are those lists of identifiers +%% that share the same definition, i.e. multiple cases, multiple type +%% declarations, multiple member names. +%% +tk_memberlist(G, S, N, [X | Xs]) -> + BaseTK = tk(G, S, N, ic_forms:get_type(X)), + + XX = #id_of{type=X}, + lists:foldr(fun(Id, Acc) -> + [tk_member(G, S, N, XX#id_of{id=Id}, BaseTK) | Acc] end, + tk_memberlist(G, S, N, Xs), + ic_forms:get_idlist(X)); +tk_memberlist(_G, _S, _N, []) -> []. + +%% same as above but for case dcls +tk_caselist(G, S, N, DiscrTK, Xs) -> + lists:foldl(fun(Case, Acc) -> + BaseTK = tk(G, S, N, ic_forms:get_type(Case)), + %% tktab_add for the uniqueness check of the declarator + tktab_add(G, S, N, Case), + lists:foldl(fun(Id, Acc2) -> + case tk_case(G, S, N, Case, BaseTK, + DiscrTK, Id) of + Err when element(1, Err)==error -> + Acc2; + TK -> + unique_add_case_label(G, S, N, Id, + TK, Acc2) + end + end, + Acc, + ic_forms:get_idlist(Case)) + end, + [], + Xs). + + +%% Handling of the things that can be in an idlist or caselist +tk_member(G, S, N, X, BaseTK) -> + tktab_add(G, S, N, X, + {ic_forms:get_id2(X), maybe_array(G, S, N, X#id_of.id, BaseTK)}). + + +get_case_id_and_check(G, _S, _N, _X, ScopedId) -> + case ic_symtab:scoped_id_is_global(ScopedId) of + true -> ic_error:error(G, {bad_scope_enum_case, ScopedId}); + false -> ok + end, + case ic_symtab:scoped_id_strip(ScopedId) of + [Id] -> Id; + _List -> + ic_error:error(G, {bad_scope_enum_case, ScopedId}), + "" + end. + + +tk_case(G, S, N, X, BaseTK, DiscrTK, Id) -> + case case_eval(G, S, N, DiscrTK, Id) of + Err when element(1, Err) == error -> Err; + Val -> + case iceval:check_tk(G, DiscrTK, Val) of + true -> + {iceval:get_val(Val), ic_forms:get_id2(X), + maybe_array(G, S, N, X#case_dcl.id, BaseTK)}; + false -> + ic_error:error(G, {bad_case_type, DiscrTK, X, + iceval:get_val(Val)}) + end + end. + +tktab_add(G, S, N, X) -> + tktab_add_id(G, S, N, X, ic_forms:get_id2(X), nil, nil). +tktab_add(G, S, N, X, TK) -> + tktab_add_id(G, S, N, X, ic_forms:get_id2(X), TK, nil). +tktab_add(G, S, N, X, TK, Aux) -> + tktab_add_id(G, S, N, X, ic_forms:get_id2(X), TK, Aux). + + +tktab_add_id(G, S, N, X, Id, TK, Aux) when is_record(X,enumerator) -> + + %% Check if the "scl" flag is set to true + %% if so, allow old semantics ( errornous ) + %% Warning, this is for compatibility reasons only. + Name = case ic_options:get_opt(G, scl) of + true -> + [Id | N]; + false -> + [Id | tl(N)] + end, + + UName = mk_uppercase(Name), + case ets:lookup(S, Name) of + [_] -> ic_error:error(G, {multiply_defined, X}); + [] -> + case ets:lookup(S, UName) of + [] -> ok; + [_] -> ic_error:error(G, {illegal_spelling, X}) + end + end, + ets:insert(S, {Name, element(1, get_beef(X)), TK, Aux}), + if UName =/= Name -> ets:insert(S, {UName, spellcheck}); + true -> true end, + TK; +%% +%% Fixes the multiple file module definition check +%% but ONLY for Corba backend +%% +tktab_add_id(G, S, N, X, Id, TK, Aux) when is_record(X,module) -> + case ic_options:get_opt(G, be) of + erl_template -> + Name = [Id | N], + UName = mk_uppercase(Name), + ets:insert(S, {Name, element(1, get_beef(X)), TK, Aux}), + if UName =/= Name -> ets:insert(S, {UName, spellcheck}); + true -> true end, + TK; + erl_corba -> + Name = [Id | N], + UName = mk_uppercase(Name), + ets:insert(S, {Name, element(1, get_beef(X)), TK, Aux}), + if UName =/= Name -> ets:insert(S, {UName, spellcheck}); + true -> true end, + TK; + false -> %% default == erl_corba + Name = [Id | N], + UName = mk_uppercase(Name), + ets:insert(S, {Name, element(1, get_beef(X)), TK, Aux}), + if UName =/= Name -> ets:insert(S, {UName, spellcheck}); + true -> true end, + TK; + java -> + Name = [Id | N], + UName = mk_uppercase(Name), + ets:insert(S, {Name, element(1, get_beef(X)), TK, Aux}), + if UName =/= Name -> ets:insert(S, {UName, spellcheck}); + true -> true end, + TK; + erl_genserv -> + Name = [Id | N], + UName = mk_uppercase(Name), + ets:insert(S, {Name, element(1, get_beef(X)), TK, Aux}), + if UName =/= Name -> ets:insert(S, {UName, spellcheck}); + true -> true end, + TK; + erl_plain -> + Name = [Id | N], + UName = mk_uppercase(Name), + ets:insert(S, {Name, element(1, get_beef(X)), TK, Aux}), + if UName =/= Name -> ets:insert(S, {UName, spellcheck}); + true -> true end, + TK; + _Be -> + Name = [Id | N], + UName = mk_uppercase(Name), + case ets:lookup(S, Name) of + [_] -> ic_error:error(G, {multiply_defined, X}); + [] -> + case ets:lookup(S, UName) of + [] -> ok; + [_] -> ic_error:error(G, {illegal_spelling, X}) + end + end, + ets:insert(S, {Name, element(1, get_beef(X)), TK, Aux}), + if UName =/= Name -> ets:insert(S, {UName, spellcheck}); + true -> true end, + TK + end; +tktab_add_id(G, S, N, X, Id, TK, Aux) -> + Name = [Id | N], + UName = mk_uppercase(Name), + case ets:lookup(S, Name) of + [{_, forward, _, _}] when is_record(X, interface) -> ok; + [XX] when is_record(X, forward) andalso element(2, XX)==interface -> ok; + [_] -> ic_error:error(G, {multiply_defined, X}); + [] -> + case ets:lookup(S, UName) of + [] -> ok; + [_] -> ic_error:error(G, {illegal_spelling, X}) + end + end, + ets:insert(S, {Name, element(1, get_beef(X)), TK, Aux}), + if UName =/= Name -> ets:insert(S, {UName, spellcheck}); + true -> true end, + TK. + + + + +%%-------------------------------------------------------------------- +%% enum_body +%% +%% Special because ids are treated different than usual. +%% +enum_body(G, S, N, [Enum | EnumList]) -> + tktab_add(G, S, N, Enum), %%%, enum_val, Enum), + %% tktab_add(G, S, N, X, TK, V), + [ic_forms:get_id2(Enum) | enum_body(G, S, N, EnumList)]; +enum_body(_G, _S, _N, []) -> []. + + +%%-------------------------------------------------------------------- +%% mk_array +%% +%% Multi dimensional arrays are written as nested tk_array +%% +mk_array(G, S, N, [Sz | Szs], TK) -> + case iceval:eval_const(G, S, N, positive_int, Sz) of + Err when element(1, Err) == error -> TK; + Val -> + {tk_array, mk_array(G, S, N, Szs, TK), iceval:get_val(Val)} + end; +mk_array(_G, _S, _N, [], TK) -> TK. + + +%%-------------------------------------------------------------------- +%% len_eval +%% +%% Evaluates the length, which in case it has been left out is a +%% plain 0 (zero) +%% +len_eval(_G, _S, _N, 0) -> 0; +len_eval(G, S, N, X) -> %%iceval:eval_const(G, S, N, positive_int, X). + case iceval:eval_const(G, S, N, positive_int, X) of + Err when element(1, Err) == error -> 0; + Val -> iceval:get_val(Val) + end. + + +%%-------------------------------------------------------------------- +%% case_eval +%% +%% Evaluates the case label. +%% + +case_eval(G, S, N, DiscrTK, X) when element(1, DiscrTK) == tk_enum, + element(1, X) == scoped_id -> + {tk_enum, _, _, Cases} = DiscrTK, + Id = get_case_id_and_check(G, S, N, X, X), + %%io:format("Matching: ~p to ~p~n", [Id, Cases]), + case lists:member(Id, Cases) of + true -> + {enum_id, Id}; + false -> + iceval:mk_val(scoped_lookup(G, S, N, X)) % Will generate error + end; + +case_eval(G, S, N, DiscrTK, X) -> + iceval:eval_e(G, S, N, DiscrTK, X). + + +%% The enum declarator is in the union scope. +do_special_enum(G, S, N, X) when is_record(X, enum) -> + tktab_add(G, S, N, #id_of{id=X#enum.id, type=X}); +do_special_enum(_G, _S, _N, _X) -> + ok. + + +unique_add_case_label(G, _S, _N, Id, TK, TKList) -> +%%%io:format("check_case_labels: TK:~p TKLIST:~p ~n", [TK, TKList]), + if element(1, TK) == error -> + TKList; + true -> + case lists:keysearch(element(1, TK), 1, TKList) of + {value, _} -> + ic_error:error(G, {multiple_cases, Id}), + TKList; + false -> + [TK | TKList] + end + end. + + +%%-------------------------------------------------------------------- +%% default_count +%% +%% Returns the position of the default case. +%% +%% Modified for OTP-2007 +%% +default_count(Xs) -> + default_count2(Xs, 0). + +default_count2([X | Xs], N) -> default_count3(X#case_dcl.label, Xs, N); +default_count2([], _) -> -1. + +default_count3([{default, _} | _Ys], _Xs, N) -> N; +default_count3([_ | Ys], Xs, N) -> default_count3(Ys, Xs, N+1); +default_count3([], Xs, N) -> default_count2(Xs, N). + + + + +%% +%% Type checks. +%% +%% Check constant type references (only for the scoped id case, others +%% are caught by the BNF) +%% +check_const_tk(_G, _S, _N, _X, tk_long) -> true; +check_const_tk(_G, _S, _N, _X, tk_longlong) -> true; %% LLONG +check_const_tk(_G, _S, _N, _X, tk_short) -> true; +check_const_tk(_G, _S, _N, _X, tk_ushort) -> true; +check_const_tk(_G, _S, _N, _X, tk_ulong) -> true; +check_const_tk(_G, _S, _N, _X, tk_ulonglong) -> true; %% ULLONG +check_const_tk(_G, _S, _N, _X, tk_float) -> true; +check_const_tk(_G, _S, _N, _X, tk_double) -> true; +check_const_tk(_G, _S, _N, _X, tk_boolean) -> true; +check_const_tk(_G, _S, _N, _X, tk_char) -> true; +check_const_tk(_G, _S, _N, _X, tk_wchar) -> true; %% WCHAR +check_const_tk(_G, _S, _N, _X, tk_octet) -> true; +check_const_tk(_G, _S, _N, _X, {tk_string, _Len}) -> true; +check_const_tk(_G, _S, _N, _X, {tk_wstring, _Len}) -> true; %% WSTRING +check_const_tk(_G, _S, _N, _X, tk_fixed) -> true; +check_const_tk(_G, _S, _N, _X, {tk_fixed, _Digits, _Scale}) -> true; +check_const_tk(G, _S, _N, X, TK) -> ic_error:error(G, {illegal_const_t, X, TK}). + + +check_switch_tk(_G, _S, _N, _X, tk_long) -> true; +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 is_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 is_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 is_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 is_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 is_record(I1, op) -> %%, record(I2, op) -> + ic_error:error(G, {inherit_name_collision, + {YPath, Y}, {XPath, X}}); + is_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 is_record(X, typedef) -> true; +has_idlist(X) when is_record(X, member) -> true; +has_idlist(X) when is_record(X, case_dcl) -> true; +has_idlist(X) when is_record(X, attr) -> true; +has_idlist(_) -> false. + +replace_idlist(X, IdList) when is_record(X, typedef) -> X#typedef{id=IdList}; +replace_idlist(X, IdList) when is_record(X, attr) -> X#attr{id=IdList}. + +get_beef(X) when is_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 is_atom(TK) -> + false; +searchIncludedTk(TK,IR_ID) -> + case element(2,TK) == IR_ID of + true -> + {value,TK}; + false -> + false + end. + |