diff options
author | upstream source tree <ports@midipix.org> | 2015-03-15 20:14:05 -0400 |
---|---|---|
committer | upstream source tree <ports@midipix.org> | 2015-03-15 20:14:05 -0400 |
commit | 554fd8c5195424bdbcabf5de30fdc183aba391bd (patch) | |
tree | 976dc5ab7fddf506dadce60ae936f43f58787092 /gcc/ada/sem_type.adb | |
download | cbb-gcc-4.6.4-554fd8c5195424bdbcabf5de30fdc183aba391bd.tar.bz2 cbb-gcc-4.6.4-554fd8c5195424bdbcabf5de30fdc183aba391bd.tar.xz |
obtained gcc-4.6.4.tar.bz2 from upstream website;upstream
verified gcc-4.6.4.tar.bz2.sig;
imported gcc-4.6.4 source tree from verified upstream tarball.
downloading a git-generated archive based on the 'upstream' tag
should provide you with a source tree that is binary identical
to the one extracted from the above tarball.
if you have obtained the source via the command 'git clone',
however, do note that line-endings of files in your working
directory might differ from line-endings of the respective
files in the upstream repository.
Diffstat (limited to 'gcc/ada/sem_type.adb')
-rw-r--r-- | gcc/ada/sem_type.adb | 3295 |
1 files changed, 3295 insertions, 0 deletions
diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb new file mode 100644 index 000000000..08d273e37 --- /dev/null +++ b/gcc/ada/sem_type.adb @@ -0,0 +1,3295 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ T Y P E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Alloc; +with Debug; use Debug; +with Einfo; use Einfo; +with Elists; use Elists; +with Nlists; use Nlists; +with Errout; use Errout; +with Lib; use Lib; +with Namet; use Namet; +with Opt; use Opt; +with Output; use Output; +with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +with Sem_Ch6; use Sem_Ch6; +with Sem_Ch8; use Sem_Ch8; +with Sem_Ch12; use Sem_Ch12; +with Sem_Disp; use Sem_Disp; +with Sem_Dist; use Sem_Dist; +with Sem_Util; use Sem_Util; +with Stand; use Stand; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Table; +with Uintp; use Uintp; + +package body Sem_Type is + + --------------------- + -- Data Structures -- + --------------------- + + -- The following data structures establish a mapping between nodes and + -- their interpretations. An overloaded node has an entry in Interp_Map, + -- which in turn contains a pointer into the All_Interp array. The + -- interpretations of a given node are contiguous in All_Interp. Each set + -- of interpretations is terminated with the marker No_Interp. In order to + -- speed up the retrieval of the interpretations of an overloaded node, the + -- Interp_Map table is accessed by means of a simple hashing scheme, and + -- the entries in Interp_Map are chained. The heads of clash lists are + -- stored in array Headers. + + -- Headers Interp_Map All_Interp + + -- _ +-----+ +--------+ + -- |_| |_____| --->|interp1 | + -- |_|---------->|node | | |interp2 | + -- |_| |index|---------| |nointerp| + -- |_| |next | | | + -- |-----| | | + -- +-----+ +--------+ + + -- This scheme does not currently reclaim interpretations. In principle, + -- after a unit is compiled, all overloadings have been resolved, and the + -- candidate interpretations should be deleted. This should be easier + -- now than with the previous scheme??? + + package All_Interp is new Table.Table ( + Table_Component_Type => Interp, + Table_Index_Type => Int, + Table_Low_Bound => 0, + Table_Initial => Alloc.All_Interp_Initial, + Table_Increment => Alloc.All_Interp_Increment, + Table_Name => "All_Interp"); + + type Interp_Ref is record + Node : Node_Id; + Index : Interp_Index; + Next : Int; + end record; + + Header_Size : constant Int := 2 ** 12; + No_Entry : constant Int := -1; + Headers : array (0 .. Header_Size) of Int := (others => No_Entry); + + package Interp_Map is new Table.Table ( + Table_Component_Type => Interp_Ref, + Table_Index_Type => Int, + Table_Low_Bound => 0, + Table_Initial => Alloc.Interp_Map_Initial, + Table_Increment => Alloc.Interp_Map_Increment, + Table_Name => "Interp_Map"); + + function Hash (N : Node_Id) return Int; + -- A trivial hashing function for nodes, used to insert an overloaded + -- node into the Interp_Map table. + + ------------------------------------- + -- Handling of Overload Resolution -- + ------------------------------------- + + -- Overload resolution uses two passes over the syntax tree of a complete + -- context. In the first, bottom-up pass, the types of actuals in calls + -- are used to resolve possibly overloaded subprogram and operator names. + -- In the second top-down pass, the type of the context (for example the + -- condition in a while statement) is used to resolve a possibly ambiguous + -- call, and the unique subprogram name in turn imposes a specific context + -- on each of its actuals. + + -- Most expressions are in fact unambiguous, and the bottom-up pass is + -- sufficient to resolve most everything. To simplify the common case, + -- names and expressions carry a flag Is_Overloaded to indicate whether + -- they have more than one interpretation. If the flag is off, then each + -- name has already a unique meaning and type, and the bottom-up pass is + -- sufficient (and much simpler). + + -------------------------- + -- Operator Overloading -- + -------------------------- + + -- The visibility of operators is handled differently from that of other + -- entities. We do not introduce explicit versions of primitive operators + -- for each type definition. As a result, there is only one entity + -- corresponding to predefined addition on all numeric types, etc. The + -- back-end resolves predefined operators according to their type. The + -- visibility of primitive operations then reduces to the visibility of the + -- resulting type: (a + b) is a legal interpretation of some primitive + -- operator + if the type of the result (which must also be the type of a + -- and b) is directly visible (either immediately visible or use-visible). + + -- User-defined operators are treated like other functions, but the + -- visibility of these user-defined operations must be special-cased + -- to determine whether they hide or are hidden by predefined operators. + -- The form P."+" (x, y) requires additional handling. + + -- Concatenation is treated more conventionally: for every one-dimensional + -- array type we introduce a explicit concatenation operator. This is + -- necessary to handle the case of (element & element => array) which + -- cannot be handled conveniently if there is no explicit instance of + -- resulting type of the operation. + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure All_Overloads; + pragma Warnings (Off, All_Overloads); + -- Debugging procedure: list full contents of Overloads table + + function Binary_Op_Interp_Has_Abstract_Op + (N : Node_Id; + E : Entity_Id) return Entity_Id; + -- Given the node and entity of a binary operator, determine whether the + -- actuals of E contain an abstract interpretation with regards to the + -- types of their corresponding formals. Return the abstract operation or + -- Empty. + + function Function_Interp_Has_Abstract_Op + (N : Node_Id; + E : Entity_Id) return Entity_Id; + -- Given the node and entity of a function call, determine whether the + -- actuals of E contain an abstract interpretation with regards to the + -- types of their corresponding formals. Return the abstract operation or + -- Empty. + + function Has_Abstract_Op + (N : Node_Id; + Typ : Entity_Id) return Entity_Id; + -- Subsidiary routine to Binary_Op_Interp_Has_Abstract_Op and Function_ + -- Interp_Has_Abstract_Op. Determine whether an overloaded node has an + -- abstract interpretation which yields type Typ. + + procedure New_Interps (N : Node_Id); + -- Initialize collection of interpretations for the given node, which is + -- either an overloaded entity, or an operation whose arguments have + -- multiple interpretations. Interpretations can be added to only one + -- node at a time. + + function Specific_Type (Typ_1, Typ_2 : Entity_Id) return Entity_Id; + -- If Typ_1 and Typ_2 are compatible, return the one that is not universal + -- or is not a "class" type (any_character, etc). + + -------------------- + -- Add_One_Interp -- + -------------------- + + procedure Add_One_Interp + (N : Node_Id; + E : Entity_Id; + T : Entity_Id; + Opnd_Type : Entity_Id := Empty) + is + Vis_Type : Entity_Id; + + procedure Add_Entry (Name : Entity_Id; Typ : Entity_Id); + -- Add one interpretation to an overloaded node. Add a new entry if + -- not hidden by previous one, and remove previous one if hidden by + -- new one. + + function Is_Universal_Operation (Op : Entity_Id) return Boolean; + -- True if the entity is a predefined operator and the operands have + -- a universal Interpretation. + + --------------- + -- Add_Entry -- + --------------- + + procedure Add_Entry (Name : Entity_Id; Typ : Entity_Id) is + Abstr_Op : Entity_Id := Empty; + I : Interp_Index; + It : Interp; + + -- Start of processing for Add_Entry + + begin + -- Find out whether the new entry references interpretations that + -- are abstract or disabled by abstract operators. + + if Ada_Version >= Ada_2005 then + if Nkind (N) in N_Binary_Op then + Abstr_Op := Binary_Op_Interp_Has_Abstract_Op (N, Name); + elsif Nkind (N) = N_Function_Call then + Abstr_Op := Function_Interp_Has_Abstract_Op (N, Name); + end if; + end if; + + Get_First_Interp (N, I, It); + while Present (It.Nam) loop + + -- A user-defined subprogram hides another declared at an outer + -- level, or one that is use-visible. So return if previous + -- definition hides new one (which is either in an outer + -- scope, or use-visible). Note that for functions use-visible + -- is the same as potentially use-visible. If new one hides + -- previous one, replace entry in table of interpretations. + -- If this is a universal operation, retain the operator in case + -- preference rule applies. + + if (((Ekind (Name) = E_Function or else Ekind (Name) = E_Procedure) + and then Ekind (Name) = Ekind (It.Nam)) + or else (Ekind (Name) = E_Operator + and then Ekind (It.Nam) = E_Function)) + + and then Is_Immediately_Visible (It.Nam) + and then Type_Conformant (Name, It.Nam) + and then Base_Type (It.Typ) = Base_Type (T) + then + if Is_Universal_Operation (Name) then + exit; + + -- If node is an operator symbol, we have no actuals with + -- which to check hiding, and this is done in full in the + -- caller (Analyze_Subprogram_Renaming) so we include the + -- predefined operator in any case. + + elsif Nkind (N) = N_Operator_Symbol + or else (Nkind (N) = N_Expanded_Name + and then + Nkind (Selector_Name (N)) = N_Operator_Symbol) + then + exit; + + elsif not In_Open_Scopes (Scope (Name)) + or else Scope_Depth (Scope (Name)) <= + Scope_Depth (Scope (It.Nam)) + then + -- If ambiguity within instance, and entity is not an + -- implicit operation, save for later disambiguation. + + if Scope (Name) = Scope (It.Nam) + and then not Is_Inherited_Operation (Name) + and then In_Instance + then + exit; + else + return; + end if; + + else + All_Interp.Table (I).Nam := Name; + return; + end if; + + -- Avoid making duplicate entries in overloads + + elsif Name = It.Nam + and then Base_Type (It.Typ) = Base_Type (T) + then + return; + + -- Otherwise keep going + + else + Get_Next_Interp (I, It); + end if; + + end loop; + + All_Interp.Table (All_Interp.Last) := (Name, Typ, Abstr_Op); + All_Interp.Append (No_Interp); + end Add_Entry; + + ---------------------------- + -- Is_Universal_Operation -- + ---------------------------- + + function Is_Universal_Operation (Op : Entity_Id) return Boolean is + Arg : Node_Id; + + begin + if Ekind (Op) /= E_Operator then + return False; + + elsif Nkind (N) in N_Binary_Op then + return Present (Universal_Interpretation (Left_Opnd (N))) + and then Present (Universal_Interpretation (Right_Opnd (N))); + + elsif Nkind (N) in N_Unary_Op then + return Present (Universal_Interpretation (Right_Opnd (N))); + + elsif Nkind (N) = N_Function_Call then + Arg := First_Actual (N); + while Present (Arg) loop + if No (Universal_Interpretation (Arg)) then + return False; + end if; + + Next_Actual (Arg); + end loop; + + return True; + + else + return False; + end if; + end Is_Universal_Operation; + + -- Start of processing for Add_One_Interp + + begin + -- If the interpretation is a predefined operator, verify that the + -- result type is visible, or that the entity has already been + -- resolved (case of an instantiation node that refers to a predefined + -- operation, or an internally generated operator node, or an operator + -- given as an expanded name). If the operator is a comparison or + -- equality, it is the type of the operand that matters to determine + -- whether the operator is visible. In an instance, the check is not + -- performed, given that the operator was visible in the generic. + + if Ekind (E) = E_Operator then + if Present (Opnd_Type) then + Vis_Type := Opnd_Type; + else + Vis_Type := Base_Type (T); + end if; + + if In_Open_Scopes (Scope (Vis_Type)) + or else Is_Potentially_Use_Visible (Vis_Type) + or else In_Use (Vis_Type) + or else (In_Use (Scope (Vis_Type)) + and then not Is_Hidden (Vis_Type)) + or else Nkind (N) = N_Expanded_Name + or else (Nkind (N) in N_Op and then E = Entity (N)) + or else In_Instance + or else Ekind (Vis_Type) = E_Anonymous_Access_Type + then + null; + + -- If the node is given in functional notation and the prefix + -- is an expanded name, then the operator is visible if the + -- prefix is the scope of the result type as well. If the + -- operator is (implicitly) defined in an extension of system, + -- it is know to be valid (see Defined_In_Scope, sem_ch4.adb). + + elsif Nkind (N) = N_Function_Call + and then Nkind (Name (N)) = N_Expanded_Name + and then (Entity (Prefix (Name (N))) = Scope (Base_Type (T)) + or else Entity (Prefix (Name (N))) = Scope (Vis_Type) + or else Scope (Vis_Type) = System_Aux_Id) + then + null; + + -- Save type for subsequent error message, in case no other + -- interpretation is found. + + else + Candidate_Type := Vis_Type; + return; + end if; + + -- In an instance, an abstract non-dispatching operation cannot be a + -- candidate interpretation, because it could not have been one in the + -- generic (it may be a spurious overloading in the instance). + + elsif In_Instance + and then Is_Overloadable (E) + and then Is_Abstract_Subprogram (E) + and then not Is_Dispatching_Operation (E) + then + return; + + -- An inherited interface operation that is implemented by some derived + -- type does not participate in overload resolution, only the + -- implementation operation does. + + elsif Is_Hidden (E) + and then Is_Subprogram (E) + and then Present (Interface_Alias (E)) + then + -- Ada 2005 (AI-251): If this primitive operation corresponds with + -- an immediate ancestor interface there is no need to add it to the + -- list of interpretations. The corresponding aliased primitive is + -- also in this list of primitive operations and will be used instead + -- because otherwise we have a dummy ambiguity between the two + -- subprograms which are in fact the same. + + if not Is_Ancestor + (Find_Dispatching_Type (Interface_Alias (E)), + Find_Dispatching_Type (E)) + then + Add_One_Interp (N, Interface_Alias (E), T); + end if; + + return; + + -- Calling stubs for an RACW operation never participate in resolution, + -- they are executed only through dispatching calls. + + elsif Is_RACW_Stub_Type_Operation (E) then + return; + end if; + + -- If this is the first interpretation of N, N has type Any_Type. + -- In that case place the new type on the node. If one interpretation + -- already exists, indicate that the node is overloaded, and store + -- both the previous and the new interpretation in All_Interp. If + -- this is a later interpretation, just add it to the set. + + if Etype (N) = Any_Type then + if Is_Type (E) then + Set_Etype (N, T); + + else + -- Record both the operator or subprogram name, and its type + + if Nkind (N) in N_Op or else Is_Entity_Name (N) then + Set_Entity (N, E); + end if; + + Set_Etype (N, T); + end if; + + -- Either there is no current interpretation in the table for any + -- node or the interpretation that is present is for a different + -- node. In both cases add a new interpretation to the table. + + elsif Interp_Map.Last < 0 + or else + (Interp_Map.Table (Interp_Map.Last).Node /= N + and then not Is_Overloaded (N)) + then + New_Interps (N); + + if (Nkind (N) in N_Op or else Is_Entity_Name (N)) + and then Present (Entity (N)) + then + Add_Entry (Entity (N), Etype (N)); + + elsif Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement) + and then Is_Entity_Name (Name (N)) + then + Add_Entry (Entity (Name (N)), Etype (N)); + + -- If this is an indirect call there will be no name associated + -- with the previous entry. To make diagnostics clearer, save + -- Subprogram_Type of first interpretation, so that the error will + -- point to the anonymous access to subprogram, not to the result + -- type of the call itself. + + elsif (Nkind (N)) = N_Function_Call + and then Nkind (Name (N)) = N_Explicit_Dereference + and then Is_Overloaded (Name (N)) + then + declare + It : Interp; + + Itn : Interp_Index; + pragma Warnings (Off, Itn); + + begin + Get_First_Interp (Name (N), Itn, It); + Add_Entry (It.Nam, Etype (N)); + end; + + else + -- Overloaded prefix in indexed or selected component, or call + -- whose name is an expression or another call. + + Add_Entry (Etype (N), Etype (N)); + end if; + + Add_Entry (E, T); + + else + Add_Entry (E, T); + end if; + end Add_One_Interp; + + ------------------- + -- All_Overloads -- + ------------------- + + procedure All_Overloads is + begin + for J in All_Interp.First .. All_Interp.Last loop + + if Present (All_Interp.Table (J).Nam) then + Write_Entity_Info (All_Interp.Table (J). Nam, " "); + else + Write_Str ("No Interp"); + Write_Eol; + end if; + + Write_Str ("================="); + Write_Eol; + end loop; + end All_Overloads; + + -------------------------------------- + -- Binary_Op_Interp_Has_Abstract_Op -- + -------------------------------------- + + function Binary_Op_Interp_Has_Abstract_Op + (N : Node_Id; + E : Entity_Id) return Entity_Id + is + Abstr_Op : Entity_Id; + E_Left : constant Node_Id := First_Formal (E); + E_Right : constant Node_Id := Next_Formal (E_Left); + + begin + Abstr_Op := Has_Abstract_Op (Left_Opnd (N), Etype (E_Left)); + if Present (Abstr_Op) then + return Abstr_Op; + end if; + + return Has_Abstract_Op (Right_Opnd (N), Etype (E_Right)); + end Binary_Op_Interp_Has_Abstract_Op; + + --------------------- + -- Collect_Interps -- + --------------------- + + procedure Collect_Interps (N : Node_Id) is + Ent : constant Entity_Id := Entity (N); + H : Entity_Id; + First_Interp : Interp_Index; + + begin + New_Interps (N); + + -- Unconditionally add the entity that was initially matched + + First_Interp := All_Interp.Last; + Add_One_Interp (N, Ent, Etype (N)); + + -- For expanded name, pick up all additional entities from the + -- same scope, since these are obviously also visible. Note that + -- these are not necessarily contiguous on the homonym chain. + + if Nkind (N) = N_Expanded_Name then + H := Homonym (Ent); + while Present (H) loop + if Scope (H) = Scope (Entity (N)) then + Add_One_Interp (N, H, Etype (H)); + end if; + + H := Homonym (H); + end loop; + + -- Case of direct name + + else + -- First, search the homonym chain for directly visible entities + + H := Current_Entity (Ent); + while Present (H) loop + exit when (not Is_Overloadable (H)) + and then Is_Immediately_Visible (H); + + if Is_Immediately_Visible (H) + and then H /= Ent + then + -- Only add interpretation if not hidden by an inner + -- immediately visible one. + + for J in First_Interp .. All_Interp.Last - 1 loop + + -- Current homograph is not hidden. Add to overloads + + if not Is_Immediately_Visible (All_Interp.Table (J).Nam) then + exit; + + -- Homograph is hidden, unless it is a predefined operator + + elsif Type_Conformant (H, All_Interp.Table (J).Nam) then + + -- A homograph in the same scope can occur within an + -- instantiation, the resulting ambiguity has to be + -- resolved later. + + if Scope (H) = Scope (Ent) + and then In_Instance + and then not Is_Inherited_Operation (H) + then + All_Interp.Table (All_Interp.Last) := + (H, Etype (H), Empty); + All_Interp.Append (No_Interp); + goto Next_Homograph; + + elsif Scope (H) /= Standard_Standard then + goto Next_Homograph; + end if; + end if; + end loop; + + -- On exit, we know that current homograph is not hidden + + Add_One_Interp (N, H, Etype (H)); + + if Debug_Flag_E then + Write_Str ("Add overloaded interpretation "); + Write_Int (Int (H)); + Write_Eol; + end if; + end if; + + <<Next_Homograph>> + H := Homonym (H); + end loop; + + -- Scan list of homographs for use-visible entities only + + H := Current_Entity (Ent); + + while Present (H) loop + if Is_Potentially_Use_Visible (H) + and then H /= Ent + and then Is_Overloadable (H) + then + for J in First_Interp .. All_Interp.Last - 1 loop + + if not Is_Immediately_Visible (All_Interp.Table (J).Nam) then + exit; + + elsif Type_Conformant (H, All_Interp.Table (J).Nam) then + goto Next_Use_Homograph; + end if; + end loop; + + Add_One_Interp (N, H, Etype (H)); + end if; + + <<Next_Use_Homograph>> + H := Homonym (H); + end loop; + end if; + + if All_Interp.Last = First_Interp + 1 then + + -- The final interpretation is in fact not overloaded. Note that the + -- unique legal interpretation may or may not be the original one, + -- so we need to update N's entity and etype now, because once N + -- is marked as not overloaded it is also expected to carry the + -- proper interpretation. + + Set_Is_Overloaded (N, False); + Set_Entity (N, All_Interp.Table (First_Interp).Nam); + Set_Etype (N, All_Interp.Table (First_Interp).Typ); + end if; + end Collect_Interps; + + ------------ + -- Covers -- + ------------ + + function Covers (T1, T2 : Entity_Id) return Boolean is + + BT1 : Entity_Id; + BT2 : Entity_Id; + + function Full_View_Covers (Typ1, Typ2 : Entity_Id) return Boolean; + -- In an instance the proper view may not always be correct for + -- private types, but private and full view are compatible. This + -- removes spurious errors from nested instantiations that involve, + -- among other things, types derived from private types. + + ---------------------- + -- Full_View_Covers -- + ---------------------- + + function Full_View_Covers (Typ1, Typ2 : Entity_Id) return Boolean is + begin + return + Is_Private_Type (Typ1) + and then + ((Present (Full_View (Typ1)) + and then Covers (Full_View (Typ1), Typ2)) + or else Base_Type (Typ1) = Typ2 + or else Base_Type (Typ2) = Typ1); + end Full_View_Covers; + + -- Start of processing for Covers + + begin + -- If either operand missing, then this is an error, but ignore it (and + -- pretend we have a cover) if errors already detected, since this may + -- simply mean we have malformed trees or a semantic error upstream. + + if No (T1) or else No (T2) then + if Total_Errors_Detected /= 0 then + return True; + else + raise Program_Error; + end if; + + else + BT1 := Base_Type (T1); + BT2 := Base_Type (T2); + + -- Handle underlying view of records with unknown discriminants + -- using the original entity that motivated the construction of + -- this underlying record view (see Build_Derived_Private_Type). + + if Is_Underlying_Record_View (BT1) then + BT1 := Underlying_Record_View (BT1); + end if; + + if Is_Underlying_Record_View (BT2) then + BT2 := Underlying_Record_View (BT2); + end if; + end if; + + -- First check for Standard_Void_Type, which is special. Subsequent + -- processing in this routine assumes T1 and T2 are bona fide types; + -- Standard_Void_Type is a special entity that has some, but not all, + -- properties of types. + + if (T1 = Standard_Void_Type) /= (T2 = Standard_Void_Type) then + return False; + + -- Simplest case: same types are compatible, and types that have the + -- same base type and are not generic actuals are compatible. Generic + -- actuals belong to their class but are not compatible with other + -- types of their class, and in particular with other generic actuals. + -- They are however compatible with their own subtypes, and itypes + -- with the same base are compatible as well. Similarly, constrained + -- subtypes obtained from expressions of an unconstrained nominal type + -- are compatible with the base type (may lead to spurious ambiguities + -- in obscure cases ???) + + -- Generic actuals require special treatment to avoid spurious ambi- + -- guities in an instance, when two formal types are instantiated with + -- the same actual, so that different subprograms end up with the same + -- signature in the instance. + + elsif T1 = T2 then + return True; + + elsif BT1 = BT2 + or else BT1 = T2 + or else BT2 = T1 + then + if not Is_Generic_Actual_Type (T1) then + return True; + else + return (not Is_Generic_Actual_Type (T2) + or else Is_Itype (T1) + or else Is_Itype (T2) + or else Is_Constr_Subt_For_U_Nominal (T1) + or else Is_Constr_Subt_For_U_Nominal (T2) + or else Scope (T1) /= Scope (T2)); + end if; + + -- Literals are compatible with types in a given "class" + + elsif (T2 = Universal_Integer and then Is_Integer_Type (T1)) + or else (T2 = Universal_Real and then Is_Real_Type (T1)) + or else (T2 = Universal_Fixed and then Is_Fixed_Point_Type (T1)) + or else (T2 = Any_Fixed and then Is_Fixed_Point_Type (T1)) + or else (T2 = Any_String and then Is_String_Type (T1)) + or else (T2 = Any_Character and then Is_Character_Type (T1)) + or else (T2 = Any_Access and then Is_Access_Type (T1)) + then + return True; + + -- The context may be class wide, and a class-wide type is compatible + -- with any member of the class. + + elsif Is_Class_Wide_Type (T1) + and then Is_Ancestor (Root_Type (T1), T2) + then + return True; + + elsif Is_Class_Wide_Type (T1) + and then Is_Class_Wide_Type (T2) + and then Base_Type (Etype (T1)) = Base_Type (Etype (T2)) + then + return True; + + -- Ada 2005 (AI-345): A class-wide abstract interface type covers a + -- task_type or protected_type that implements the interface. + + elsif Ada_Version >= Ada_2005 + and then Is_Class_Wide_Type (T1) + and then Is_Interface (Etype (T1)) + and then Is_Concurrent_Type (T2) + and then Interface_Present_In_Ancestor + (Typ => Base_Type (T2), + Iface => Etype (T1)) + then + return True; + + -- Ada 2005 (AI-251): A class-wide abstract interface type T1 covers an + -- object T2 implementing T1 + + elsif Ada_Version >= Ada_2005 + and then Is_Class_Wide_Type (T1) + and then Is_Interface (Etype (T1)) + and then Is_Tagged_Type (T2) + then + if Interface_Present_In_Ancestor (Typ => T2, + Iface => Etype (T1)) + then + return True; + end if; + + declare + E : Entity_Id; + Elmt : Elmt_Id; + + begin + if Is_Concurrent_Type (BT2) then + E := Corresponding_Record_Type (BT2); + else + E := BT2; + end if; + + -- Ada 2005 (AI-251): A class-wide abstract interface type T1 + -- covers an object T2 that implements a direct derivation of T1. + -- Note: test for presence of E is defense against previous error. + + if Present (E) + and then Present (Interfaces (E)) + then + Elmt := First_Elmt (Interfaces (E)); + while Present (Elmt) loop + if Is_Ancestor (Etype (T1), Node (Elmt)) then + return True; + end if; + + Next_Elmt (Elmt); + end loop; + end if; + + -- We should also check the case in which T1 is an ancestor of + -- some implemented interface??? + + return False; + end; + + -- In a dispatching call the actual may be class-wide, the formal + -- may be its specific type, or that of a descendent of it. + + elsif Is_Class_Wide_Type (T2) + and then + (Class_Wide_Type (T1) = T2 + or else Base_Type (Root_Type (T2)) = Base_Type (T1)) + then + return True; + + -- Some contexts require a class of types rather than a specific type. + -- For example, conditions require any boolean type, fixed point + -- attributes require some real type, etc. The built-in types Any_XXX + -- represent these classes. + + elsif (T1 = Any_Integer and then Is_Integer_Type (T2)) + or else (T1 = Any_Boolean and then Is_Boolean_Type (T2)) + or else (T1 = Any_Real and then Is_Real_Type (T2)) + or else (T1 = Any_Fixed and then Is_Fixed_Point_Type (T2)) + or else (T1 = Any_Discrete and then Is_Discrete_Type (T2)) + then + return True; + + -- An aggregate is compatible with an array or record type + + elsif T2 = Any_Composite + and then Is_Aggregate_Type (T1) + then + return True; + + -- If the expected type is an anonymous access, the designated type must + -- cover that of the expression. Use the base type for this check: even + -- though access subtypes are rare in sources, they are generated for + -- actuals in instantiations. + + elsif Ekind (BT1) = E_Anonymous_Access_Type + and then Is_Access_Type (T2) + and then Covers (Designated_Type (T1), Designated_Type (T2)) + then + return True; + + -- An Access_To_Subprogram is compatible with itself, or with an + -- anonymous type created for an attribute reference Access. + + elsif (Ekind (BT1) = E_Access_Subprogram_Type + or else + Ekind (BT1) = E_Access_Protected_Subprogram_Type) + and then Is_Access_Type (T2) + and then (not Comes_From_Source (T1) + or else not Comes_From_Source (T2)) + and then (Is_Overloadable (Designated_Type (T2)) + or else + Ekind (Designated_Type (T2)) = E_Subprogram_Type) + and then + Type_Conformant (Designated_Type (T1), Designated_Type (T2)) + and then + Mode_Conformant (Designated_Type (T1), Designated_Type (T2)) + then + return True; + + -- Ada 2005 (AI-254): An Anonymous_Access_To_Subprogram is compatible + -- with itself, or with an anonymous type created for an attribute + -- reference Access. + + elsif (Ekind (BT1) = E_Anonymous_Access_Subprogram_Type + or else + Ekind (BT1) + = E_Anonymous_Access_Protected_Subprogram_Type) + and then Is_Access_Type (T2) + and then (not Comes_From_Source (T1) + or else not Comes_From_Source (T2)) + and then (Is_Overloadable (Designated_Type (T2)) + or else + Ekind (Designated_Type (T2)) = E_Subprogram_Type) + and then + Type_Conformant (Designated_Type (T1), Designated_Type (T2)) + and then + Mode_Conformant (Designated_Type (T1), Designated_Type (T2)) + then + return True; + + -- The context can be a remote access type, and the expression the + -- corresponding source type declared in a categorized package, or + -- vice versa. + + elsif Is_Record_Type (T1) + and then (Is_Remote_Call_Interface (T1) + or else Is_Remote_Types (T1)) + and then Present (Corresponding_Remote_Type (T1)) + then + return Covers (Corresponding_Remote_Type (T1), T2); + + -- and conversely. + + elsif Is_Record_Type (T2) + and then (Is_Remote_Call_Interface (T2) + or else Is_Remote_Types (T2)) + and then Present (Corresponding_Remote_Type (T2)) + then + return Covers (Corresponding_Remote_Type (T2), T1); + + -- Synchronized types are represented at run time by their corresponding + -- record type. During expansion one is replaced with the other, but + -- they are compatible views of the same type. + + elsif Is_Record_Type (T1) + and then Is_Concurrent_Type (T2) + and then Present (Corresponding_Record_Type (T2)) + then + return Covers (T1, Corresponding_Record_Type (T2)); + + elsif Is_Concurrent_Type (T1) + and then Present (Corresponding_Record_Type (T1)) + and then Is_Record_Type (T2) + then + return Covers (Corresponding_Record_Type (T1), T2); + + -- During analysis, an attribute reference 'Access has a special type + -- kind: Access_Attribute_Type, to be replaced eventually with the type + -- imposed by context. + + elsif Ekind (T2) = E_Access_Attribute_Type + and then Ekind_In (BT1, E_General_Access_Type, E_Access_Type) + and then Covers (Designated_Type (T1), Designated_Type (T2)) + then + -- If the target type is a RACW type while the source is an access + -- attribute type, we are building a RACW that may be exported. + + if Is_Remote_Access_To_Class_Wide_Type (BT1) then + Set_Has_RACW (Current_Sem_Unit); + end if; + + return True; + + -- Ditto for allocators, which eventually resolve to the context type + + elsif Ekind (T2) = E_Allocator_Type + and then Is_Access_Type (T1) + then + return Covers (Designated_Type (T1), Designated_Type (T2)) + or else + (From_With_Type (Designated_Type (T1)) + and then Covers (Designated_Type (T2), Designated_Type (T1))); + + -- A boolean operation on integer literals is compatible with modular + -- context. + + elsif T2 = Any_Modular + and then Is_Modular_Integer_Type (T1) + then + return True; + + -- The actual type may be the result of a previous error + + elsif Base_Type (T2) = Any_Type then + return True; + + -- A packed array type covers its corresponding non-packed type. This is + -- not legitimate Ada, but allows the omission of a number of otherwise + -- useless unchecked conversions, and since this can only arise in + -- (known correct) expanded code, no harm is done. + + elsif Is_Array_Type (T2) + and then Is_Packed (T2) + and then T1 = Packed_Array_Type (T2) + then + return True; + + -- Similarly an array type covers its corresponding packed array type + + elsif Is_Array_Type (T1) + and then Is_Packed (T1) + and then T2 = Packed_Array_Type (T1) + then + return True; + + -- In instances, or with types exported from instantiations, check + -- whether a partial and a full view match. Verify that types are + -- legal, to prevent cascaded errors. + + elsif In_Instance + and then + (Full_View_Covers (T1, T2) + or else Full_View_Covers (T2, T1)) + then + return True; + + elsif Is_Type (T2) + and then Is_Generic_Actual_Type (T2) + and then Full_View_Covers (T1, T2) + then + return True; + + elsif Is_Type (T1) + and then Is_Generic_Actual_Type (T1) + and then Full_View_Covers (T2, T1) + then + return True; + + -- In the expansion of inlined bodies, types are compatible if they + -- are structurally equivalent. + + elsif In_Inlined_Body + and then (Underlying_Type (T1) = Underlying_Type (T2) + or else (Is_Access_Type (T1) + and then Is_Access_Type (T2) + and then + Designated_Type (T1) = Designated_Type (T2)) + or else (T1 = Any_Access + and then Is_Access_Type (Underlying_Type (T2))) + or else (T2 = Any_Composite + and then + Is_Composite_Type (Underlying_Type (T1)))) + then + return True; + + -- Ada 2005 (AI-50217): Additional branches to make the shadow entity + -- obtained through a limited_with compatible with its real entity. + + elsif From_With_Type (T1) then + + -- If the expected type is the non-limited view of a type, the + -- expression may have the limited view. If that one in turn is + -- incomplete, get full view if available. + + if Is_Incomplete_Type (T1) then + return Covers (Get_Full_View (Non_Limited_View (T1)), T2); + + elsif Ekind (T1) = E_Class_Wide_Type then + return + Covers (Class_Wide_Type (Non_Limited_View (Etype (T1))), T2); + else + return False; + end if; + + elsif From_With_Type (T2) then + + -- If units in the context have Limited_With clauses on each other, + -- either type might have a limited view. Checks performed elsewhere + -- verify that the context type is the nonlimited view. + + if Is_Incomplete_Type (T2) then + return Covers (T1, Get_Full_View (Non_Limited_View (T2))); + + elsif Ekind (T2) = E_Class_Wide_Type then + return + Present (Non_Limited_View (Etype (T2))) + and then + Covers (T1, Class_Wide_Type (Non_Limited_View (Etype (T2)))); + else + return False; + end if; + + -- Ada 2005 (AI-412): Coverage for regular incomplete subtypes + + elsif Ekind (T1) = E_Incomplete_Subtype then + return Covers (Full_View (Etype (T1)), T2); + + elsif Ekind (T2) = E_Incomplete_Subtype then + return Covers (T1, Full_View (Etype (T2))); + + -- Ada 2005 (AI-423): Coverage of formal anonymous access types + -- and actual anonymous access types in the context of generic + -- instantiations. We have the following situation: + + -- generic + -- type Formal is private; + -- Formal_Obj : access Formal; -- T1 + -- package G is ... + + -- package P is + -- type Actual is ... + -- Actual_Obj : access Actual; -- T2 + -- package Instance is new G (Formal => Actual, + -- Formal_Obj => Actual_Obj); + + elsif Ada_Version >= Ada_2005 + and then Ekind (T1) = E_Anonymous_Access_Type + and then Ekind (T2) = E_Anonymous_Access_Type + and then Is_Generic_Type (Directly_Designated_Type (T1)) + and then Get_Instance_Of (Directly_Designated_Type (T1)) = + Directly_Designated_Type (T2) + then + return True; + + -- Otherwise, types are not compatible! + + else + return False; + end if; + end Covers; + + ------------------ + -- Disambiguate -- + ------------------ + + function Disambiguate + (N : Node_Id; + I1, I2 : Interp_Index; + Typ : Entity_Id) return Interp + is + I : Interp_Index; + It : Interp; + It1, It2 : Interp; + Nam1, Nam2 : Entity_Id; + Predef_Subp : Entity_Id; + User_Subp : Entity_Id; + + function Inherited_From_Actual (S : Entity_Id) return Boolean; + -- Determine whether one of the candidates is an operation inherited by + -- a type that is derived from an actual in an instantiation. + + function Is_Actual_Subprogram (S : Entity_Id) return Boolean; + -- Determine whether a subprogram is an actual in an enclosing instance. + -- An overloading between such a subprogram and one declared outside the + -- instance is resolved in favor of the first, because it resolved in + -- the generic. + + function Matches (Actual, Formal : Node_Id) return Boolean; + -- Look for exact type match in an instance, to remove spurious + -- ambiguities when two formal types have the same actual. + + function Standard_Operator return Boolean; + -- Check whether subprogram is predefined operator declared in Standard. + -- It may given by an operator name, or by an expanded name whose prefix + -- is Standard. + + function Remove_Conversions return Interp; + -- Last chance for pathological cases involving comparisons on literals, + -- and user overloadings of the same operator. Such pathologies have + -- been removed from the ACVC, but still appear in two DEC tests, with + -- the following notable quote from Ben Brosgol: + -- + -- [Note: I disclaim all credit/responsibility/blame for coming up with + -- this example; Robert Dewar brought it to our attention, since it is + -- apparently found in the ACVC 1.5. I did not attempt to find the + -- reason in the Reference Manual that makes the example legal, since I + -- was too nauseated by it to want to pursue it further.] + -- + -- Accordingly, this is not a fully recursive solution, but it handles + -- DEC tests c460vsa, c460vsb. It also handles ai00136a, which pushes + -- pathology in the other direction with calls whose multiple overloaded + -- actuals make them truly unresolvable. + + -- The new rules concerning abstract operations create additional need + -- for special handling of expressions with universal operands, see + -- comments to Has_Abstract_Interpretation below. + + --------------------------- + -- Inherited_From_Actual -- + --------------------------- + + function Inherited_From_Actual (S : Entity_Id) return Boolean is + Par : constant Node_Id := Parent (S); + begin + if Nkind (Par) /= N_Full_Type_Declaration + or else Nkind (Type_Definition (Par)) /= N_Derived_Type_Definition + then + return False; + else + return Is_Entity_Name (Subtype_Indication (Type_Definition (Par))) + and then + Is_Generic_Actual_Type ( + Entity (Subtype_Indication (Type_Definition (Par)))); + end if; + end Inherited_From_Actual; + + -------------------------- + -- Is_Actual_Subprogram -- + -------------------------- + + function Is_Actual_Subprogram (S : Entity_Id) return Boolean is + begin + return In_Open_Scopes (Scope (S)) + and then + (Is_Generic_Instance (Scope (S)) + or else Is_Wrapper_Package (Scope (S))); + end Is_Actual_Subprogram; + + ------------- + -- Matches -- + ------------- + + function Matches (Actual, Formal : Node_Id) return Boolean is + T1 : constant Entity_Id := Etype (Actual); + T2 : constant Entity_Id := Etype (Formal); + begin + return T1 = T2 + or else + (Is_Numeric_Type (T2) + and then (T1 = Universal_Real or else T1 = Universal_Integer)); + end Matches; + + ------------------------ + -- Remove_Conversions -- + ------------------------ + + function Remove_Conversions return Interp is + I : Interp_Index; + It : Interp; + It1 : Interp; + F1 : Entity_Id; + Act1 : Node_Id; + Act2 : Node_Id; + + function Has_Abstract_Interpretation (N : Node_Id) return Boolean; + -- If an operation has universal operands the universal operation + -- is present among its interpretations. If there is an abstract + -- interpretation for the operator, with a numeric result, this + -- interpretation was already removed in sem_ch4, but the universal + -- one is still visible. We must rescan the list of operators and + -- remove the universal interpretation to resolve the ambiguity. + + --------------------------------- + -- Has_Abstract_Interpretation -- + --------------------------------- + + function Has_Abstract_Interpretation (N : Node_Id) return Boolean is + E : Entity_Id; + + begin + if Nkind (N) not in N_Op + or else Ada_Version < Ada_2005 + or else not Is_Overloaded (N) + or else No (Universal_Interpretation (N)) + then + return False; + + else + E := Get_Name_Entity_Id (Chars (N)); + while Present (E) loop + if Is_Overloadable (E) + and then Is_Abstract_Subprogram (E) + and then Is_Numeric_Type (Etype (E)) + then + return True; + else + E := Homonym (E); + end if; + end loop; + + -- Finally, if an operand of the binary operator is itself + -- an operator, recurse to see whether its own abstract + -- interpretation is responsible for the spurious ambiguity. + + if Nkind (N) in N_Binary_Op then + return Has_Abstract_Interpretation (Left_Opnd (N)) + or else Has_Abstract_Interpretation (Right_Opnd (N)); + + elsif Nkind (N) in N_Unary_Op then + return Has_Abstract_Interpretation (Right_Opnd (N)); + + else + return False; + end if; + end if; + end Has_Abstract_Interpretation; + + -- Start of processing for Remove_Conversions + + begin + It1 := No_Interp; + + Get_First_Interp (N, I, It); + while Present (It.Typ) loop + if not Is_Overloadable (It.Nam) then + return No_Interp; + end if; + + F1 := First_Formal (It.Nam); + + if No (F1) then + return It1; + + else + if Nkind (N) = N_Function_Call + or else Nkind (N) = N_Procedure_Call_Statement + then + Act1 := First_Actual (N); + + if Present (Act1) then + Act2 := Next_Actual (Act1); + else + Act2 := Empty; + end if; + + elsif Nkind (N) in N_Unary_Op then + Act1 := Right_Opnd (N); + Act2 := Empty; + + elsif Nkind (N) in N_Binary_Op then + Act1 := Left_Opnd (N); + Act2 := Right_Opnd (N); + + -- Use type of second formal, so as to include + -- exponentiation, where the exponent may be + -- ambiguous and the result non-universal. + + Next_Formal (F1); + + else + return It1; + end if; + + if Nkind (Act1) in N_Op + and then Is_Overloaded (Act1) + and then (Nkind (Right_Opnd (Act1)) = N_Integer_Literal + or else Nkind (Right_Opnd (Act1)) = N_Real_Literal) + and then Has_Compatible_Type (Act1, Standard_Boolean) + and then Etype (F1) = Standard_Boolean + then + -- If the two candidates are the original ones, the + -- ambiguity is real. Otherwise keep the original, further + -- calls to Disambiguate will take care of others in the + -- list of candidates. + + if It1 /= No_Interp then + if It = Disambiguate.It1 + or else It = Disambiguate.It2 + then + if It1 = Disambiguate.It1 + or else It1 = Disambiguate.It2 + then + return No_Interp; + else + It1 := It; + end if; + end if; + + elsif Present (Act2) + and then Nkind (Act2) in N_Op + and then Is_Overloaded (Act2) + and then Nkind_In (Right_Opnd (Act2), N_Integer_Literal, + N_Real_Literal) + and then Has_Compatible_Type (Act2, Standard_Boolean) + then + -- The preference rule on the first actual is not + -- sufficient to disambiguate. + + goto Next_Interp; + + else + It1 := It; + end if; + + elsif Is_Numeric_Type (Etype (F1)) + and then Has_Abstract_Interpretation (Act1) + then + -- Current interpretation is not the right one because it + -- expects a numeric operand. Examine all the other ones. + + declare + I : Interp_Index; + It : Interp; + + begin + Get_First_Interp (N, I, It); + while Present (It.Typ) loop + if + not Is_Numeric_Type (Etype (First_Formal (It.Nam))) + then + if No (Act2) + or else not Has_Abstract_Interpretation (Act2) + or else not + Is_Numeric_Type + (Etype (Next_Formal (First_Formal (It.Nam)))) + then + return It; + end if; + end if; + + Get_Next_Interp (I, It); + end loop; + + return No_Interp; + end; + end if; + end if; + + <<Next_Interp>> + Get_Next_Interp (I, It); + end loop; + + -- After some error, a formal may have Any_Type and yield a spurious + -- match. To avoid cascaded errors if possible, check for such a + -- formal in either candidate. + + if Serious_Errors_Detected > 0 then + declare + Formal : Entity_Id; + + begin + Formal := First_Formal (Nam1); + while Present (Formal) loop + if Etype (Formal) = Any_Type then + return Disambiguate.It2; + end if; + + Next_Formal (Formal); + end loop; + + Formal := First_Formal (Nam2); + while Present (Formal) loop + if Etype (Formal) = Any_Type then + return Disambiguate.It1; + end if; + + Next_Formal (Formal); + end loop; + end; + end if; + + return It1; + end Remove_Conversions; + + ----------------------- + -- Standard_Operator -- + ----------------------- + + function Standard_Operator return Boolean is + Nam : Node_Id; + + begin + if Nkind (N) in N_Op then + return True; + + elsif Nkind (N) = N_Function_Call then + Nam := Name (N); + + if Nkind (Nam) /= N_Expanded_Name then + return True; + else + return Entity (Prefix (Nam)) = Standard_Standard; + end if; + else + return False; + end if; + end Standard_Operator; + + -- Start of processing for Disambiguate + + begin + -- Recover the two legal interpretations + + Get_First_Interp (N, I, It); + while I /= I1 loop + Get_Next_Interp (I, It); + end loop; + + It1 := It; + Nam1 := It.Nam; + while I /= I2 loop + Get_Next_Interp (I, It); + end loop; + + It2 := It; + Nam2 := It.Nam; + + -- Check whether one of the entities is an Ada 2005/2012 and we are + -- operating in an earlier mode, in which case we discard the Ada + -- 2005/2012 entity, so that we get proper Ada 95 overload resolution. + + if Ada_Version < Ada_2005 then + if Is_Ada_2005_Only (Nam1) or else Is_Ada_2012_Only (Nam1) then + return It2; + elsif Is_Ada_2005_Only (Nam2) or else Is_Ada_2012_Only (Nam1) then + return It1; + end if; + end if; + + -- Check whether one of the entities is an Ada 2012 entity and we are + -- operating in Ada 2005 mode, in which case we discard the Ada 2012 + -- entity, so that we get proper Ada 2005 overload resolution. + + if Ada_Version = Ada_2005 then + if Is_Ada_2012_Only (Nam1) then + return It2; + elsif Is_Ada_2012_Only (Nam2) then + return It1; + end if; + end if; + + -- Check for overloaded CIL convention stuff because the CIL libraries + -- do sick things like Console.Write_Line where it matches two different + -- overloads, so just pick the first ??? + + if Convention (Nam1) = Convention_CIL + and then Convention (Nam2) = Convention_CIL + and then Ekind (Nam1) = Ekind (Nam2) + and then (Ekind (Nam1) = E_Procedure + or else Ekind (Nam1) = E_Function) + then + return It2; + end if; + + -- If the context is universal, the predefined operator is preferred. + -- This includes bounds in numeric type declarations, and expressions + -- in type conversions. If no interpretation yields a universal type, + -- then we must check whether the user-defined entity hides the prede- + -- fined one. + + if Chars (Nam1) in Any_Operator_Name + and then Standard_Operator + then + if Typ = Universal_Integer + or else Typ = Universal_Real + or else Typ = Any_Integer + or else Typ = Any_Discrete + or else Typ = Any_Real + or else Typ = Any_Type + then + -- Find an interpretation that yields the universal type, or else + -- a predefined operator that yields a predefined numeric type. + + declare + Candidate : Interp := No_Interp; + + begin + Get_First_Interp (N, I, It); + while Present (It.Typ) loop + if (Covers (Typ, It.Typ) + or else Typ = Any_Type) + and then + (It.Typ = Universal_Integer + or else It.Typ = Universal_Real) + then + return It; + + elsif Covers (Typ, It.Typ) + and then Scope (It.Typ) = Standard_Standard + and then Scope (It.Nam) = Standard_Standard + and then Is_Numeric_Type (It.Typ) + then + Candidate := It; + end if; + + Get_Next_Interp (I, It); + end loop; + + if Candidate /= No_Interp then + return Candidate; + end if; + end; + + elsif Chars (Nam1) /= Name_Op_Not + and then (Typ = Standard_Boolean or else Typ = Any_Boolean) + then + -- Equality or comparison operation. Choose predefined operator if + -- arguments are universal. The node may be an operator, name, or + -- a function call, so unpack arguments accordingly. + + declare + Arg1, Arg2 : Node_Id; + + begin + if Nkind (N) in N_Op then + Arg1 := Left_Opnd (N); + Arg2 := Right_Opnd (N); + + elsif Is_Entity_Name (N) then + Arg1 := First_Entity (Entity (N)); + Arg2 := Next_Entity (Arg1); + + else + Arg1 := First_Actual (N); + Arg2 := Next_Actual (Arg1); + end if; + + if Present (Arg2) + and then Present (Universal_Interpretation (Arg1)) + and then Universal_Interpretation (Arg2) = + Universal_Interpretation (Arg1) + then + Get_First_Interp (N, I, It); + while Scope (It.Nam) /= Standard_Standard loop + Get_Next_Interp (I, It); + end loop; + + return It; + end if; + end; + end if; + end if; + + -- If no universal interpretation, check whether user-defined operator + -- hides predefined one, as well as other special cases. If the node + -- is a range, then one or both bounds are ambiguous. Each will have + -- to be disambiguated w.r.t. the context type. The type of the range + -- itself is imposed by the context, so we can return either legal + -- interpretation. + + if Ekind (Nam1) = E_Operator then + Predef_Subp := Nam1; + User_Subp := Nam2; + + elsif Ekind (Nam2) = E_Operator then + Predef_Subp := Nam2; + User_Subp := Nam1; + + elsif Nkind (N) = N_Range then + return It1; + + -- Implement AI05-105: A renaming declaration with an access + -- definition must resolve to an anonymous access type. This + -- is a resolution rule and can be used to disambiguate. + + elsif Nkind (Parent (N)) = N_Object_Renaming_Declaration + and then Present (Access_Definition (Parent (N))) + then + if Ekind_In (It1.Typ, E_Anonymous_Access_Type, + E_Anonymous_Access_Subprogram_Type) + then + if Ekind (It2.Typ) = Ekind (It1.Typ) then + + -- True ambiguity + + return No_Interp; + + else + return It1; + end if; + + elsif Ekind_In (It2.Typ, E_Anonymous_Access_Type, + E_Anonymous_Access_Subprogram_Type) + then + return It2; + + -- No legal interpretation + + else + return No_Interp; + end if; + + -- If two user defined-subprograms are visible, it is a true ambiguity, + -- unless one of them is an entry and the context is a conditional or + -- timed entry call, or unless we are within an instance and this is + -- results from two formals types with the same actual. + + else + if Nkind (N) = N_Procedure_Call_Statement + and then Nkind (Parent (N)) = N_Entry_Call_Alternative + and then N = Entry_Call_Statement (Parent (N)) + then + if Ekind (Nam2) = E_Entry then + return It2; + elsif Ekind (Nam1) = E_Entry then + return It1; + else + return No_Interp; + end if; + + -- If the ambiguity occurs within an instance, it is due to several + -- formal types with the same actual. Look for an exact match between + -- the types of the formals of the overloadable entities, and the + -- actuals in the call, to recover the unambiguous match in the + -- original generic. + + -- The ambiguity can also be due to an overloading between a formal + -- subprogram and a subprogram declared outside the generic. If the + -- node is overloaded, it did not resolve to the global entity in + -- the generic, and we choose the formal subprogram. + + -- Finally, the ambiguity can be between an explicit subprogram and + -- one inherited (with different defaults) from an actual. In this + -- case the resolution was to the explicit declaration in the + -- generic, and remains so in the instance. + + elsif In_Instance + and then not In_Generic_Actual (N) + then + if Nkind (N) = N_Function_Call + or else Nkind (N) = N_Procedure_Call_Statement + then + declare + Actual : Node_Id; + Formal : Entity_Id; + Is_Act1 : constant Boolean := Is_Actual_Subprogram (Nam1); + Is_Act2 : constant Boolean := Is_Actual_Subprogram (Nam2); + + begin + if Is_Act1 and then not Is_Act2 then + return It1; + + elsif Is_Act2 and then not Is_Act1 then + return It2; + + elsif Inherited_From_Actual (Nam1) + and then Comes_From_Source (Nam2) + then + return It2; + + elsif Inherited_From_Actual (Nam2) + and then Comes_From_Source (Nam1) + then + return It1; + end if; + + Actual := First_Actual (N); + Formal := First_Formal (Nam1); + while Present (Actual) loop + if Etype (Actual) /= Etype (Formal) then + return It2; + end if; + + Next_Actual (Actual); + Next_Formal (Formal); + end loop; + + return It1; + end; + + elsif Nkind (N) in N_Binary_Op then + if Matches (Left_Opnd (N), First_Formal (Nam1)) + and then + Matches (Right_Opnd (N), Next_Formal (First_Formal (Nam1))) + then + return It1; + else + return It2; + end if; + + elsif Nkind (N) in N_Unary_Op then + if Etype (Right_Opnd (N)) = Etype (First_Formal (Nam1)) then + return It1; + else + return It2; + end if; + + else + return Remove_Conversions; + end if; + else + return Remove_Conversions; + end if; + end if; + + -- An implicit concatenation operator on a string type cannot be + -- disambiguated from the predefined concatenation. This can only + -- happen with concatenation of string literals. + + if Chars (User_Subp) = Name_Op_Concat + and then Ekind (User_Subp) = E_Operator + and then Is_String_Type (Etype (First_Formal (User_Subp))) + then + return No_Interp; + + -- If the user-defined operator is in an open scope, or in the scope + -- of the resulting type, or given by an expanded name that names its + -- scope, it hides the predefined operator for the type. Exponentiation + -- has to be special-cased because the implicit operator does not have + -- a symmetric signature, and may not be hidden by the explicit one. + + elsif (Nkind (N) = N_Function_Call + and then Nkind (Name (N)) = N_Expanded_Name + and then (Chars (Predef_Subp) /= Name_Op_Expon + or else Hides_Op (User_Subp, Predef_Subp)) + and then Scope (User_Subp) = Entity (Prefix (Name (N)))) + or else Hides_Op (User_Subp, Predef_Subp) + then + if It1.Nam = User_Subp then + return It1; + else + return It2; + end if; + + -- Otherwise, the predefined operator has precedence, or if the user- + -- defined operation is directly visible we have a true ambiguity. If + -- this is a fixed-point multiplication and division in Ada83 mode, + -- exclude the universal_fixed operator, which often causes ambiguities + -- in legacy code. + + else + if (In_Open_Scopes (Scope (User_Subp)) + or else Is_Potentially_Use_Visible (User_Subp)) + and then not In_Instance + then + if Is_Fixed_Point_Type (Typ) + and then (Chars (Nam1) = Name_Op_Multiply + or else Chars (Nam1) = Name_Op_Divide) + and then Ada_Version = Ada_83 + then + if It2.Nam = Predef_Subp then + return It1; + else + return It2; + end if; + + -- Ada 2005, AI-420: preference rule for "=" on Universal_Access + -- states that the operator defined in Standard is not available + -- if there is a user-defined equality with the proper signature, + -- declared in the same declarative list as the type. The node + -- may be an operator or a function call. + + elsif (Chars (Nam1) = Name_Op_Eq + or else + Chars (Nam1) = Name_Op_Ne) + and then Ada_Version >= Ada_2005 + and then Etype (User_Subp) = Standard_Boolean + then + declare + Opnd : Node_Id; + + begin + if Nkind (N) = N_Function_Call then + Opnd := First_Actual (N); + else + Opnd := Left_Opnd (N); + end if; + + if Ekind (Etype (Opnd)) = E_Anonymous_Access_Type + and then + In_Same_List (Parent (Designated_Type (Etype (Opnd))), + Unit_Declaration_Node (User_Subp)) + then + if It2.Nam = Predef_Subp then + return It1; + else + return It2; + end if; + else + return Remove_Conversions; + end if; + end; + + else + return No_Interp; + end if; + + elsif It1.Nam = Predef_Subp then + return It1; + + else + return It2; + end if; + end if; + end Disambiguate; + + --------------------- + -- End_Interp_List -- + --------------------- + + procedure End_Interp_List is + begin + All_Interp.Table (All_Interp.Last) := No_Interp; + All_Interp.Increment_Last; + end End_Interp_List; + + ------------------------- + -- Entity_Matches_Spec -- + ------------------------- + + function Entity_Matches_Spec (Old_S, New_S : Entity_Id) return Boolean is + begin + -- Simple case: same entity kinds, type conformance is required. A + -- parameterless function can also rename a literal. + + if Ekind (Old_S) = Ekind (New_S) + or else (Ekind (New_S) = E_Function + and then Ekind (Old_S) = E_Enumeration_Literal) + then + return Type_Conformant (New_S, Old_S); + + elsif Ekind (New_S) = E_Function + and then Ekind (Old_S) = E_Operator + then + return Operator_Matches_Spec (Old_S, New_S); + + elsif Ekind (New_S) = E_Procedure + and then Is_Entry (Old_S) + then + return Type_Conformant (New_S, Old_S); + + else + return False; + end if; + end Entity_Matches_Spec; + + ---------------------- + -- Find_Unique_Type -- + ---------------------- + + function Find_Unique_Type (L : Node_Id; R : Node_Id) return Entity_Id is + T : constant Entity_Id := Etype (L); + I : Interp_Index; + It : Interp; + TR : Entity_Id := Any_Type; + + begin + if Is_Overloaded (R) then + Get_First_Interp (R, I, It); + while Present (It.Typ) loop + if Covers (T, It.Typ) or else Covers (It.Typ, T) then + + -- If several interpretations are possible and L is universal, + -- apply preference rule. + + if TR /= Any_Type then + + if (T = Universal_Integer or else T = Universal_Real) + and then It.Typ = T + then + TR := It.Typ; + end if; + + else + TR := It.Typ; + end if; + end if; + + Get_Next_Interp (I, It); + end loop; + + Set_Etype (R, TR); + + -- In the non-overloaded case, the Etype of R is already set correctly + + else + null; + end if; + + -- If one of the operands is Universal_Fixed, the type of the other + -- operand provides the context. + + if Etype (R) = Universal_Fixed then + return T; + + elsif T = Universal_Fixed then + return Etype (R); + + -- Ada 2005 (AI-230): Support the following operators: + + -- function "=" (L, R : universal_access) return Boolean; + -- function "/=" (L, R : universal_access) return Boolean; + + -- Pool specific access types (E_Access_Type) are not covered by these + -- operators because of the legality rule of 4.5.2(9.2): "The operands + -- of the equality operators for universal_access shall be convertible + -- to one another (see 4.6)". For example, considering the type decla- + -- ration "type P is access Integer" and an anonymous access to Integer, + -- P is convertible to "access Integer" by 4.6 (24.11-24.15), but there + -- is no rule in 4.6 that allows "access Integer" to be converted to P. + + elsif Ada_Version >= Ada_2005 + and then + (Ekind (Etype (L)) = E_Anonymous_Access_Type + or else + Ekind (Etype (L)) = E_Anonymous_Access_Subprogram_Type) + and then Is_Access_Type (Etype (R)) + and then Ekind (Etype (R)) /= E_Access_Type + then + return Etype (L); + + elsif Ada_Version >= Ada_2005 + and then + (Ekind (Etype (R)) = E_Anonymous_Access_Type + or else Ekind (Etype (R)) = E_Anonymous_Access_Subprogram_Type) + and then Is_Access_Type (Etype (L)) + and then Ekind (Etype (L)) /= E_Access_Type + then + return Etype (R); + + else + return Specific_Type (T, Etype (R)); + end if; + end Find_Unique_Type; + + ------------------------------------- + -- Function_Interp_Has_Abstract_Op -- + ------------------------------------- + + function Function_Interp_Has_Abstract_Op + (N : Node_Id; + E : Entity_Id) return Entity_Id + is + Abstr_Op : Entity_Id; + Act : Node_Id; + Act_Parm : Node_Id; + Form_Parm : Node_Id; + + begin + -- Why is check on E needed below ??? + -- In any case this para needs comments ??? + + if Is_Overloaded (N) and then Is_Overloadable (E) then + Act_Parm := First_Actual (N); + Form_Parm := First_Formal (E); + while Present (Act_Parm) + and then Present (Form_Parm) + loop + Act := Act_Parm; + + if Nkind (Act) = N_Parameter_Association then + Act := Explicit_Actual_Parameter (Act); + end if; + + Abstr_Op := Has_Abstract_Op (Act, Etype (Form_Parm)); + + if Present (Abstr_Op) then + return Abstr_Op; + end if; + + Next_Actual (Act_Parm); + Next_Formal (Form_Parm); + end loop; + end if; + + return Empty; + end Function_Interp_Has_Abstract_Op; + + ---------------------- + -- Get_First_Interp -- + ---------------------- + + procedure Get_First_Interp + (N : Node_Id; + I : out Interp_Index; + It : out Interp) + is + Int_Ind : Interp_Index; + Map_Ptr : Int; + O_N : Node_Id; + + begin + -- If a selected component is overloaded because the selector has + -- multiple interpretations, the node is a call to a protected + -- operation or an indirect call. Retrieve the interpretation from + -- the selector name. The selected component may be overloaded as well + -- if the prefix is overloaded. That case is unchanged. + + if Nkind (N) = N_Selected_Component + and then Is_Overloaded (Selector_Name (N)) + then + O_N := Selector_Name (N); + else + O_N := N; + end if; + + Map_Ptr := Headers (Hash (O_N)); + while Map_Ptr /= No_Entry loop + if Interp_Map.Table (Map_Ptr).Node = O_N then + Int_Ind := Interp_Map.Table (Map_Ptr).Index; + It := All_Interp.Table (Int_Ind); + I := Int_Ind; + return; + else + Map_Ptr := Interp_Map.Table (Map_Ptr).Next; + end if; + end loop; + + -- Procedure should never be called if the node has no interpretations + + raise Program_Error; + end Get_First_Interp; + + --------------------- + -- Get_Next_Interp -- + --------------------- + + procedure Get_Next_Interp (I : in out Interp_Index; It : out Interp) is + begin + I := I + 1; + It := All_Interp.Table (I); + end Get_Next_Interp; + + ------------------------- + -- Has_Compatible_Type -- + ------------------------- + + function Has_Compatible_Type + (N : Node_Id; + Typ : Entity_Id) return Boolean + is + I : Interp_Index; + It : Interp; + + begin + if N = Error then + return False; + end if; + + if Nkind (N) = N_Subtype_Indication + or else not Is_Overloaded (N) + then + return + Covers (Typ, Etype (N)) + + -- Ada 2005 (AI-345): The context may be a synchronized interface. + -- If the type is already frozen use the corresponding_record + -- to check whether it is a proper descendant. + + or else + (Is_Record_Type (Typ) + and then Is_Concurrent_Type (Etype (N)) + and then Present (Corresponding_Record_Type (Etype (N))) + and then Covers (Typ, Corresponding_Record_Type (Etype (N)))) + + or else + (Is_Concurrent_Type (Typ) + and then Is_Record_Type (Etype (N)) + and then Present (Corresponding_Record_Type (Typ)) + and then Covers (Corresponding_Record_Type (Typ), Etype (N))) + + or else + (not Is_Tagged_Type (Typ) + and then Ekind (Typ) /= E_Anonymous_Access_Type + and then Covers (Etype (N), Typ)); + + else + Get_First_Interp (N, I, It); + while Present (It.Typ) loop + if (Covers (Typ, It.Typ) + and then + (Scope (It.Nam) /= Standard_Standard + or else not Is_Invisible_Operator (N, Base_Type (Typ)))) + + -- Ada 2005 (AI-345) + + or else + (Is_Concurrent_Type (It.Typ) + and then Present (Corresponding_Record_Type + (Etype (It.Typ))) + and then Covers (Typ, Corresponding_Record_Type + (Etype (It.Typ)))) + + or else (not Is_Tagged_Type (Typ) + and then Ekind (Typ) /= E_Anonymous_Access_Type + and then Covers (It.Typ, Typ)) + then + return True; + end if; + + Get_Next_Interp (I, It); + end loop; + + return False; + end if; + end Has_Compatible_Type; + + --------------------- + -- Has_Abstract_Op -- + --------------------- + + function Has_Abstract_Op + (N : Node_Id; + Typ : Entity_Id) return Entity_Id + is + I : Interp_Index; + It : Interp; + + begin + if Is_Overloaded (N) then + Get_First_Interp (N, I, It); + while Present (It.Nam) loop + if Present (It.Abstract_Op) + and then Etype (It.Abstract_Op) = Typ + then + return It.Abstract_Op; + end if; + + Get_Next_Interp (I, It); + end loop; + end if; + + return Empty; + end Has_Abstract_Op; + + ---------- + -- Hash -- + ---------- + + function Hash (N : Node_Id) return Int is + begin + -- Nodes have a size that is power of two, so to select significant + -- bits only we remove the low-order bits. + + return ((Int (N) / 2 ** 5) mod Header_Size); + end Hash; + + -------------- + -- Hides_Op -- + -------------- + + function Hides_Op (F : Entity_Id; Op : Entity_Id) return Boolean is + Btyp : constant Entity_Id := Base_Type (Etype (First_Formal (F))); + begin + return Operator_Matches_Spec (Op, F) + and then (In_Open_Scopes (Scope (F)) + or else Scope (F) = Scope (Btyp) + or else (not In_Open_Scopes (Scope (Btyp)) + and then not In_Use (Btyp) + and then not In_Use (Scope (Btyp)))); + end Hides_Op; + + ------------------------ + -- Init_Interp_Tables -- + ------------------------ + + procedure Init_Interp_Tables is + begin + All_Interp.Init; + Interp_Map.Init; + Headers := (others => No_Entry); + end Init_Interp_Tables; + + ----------------------------------- + -- Interface_Present_In_Ancestor -- + ----------------------------------- + + function Interface_Present_In_Ancestor + (Typ : Entity_Id; + Iface : Entity_Id) return Boolean + is + Target_Typ : Entity_Id; + Iface_Typ : Entity_Id; + + function Iface_Present_In_Ancestor (Typ : Entity_Id) return Boolean; + -- Returns True if Typ or some ancestor of Typ implements Iface + + ------------------------------- + -- Iface_Present_In_Ancestor -- + ------------------------------- + + function Iface_Present_In_Ancestor (Typ : Entity_Id) return Boolean is + E : Entity_Id; + AI : Entity_Id; + Elmt : Elmt_Id; + + begin + if Typ = Iface_Typ then + return True; + end if; + + -- Handle private types + + if Present (Full_View (Typ)) + and then not Is_Concurrent_Type (Full_View (Typ)) + then + E := Full_View (Typ); + else + E := Typ; + end if; + + loop + if Present (Interfaces (E)) + and then Present (Interfaces (E)) + and then not Is_Empty_Elmt_List (Interfaces (E)) + then + Elmt := First_Elmt (Interfaces (E)); + while Present (Elmt) loop + AI := Node (Elmt); + + if AI = Iface_Typ or else Is_Ancestor (Iface_Typ, AI) then + return True; + end if; + + Next_Elmt (Elmt); + end loop; + end if; + + exit when Etype (E) = E + + -- Handle private types + + or else (Present (Full_View (Etype (E))) + and then Full_View (Etype (E)) = E); + + -- Check if the current type is a direct derivation of the + -- interface + + if Etype (E) = Iface_Typ then + return True; + end if; + + -- Climb to the immediate ancestor handling private types + + if Present (Full_View (Etype (E))) then + E := Full_View (Etype (E)); + else + E := Etype (E); + end if; + end loop; + + return False; + end Iface_Present_In_Ancestor; + + -- Start of processing for Interface_Present_In_Ancestor + + begin + -- Iface might be a class-wide subtype, so we have to apply Base_Type + + if Is_Class_Wide_Type (Iface) then + Iface_Typ := Etype (Base_Type (Iface)); + else + Iface_Typ := Iface; + end if; + + -- Handle subtypes + + Iface_Typ := Base_Type (Iface_Typ); + + if Is_Access_Type (Typ) then + Target_Typ := Etype (Directly_Designated_Type (Typ)); + else + Target_Typ := Typ; + end if; + + if Is_Concurrent_Record_Type (Target_Typ) then + Target_Typ := Corresponding_Concurrent_Type (Target_Typ); + end if; + + Target_Typ := Base_Type (Target_Typ); + + -- In case of concurrent types we can't use the Corresponding Record_Typ + -- to look for the interface because it is built by the expander (and + -- hence it is not always available). For this reason we traverse the + -- list of interfaces (available in the parent of the concurrent type) + + if Is_Concurrent_Type (Target_Typ) then + if Present (Interface_List (Parent (Target_Typ))) then + declare + AI : Node_Id; + + begin + AI := First (Interface_List (Parent (Target_Typ))); + while Present (AI) loop + if Etype (AI) = Iface_Typ then + return True; + + elsif Present (Interfaces (Etype (AI))) + and then Iface_Present_In_Ancestor (Etype (AI)) + then + return True; + end if; + + Next (AI); + end loop; + end; + end if; + + return False; + end if; + + if Is_Class_Wide_Type (Target_Typ) then + Target_Typ := Etype (Target_Typ); + end if; + + if Ekind (Target_Typ) = E_Incomplete_Type then + pragma Assert (Present (Non_Limited_View (Target_Typ))); + Target_Typ := Non_Limited_View (Target_Typ); + + -- Protect the frontend against previously detected errors + + if Ekind (Target_Typ) = E_Incomplete_Type then + return False; + end if; + end if; + + return Iface_Present_In_Ancestor (Target_Typ); + end Interface_Present_In_Ancestor; + + --------------------- + -- Intersect_Types -- + --------------------- + + function Intersect_Types (L, R : Node_Id) return Entity_Id is + Index : Interp_Index; + It : Interp; + Typ : Entity_Id; + + function Check_Right_Argument (T : Entity_Id) return Entity_Id; + -- Find interpretation of right arg that has type compatible with T + + -------------------------- + -- Check_Right_Argument -- + -------------------------- + + function Check_Right_Argument (T : Entity_Id) return Entity_Id is + Index : Interp_Index; + It : Interp; + T2 : Entity_Id; + + begin + if not Is_Overloaded (R) then + return Specific_Type (T, Etype (R)); + + else + Get_First_Interp (R, Index, It); + loop + T2 := Specific_Type (T, It.Typ); + + if T2 /= Any_Type then + return T2; + end if; + + Get_Next_Interp (Index, It); + exit when No (It.Typ); + end loop; + + return Any_Type; + end if; + end Check_Right_Argument; + + -- Start of processing for Intersect_Types + + begin + if Etype (L) = Any_Type or else Etype (R) = Any_Type then + return Any_Type; + end if; + + if not Is_Overloaded (L) then + Typ := Check_Right_Argument (Etype (L)); + + else + Typ := Any_Type; + Get_First_Interp (L, Index, It); + while Present (It.Typ) loop + Typ := Check_Right_Argument (It.Typ); + exit when Typ /= Any_Type; + Get_Next_Interp (Index, It); + end loop; + + end if; + + -- If Typ is Any_Type, it means no compatible pair of types was found + + if Typ = Any_Type then + if Nkind (Parent (L)) in N_Op then + Error_Msg_N ("incompatible types for operator", Parent (L)); + + elsif Nkind (Parent (L)) = N_Range then + Error_Msg_N ("incompatible types given in constraint", Parent (L)); + + -- Ada 2005 (AI-251): Complete the error notification + + elsif Is_Class_Wide_Type (Etype (R)) + and then Is_Interface (Etype (Class_Wide_Type (Etype (R)))) + then + Error_Msg_NE ("(Ada 2005) does not implement interface }", + L, Etype (Class_Wide_Type (Etype (R)))); + + else + Error_Msg_N ("incompatible types", Parent (L)); + end if; + end if; + + return Typ; + end Intersect_Types; + + ----------------------- + -- In_Generic_Actual -- + ----------------------- + + function In_Generic_Actual (Exp : Node_Id) return Boolean is + Par : constant Node_Id := Parent (Exp); + + begin + if No (Par) then + return False; + + elsif Nkind (Par) in N_Declaration then + if Nkind (Par) = N_Object_Declaration then + return Present (Corresponding_Generic_Association (Par)); + else + return False; + end if; + + elsif Nkind (Par) = N_Object_Renaming_Declaration then + return Present (Corresponding_Generic_Association (Par)); + + elsif Nkind (Par) in N_Statement_Other_Than_Procedure_Call then + return False; + + else + return In_Generic_Actual (Parent (Par)); + end if; + end In_Generic_Actual; + + ----------------- + -- Is_Ancestor -- + ----------------- + + function Is_Ancestor (T1, T2 : Entity_Id) return Boolean is + BT1 : Entity_Id; + BT2 : Entity_Id; + Par : Entity_Id; + + begin + BT1 := Base_Type (T1); + BT2 := Base_Type (T2); + + -- Handle underlying view of records with unknown discriminants using + -- the original entity that motivated the construction of this + -- underlying record view (see Build_Derived_Private_Type). + + if Is_Underlying_Record_View (BT1) then + BT1 := Underlying_Record_View (BT1); + end if; + + if Is_Underlying_Record_View (BT2) then + BT2 := Underlying_Record_View (BT2); + end if; + + if BT1 = BT2 then + return True; + + -- The predicate must look past privacy + + elsif Is_Private_Type (T1) + and then Present (Full_View (T1)) + and then BT2 = Base_Type (Full_View (T1)) + then + return True; + + elsif Is_Private_Type (T2) + and then Present (Full_View (T2)) + and then BT1 = Base_Type (Full_View (T2)) + then + return True; + + else + Par := Etype (BT2); + + loop + -- If there was a error on the type declaration, do not recurse + + if Error_Posted (Par) then + return False; + + elsif BT1 = Base_Type (Par) + or else (Is_Private_Type (T1) + and then Present (Full_View (T1)) + and then Base_Type (Par) = Base_Type (Full_View (T1))) + then + return True; + + elsif Is_Private_Type (Par) + and then Present (Full_View (Par)) + and then Full_View (Par) = BT1 + then + return True; + + elsif Etype (Par) /= Par then + + -- If this is a private type and its parent is an interface + -- then use the parent of the full view (which is a type that + -- implements such interface) + + if Is_Private_Type (Par) + and then Is_Interface (Etype (Par)) + and then Present (Full_View (Par)) + then + Par := Etype (Full_View (Par)); + else + Par := Etype (Par); + end if; + + -- For all other cases return False, not an Ancestor + + else + return False; + end if; + end loop; + end if; + end Is_Ancestor; + + --------------------------- + -- Is_Invisible_Operator -- + --------------------------- + + function Is_Invisible_Operator + (N : Node_Id; + T : Entity_Id) return Boolean + is + Orig_Node : constant Node_Id := Original_Node (N); + + begin + if Nkind (N) not in N_Op then + return False; + + elsif not Comes_From_Source (N) then + return False; + + elsif No (Universal_Interpretation (Right_Opnd (N))) then + return False; + + elsif Nkind (N) in N_Binary_Op + and then No (Universal_Interpretation (Left_Opnd (N))) + then + return False; + + else + return Is_Numeric_Type (T) + and then not In_Open_Scopes (Scope (T)) + and then not Is_Potentially_Use_Visible (T) + and then not In_Use (T) + and then not In_Use (Scope (T)) + and then + (Nkind (Orig_Node) /= N_Function_Call + or else Nkind (Name (Orig_Node)) /= N_Expanded_Name + or else Entity (Prefix (Name (Orig_Node))) /= Scope (T)) + and then not In_Instance; + end if; + end Is_Invisible_Operator; + + -------------------- + -- Is_Progenitor -- + -------------------- + + function Is_Progenitor + (Iface : Entity_Id; + Typ : Entity_Id) return Boolean + is + begin + return Implements_Interface (Typ, Iface, Exclude_Parents => True); + end Is_Progenitor; + + ------------------- + -- Is_Subtype_Of -- + ------------------- + + function Is_Subtype_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean is + S : Entity_Id; + + begin + S := Ancestor_Subtype (T1); + while Present (S) loop + if S = T2 then + return True; + else + S := Ancestor_Subtype (S); + end if; + end loop; + + return False; + end Is_Subtype_Of; + + ------------------ + -- List_Interps -- + ------------------ + + procedure List_Interps (Nam : Node_Id; Err : Node_Id) is + Index : Interp_Index; + It : Interp; + + begin + Get_First_Interp (Nam, Index, It); + while Present (It.Nam) loop + if Scope (It.Nam) = Standard_Standard + and then Scope (It.Typ) /= Standard_Standard + then + Error_Msg_Sloc := Sloc (Parent (It.Typ)); + Error_Msg_NE ("\\& (inherited) declared#!", Err, It.Nam); + + else + Error_Msg_Sloc := Sloc (It.Nam); + Error_Msg_NE ("\\& declared#!", Err, It.Nam); + end if; + + Get_Next_Interp (Index, It); + end loop; + end List_Interps; + + ----------------- + -- New_Interps -- + ----------------- + + procedure New_Interps (N : Node_Id) is + Map_Ptr : Int; + + begin + All_Interp.Append (No_Interp); + + Map_Ptr := Headers (Hash (N)); + + if Map_Ptr = No_Entry then + + -- Place new node at end of table + + Interp_Map.Increment_Last; + Headers (Hash (N)) := Interp_Map.Last; + + else + -- Place node at end of chain, or locate its previous entry + + loop + if Interp_Map.Table (Map_Ptr).Node = N then + + -- Node is already in the table, and is being rewritten. + -- Start a new interp section, retain hash link. + + Interp_Map.Table (Map_Ptr).Node := N; + Interp_Map.Table (Map_Ptr).Index := All_Interp.Last; + Set_Is_Overloaded (N, True); + return; + + else + exit when Interp_Map.Table (Map_Ptr).Next = No_Entry; + Map_Ptr := Interp_Map.Table (Map_Ptr).Next; + end if; + end loop; + + -- Chain the new node + + Interp_Map.Increment_Last; + Interp_Map.Table (Map_Ptr).Next := Interp_Map.Last; + end if; + + Interp_Map.Table (Interp_Map.Last) := (N, All_Interp.Last, No_Entry); + Set_Is_Overloaded (N, True); + end New_Interps; + + --------------------------- + -- Operator_Matches_Spec -- + --------------------------- + + function Operator_Matches_Spec (Op, New_S : Entity_Id) return Boolean is + Op_Name : constant Name_Id := Chars (Op); + T : constant Entity_Id := Etype (New_S); + New_F : Entity_Id; + Old_F : Entity_Id; + Num : Int; + T1 : Entity_Id; + T2 : Entity_Id; + + begin + -- To verify that a predefined operator matches a given signature, + -- do a case analysis of the operator classes. Function can have one + -- or two formals and must have the proper result type. + + New_F := First_Formal (New_S); + Old_F := First_Formal (Op); + Num := 0; + while Present (New_F) and then Present (Old_F) loop + Num := Num + 1; + Next_Formal (New_F); + Next_Formal (Old_F); + end loop; + + -- Definite mismatch if different number of parameters + + if Present (Old_F) or else Present (New_F) then + return False; + + -- Unary operators + + elsif Num = 1 then + T1 := Etype (First_Formal (New_S)); + + if Op_Name = Name_Op_Subtract + or else Op_Name = Name_Op_Add + or else Op_Name = Name_Op_Abs + then + return Base_Type (T1) = Base_Type (T) + and then Is_Numeric_Type (T); + + elsif Op_Name = Name_Op_Not then + return Base_Type (T1) = Base_Type (T) + and then Valid_Boolean_Arg (Base_Type (T)); + + else + return False; + end if; + + -- Binary operators + + else + T1 := Etype (First_Formal (New_S)); + T2 := Etype (Next_Formal (First_Formal (New_S))); + + if Op_Name = Name_Op_And or else Op_Name = Name_Op_Or + or else Op_Name = Name_Op_Xor + then + return Base_Type (T1) = Base_Type (T2) + and then Base_Type (T1) = Base_Type (T) + and then Valid_Boolean_Arg (Base_Type (T)); + + elsif Op_Name = Name_Op_Eq or else Op_Name = Name_Op_Ne then + return Base_Type (T1) = Base_Type (T2) + and then not Is_Limited_Type (T1) + and then Is_Boolean_Type (T); + + elsif Op_Name = Name_Op_Lt or else Op_Name = Name_Op_Le + or else Op_Name = Name_Op_Gt or else Op_Name = Name_Op_Ge + then + return Base_Type (T1) = Base_Type (T2) + and then Valid_Comparison_Arg (T1) + and then Is_Boolean_Type (T); + + elsif Op_Name = Name_Op_Add or else Op_Name = Name_Op_Subtract then + return Base_Type (T1) = Base_Type (T2) + and then Base_Type (T1) = Base_Type (T) + and then Is_Numeric_Type (T); + + -- For division and multiplication, a user-defined function does not + -- match the predefined universal_fixed operation, except in Ada 83. + + elsif Op_Name = Name_Op_Divide then + return (Base_Type (T1) = Base_Type (T2) + and then Base_Type (T1) = Base_Type (T) + and then Is_Numeric_Type (T) + and then (not Is_Fixed_Point_Type (T) + or else Ada_Version = Ada_83)) + + -- Mixed_Mode operations on fixed-point types + + or else (Base_Type (T1) = Base_Type (T) + and then Base_Type (T2) = Base_Type (Standard_Integer) + and then Is_Fixed_Point_Type (T)) + + -- A user defined operator can also match (and hide) a mixed + -- operation on universal literals. + + or else (Is_Integer_Type (T2) + and then Is_Floating_Point_Type (T1) + and then Base_Type (T1) = Base_Type (T)); + + elsif Op_Name = Name_Op_Multiply then + return (Base_Type (T1) = Base_Type (T2) + and then Base_Type (T1) = Base_Type (T) + and then Is_Numeric_Type (T) + and then (not Is_Fixed_Point_Type (T) + or else Ada_Version = Ada_83)) + + -- Mixed_Mode operations on fixed-point types + + or else (Base_Type (T1) = Base_Type (T) + and then Base_Type (T2) = Base_Type (Standard_Integer) + and then Is_Fixed_Point_Type (T)) + + or else (Base_Type (T2) = Base_Type (T) + and then Base_Type (T1) = Base_Type (Standard_Integer) + and then Is_Fixed_Point_Type (T)) + + or else (Is_Integer_Type (T2) + and then Is_Floating_Point_Type (T1) + and then Base_Type (T1) = Base_Type (T)) + + or else (Is_Integer_Type (T1) + and then Is_Floating_Point_Type (T2) + and then Base_Type (T2) = Base_Type (T)); + + elsif Op_Name = Name_Op_Mod or else Op_Name = Name_Op_Rem then + return Base_Type (T1) = Base_Type (T2) + and then Base_Type (T1) = Base_Type (T) + and then Is_Integer_Type (T); + + elsif Op_Name = Name_Op_Expon then + return Base_Type (T1) = Base_Type (T) + and then Is_Numeric_Type (T) + and then Base_Type (T2) = Base_Type (Standard_Integer); + + elsif Op_Name = Name_Op_Concat then + return Is_Array_Type (T) + and then (Base_Type (T) = Base_Type (Etype (Op))) + and then (Base_Type (T1) = Base_Type (T) + or else + Base_Type (T1) = Base_Type (Component_Type (T))) + and then (Base_Type (T2) = Base_Type (T) + or else + Base_Type (T2) = Base_Type (Component_Type (T))); + + else + return False; + end if; + end if; + end Operator_Matches_Spec; + + ------------------- + -- Remove_Interp -- + ------------------- + + procedure Remove_Interp (I : in out Interp_Index) is + II : Interp_Index; + + begin + -- Find end of interp list and copy downward to erase the discarded one + + II := I + 1; + while Present (All_Interp.Table (II).Typ) loop + II := II + 1; + end loop; + + for J in I + 1 .. II loop + All_Interp.Table (J - 1) := All_Interp.Table (J); + end loop; + + -- Back up interp index to insure that iterator will pick up next + -- available interpretation. + + I := I - 1; + end Remove_Interp; + + ------------------ + -- Save_Interps -- + ------------------ + + procedure Save_Interps (Old_N : Node_Id; New_N : Node_Id) is + Map_Ptr : Int; + O_N : Node_Id := Old_N; + + begin + if Is_Overloaded (Old_N) then + if Nkind (Old_N) = N_Selected_Component + and then Is_Overloaded (Selector_Name (Old_N)) + then + O_N := Selector_Name (Old_N); + end if; + + Map_Ptr := Headers (Hash (O_N)); + + while Interp_Map.Table (Map_Ptr).Node /= O_N loop + Map_Ptr := Interp_Map.Table (Map_Ptr).Next; + pragma Assert (Map_Ptr /= No_Entry); + end loop; + + New_Interps (New_N); + Interp_Map.Table (Interp_Map.Last).Index := + Interp_Map.Table (Map_Ptr).Index; + end if; + end Save_Interps; + + ------------------- + -- Specific_Type -- + ------------------- + + function Specific_Type (Typ_1, Typ_2 : Entity_Id) return Entity_Id is + T1 : constant Entity_Id := Available_View (Typ_1); + T2 : constant Entity_Id := Available_View (Typ_2); + B1 : constant Entity_Id := Base_Type (T1); + B2 : constant Entity_Id := Base_Type (T2); + + function Is_Remote_Access (T : Entity_Id) return Boolean; + -- Check whether T is the equivalent type of a remote access type. + -- If distribution is enabled, T is a legal context for Null. + + ---------------------- + -- Is_Remote_Access -- + ---------------------- + + function Is_Remote_Access (T : Entity_Id) return Boolean is + begin + return Is_Record_Type (T) + and then (Is_Remote_Call_Interface (T) + or else Is_Remote_Types (T)) + and then Present (Corresponding_Remote_Type (T)) + and then Is_Access_Type (Corresponding_Remote_Type (T)); + end Is_Remote_Access; + + -- Start of processing for Specific_Type + + begin + if T1 = Any_Type or else T2 = Any_Type then + return Any_Type; + end if; + + if B1 = B2 then + return B1; + + elsif (T1 = Universal_Integer and then Is_Integer_Type (T2)) + or else (T1 = Universal_Real and then Is_Real_Type (T2)) + or else (T1 = Universal_Fixed and then Is_Fixed_Point_Type (T2)) + or else (T1 = Any_Fixed and then Is_Fixed_Point_Type (T2)) + then + return B2; + + elsif (T2 = Universal_Integer and then Is_Integer_Type (T1)) + or else (T2 = Universal_Real and then Is_Real_Type (T1)) + or else (T2 = Universal_Fixed and then Is_Fixed_Point_Type (T1)) + or else (T2 = Any_Fixed and then Is_Fixed_Point_Type (T1)) + then + return B1; + + elsif T2 = Any_String and then Is_String_Type (T1) then + return B1; + + elsif T1 = Any_String and then Is_String_Type (T2) then + return B2; + + elsif T2 = Any_Character and then Is_Character_Type (T1) then + return B1; + + elsif T1 = Any_Character and then Is_Character_Type (T2) then + return B2; + + elsif T1 = Any_Access + and then (Is_Access_Type (T2) or else Is_Remote_Access (T2)) + then + return T2; + + elsif T2 = Any_Access + and then (Is_Access_Type (T1) or else Is_Remote_Access (T1)) + then + return T1; + + elsif T2 = Any_Composite + and then Is_Aggregate_Type (T1) + then + return T1; + + elsif T1 = Any_Composite + and then Is_Aggregate_Type (T2) + then + return T2; + + elsif T1 = Any_Modular and then Is_Modular_Integer_Type (T2) then + return T2; + + elsif T2 = Any_Modular and then Is_Modular_Integer_Type (T1) then + return T1; + + -- ---------------------------------------------------------- + -- Special cases for equality operators (all other predefined + -- operators can never apply to tagged types) + -- ---------------------------------------------------------- + + -- Ada 2005 (AI-251): T1 and T2 are class-wide types, and T2 is an + -- interface + + elsif Is_Class_Wide_Type (T1) + and then Is_Class_Wide_Type (T2) + and then Is_Interface (Etype (T2)) + then + return T1; + + -- Ada 2005 (AI-251): T1 is a concrete type that implements the + -- class-wide interface T2 + + elsif Is_Class_Wide_Type (T2) + and then Is_Interface (Etype (T2)) + and then Interface_Present_In_Ancestor (Typ => T1, + Iface => Etype (T2)) + then + return T1; + + elsif Is_Class_Wide_Type (T1) + and then Is_Ancestor (Root_Type (T1), T2) + then + return T1; + + elsif Is_Class_Wide_Type (T2) + and then Is_Ancestor (Root_Type (T2), T1) + then + return T2; + + elsif (Ekind (B1) = E_Access_Subprogram_Type + or else + Ekind (B1) = E_Access_Protected_Subprogram_Type) + and then Ekind (Designated_Type (B1)) /= E_Subprogram_Type + and then Is_Access_Type (T2) + then + return T2; + + elsif (Ekind (B2) = E_Access_Subprogram_Type + or else + Ekind (B2) = E_Access_Protected_Subprogram_Type) + and then Ekind (Designated_Type (B2)) /= E_Subprogram_Type + and then Is_Access_Type (T1) + then + return T1; + + elsif (Ekind (T1) = E_Allocator_Type + or else Ekind (T1) = E_Access_Attribute_Type + or else Ekind (T1) = E_Anonymous_Access_Type) + and then Is_Access_Type (T2) + then + return T2; + + elsif (Ekind (T2) = E_Allocator_Type + or else Ekind (T2) = E_Access_Attribute_Type + or else Ekind (T2) = E_Anonymous_Access_Type) + and then Is_Access_Type (T1) + then + return T1; + + -- If none of the above cases applies, types are not compatible + + else + return Any_Type; + end if; + end Specific_Type; + + --------------------- + -- Set_Abstract_Op -- + --------------------- + + procedure Set_Abstract_Op (I : Interp_Index; V : Entity_Id) is + begin + All_Interp.Table (I).Abstract_Op := V; + end Set_Abstract_Op; + + ----------------------- + -- Valid_Boolean_Arg -- + ----------------------- + + -- In addition to booleans and arrays of booleans, we must include + -- aggregates as valid boolean arguments, because in the first pass of + -- resolution their components are not examined. If it turns out not to be + -- an aggregate of booleans, this will be diagnosed in Resolve. + -- Any_Composite must be checked for prior to the array type checks because + -- Any_Composite does not have any associated indexes. + + function Valid_Boolean_Arg (T : Entity_Id) return Boolean is + begin + return Is_Boolean_Type (T) + or else T = Any_Composite + or else (Is_Array_Type (T) + and then T /= Any_String + and then Number_Dimensions (T) = 1 + and then Is_Boolean_Type (Component_Type (T)) + and then (not Is_Private_Composite (T) + or else In_Instance) + and then (not Is_Limited_Composite (T) + or else In_Instance)) + or else Is_Modular_Integer_Type (T) + or else T = Universal_Integer; + end Valid_Boolean_Arg; + + -------------------------- + -- Valid_Comparison_Arg -- + -------------------------- + + function Valid_Comparison_Arg (T : Entity_Id) return Boolean is + begin + + if T = Any_Composite then + return False; + elsif Is_Discrete_Type (T) + or else Is_Real_Type (T) + then + return True; + elsif Is_Array_Type (T) + and then Number_Dimensions (T) = 1 + and then Is_Discrete_Type (Component_Type (T)) + and then (not Is_Private_Composite (T) + or else In_Instance) + and then (not Is_Limited_Composite (T) + or else In_Instance) + then + return True; + elsif Is_String_Type (T) then + return True; + else + return False; + end if; + end Valid_Comparison_Arg; + + ---------------------- + -- Write_Interp_Ref -- + ---------------------- + + procedure Write_Interp_Ref (Map_Ptr : Int) is + begin + Write_Str (" Node: "); + Write_Int (Int (Interp_Map.Table (Map_Ptr).Node)); + Write_Str (" Index: "); + Write_Int (Int (Interp_Map.Table (Map_Ptr).Index)); + Write_Str (" Next: "); + Write_Int (Interp_Map.Table (Map_Ptr).Next); + Write_Eol; + end Write_Interp_Ref; + + --------------------- + -- Write_Overloads -- + --------------------- + + procedure Write_Overloads (N : Node_Id) is + I : Interp_Index; + It : Interp; + Nam : Entity_Id; + + begin + if not Is_Overloaded (N) then + Write_Str ("Non-overloaded entity "); + Write_Eol; + Write_Entity_Info (Entity (N), " "); + + else + Get_First_Interp (N, I, It); + Write_Str ("Overloaded entity "); + Write_Eol; + Write_Str (" Name Type Abstract Op"); + Write_Eol; + Write_Str ("==============================================="); + Write_Eol; + Nam := It.Nam; + + while Present (Nam) loop + Write_Int (Int (Nam)); + Write_Str (" "); + Write_Name (Chars (Nam)); + Write_Str (" "); + Write_Int (Int (It.Typ)); + Write_Str (" "); + Write_Name (Chars (It.Typ)); + + if Present (It.Abstract_Op) then + Write_Str (" "); + Write_Int (Int (It.Abstract_Op)); + Write_Str (" "); + Write_Name (Chars (It.Abstract_Op)); + end if; + + Write_Eol; + Get_Next_Interp (I, It); + Nam := It.Nam; + end loop; + end if; + end Write_Overloads; + +end Sem_Type; |