-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2011, 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- --
-- Find out whether the new entry references interpretations that
-- are abstract or disabled by abstract operators.
- if Ada_Version >= Ada_05 then
+ 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
then
Add_Entry (Entity (N), Etype (N));
- elsif (Nkind (N) = N_Function_Call
- or else Nkind (N) = N_Procedure_Call_Statement)
- and then (Nkind (Name (N)) = N_Operator_Symbol
- or else Is_Entity_Name (Name (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));
H : Entity_Id;
First_Interp : Interp_Index;
+ function Within_Instance (E : Entity_Id) return Boolean;
+ -- Within an instance there can be spurious ambiguities between a local
+ -- entity and one declared outside of the instance. This can only happen
+ -- for subprograms, because otherwise the local entity hides the outer
+ -- one. For an overloadable entity, this predicate determines whether it
+ -- is a candidate within the instance, or must be ignored.
+
+ ---------------------
+ -- Within_Instance --
+ ---------------------
+
+ function Within_Instance (E : Entity_Id) return Boolean is
+ Inst : Entity_Id;
+ Scop : Entity_Id;
+
+ begin
+ if not In_Instance then
+ return False;
+ end if;
+
+ Inst := Current_Scope;
+ while Present (Inst) and then not Is_Generic_Instance (Inst) loop
+ Inst := Scope (Inst);
+ end loop;
+
+ Scop := Scope (E);
+ while Present (Scop) and then Scop /= Standard_Standard loop
+ if Scop = Inst then
+ return True;
+ end if;
+ Scop := Scope (Scop);
+ end loop;
+
+ return False;
+ end Within_Instance;
+
+ -- Start of processing for Collect_Interps
+
begin
New_Interps (N);
-- 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)
+ -- resolved later. The homographs may both be local
+ -- functions or actuals, or may be declared at different
+ -- levels within the instance. The renaming of an actual
+ -- within the instance must not be included.
+
+ if Within_Instance (H)
+ and then H /= Renamed_Entity (Ent)
+ and then not Is_Inherited_Operation (H)
then
All_Interp.Table (All_Interp.Last) :=
(H, Etype (H), Empty);
else
raise Program_Error;
end if;
+ end if;
- else
- BT1 := Base_Type (T1);
- BT2 := Base_Type (T2);
+ -- Trivial case: same types are always compatible
- -- 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 T1 = T2 then
+ return True;
+ end if;
- if Is_Underlying_Record_View (BT1) then
- BT1 := Underlying_Record_View (BT1);
- 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 Is_Underlying_Record_View (BT2) then
- BT2 := Underlying_Record_View (BT2);
- end if;
+ if (T1 = Standard_Void_Type) /= (T2 = Standard_Void_Type) then
+ return False;
end if;
- -- 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 ???)
+ 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;
+
+ -- Simplest case: 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.
- if T1 = T2 then
- return True;
-
- elsif BT1 = BT2
+ if BT1 = BT2
or else BT1 = T2
or else BT2 = T1
then
-- 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_05
+ 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))
+ (Typ => BT2, Iface => Etype (T1))
then
return True;
-- Ada 2005 (AI-251): A class-wide abstract interface type T1 covers an
- -- object T2 implementing T1
+ -- object T2 implementing T1.
- elsif Ada_Version >= Ada_05
+ elsif Ada_Version >= Ada_2005
and then Is_Class_Wide_Type (T1)
and then Is_Interface (Etype (T1))
and then Is_Tagged_Type (T2)
return False;
end;
- -- In a dispatching call the actual may be class-wide
+ -- In a dispatching call, the formal is of some specific type, and the
+ -- actual is of the corresponding class-wide type, including a subtype
+ -- of the class-wide type.
elsif Is_Class_Wide_Type (T2)
- and then Base_Type (Root_Type (T2)) = Base_Type (T1)
+ and then
+ (Class_Wide_Type (T1) = Class_Wide_Type (T2)
+ or else Base_Type (Root_Type (T2)) = BT1)
then
return True;
then
return True;
+ -- Ada 2012 (AI05-0149): Allow an anonymous access type in the context
+ -- of a named general access type. An implicit conversion will be
+ -- applied. For the resolution, one designated type must cover the
+ -- other.
+
+ elsif Ada_Version >= Ada_2012
+ and then Ekind (BT1) = E_General_Access_Type
+ and then Ekind (BT2) = E_Anonymous_Access_Type
+ and then (Covers (Designated_Type (T1), Designated_Type (T2))
+ or else Covers (Designated_Type (T2), Designated_Type (T1)))
+ then
+ return True;
+
-- An Access_To_Subprogram is compatible with itself, or with an
-- anonymous type created for an attribute reference Access.
-- The actual type may be the result of a previous error
- elsif Base_Type (T2) = Any_Type then
+ elsif BT2 = Any_Type then
return True;
-- A packed array type covers its corresponding non-packed type. This is
-- package Instance is new G (Formal => Actual,
-- Formal_Obj => Actual_Obj);
- elsif Ada_Version >= Ada_05
+ 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))
-- Determine whether one of the candidates is an operation inherited by
-- a type that is derived from an actual in an instantiation.
+ function In_Same_Declaration_List
+ (Typ : Entity_Id;
+ Op_Decl : Entity_Id) return Boolean;
+ -- AI05-0020: a spurious ambiguity may arise when equality on anonymous
+ -- access types is declared on the partial view of a designated type, so
+ -- that the type declaration and equality are not in the same list of
+ -- declarations. This AI gives a preference rule for the user-defined
+ -- operation. Same rule applies for arithmetic operations on private
+ -- types completed with fixed-point types: the predefined operation is
+ -- hidden; this is already handled properly in GNAT.
+
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
-- Look for exact type match in an instance, to remove spurious
-- ambiguities when two formal types have the same actual.
+ function Operand_Type return Entity_Id;
+ -- Determine type of operand for an equality operation, to apply
+ -- Ada 2005 rules to equality on anonymous access types.
+
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
end if;
end Inherited_From_Actual;
+ ------------------------------
+ -- In_Same_Declaration_List --
+ ------------------------------
+
+ function In_Same_Declaration_List
+ (Typ : Entity_Id;
+ Op_Decl : Entity_Id) return Boolean
+ is
+ Scop : constant Entity_Id := Scope (Typ);
+
+ begin
+ return In_Same_List (Parent (Typ), Op_Decl)
+ or else
+ (Ekind_In (Scop, E_Package, E_Generic_Package)
+ and then List_Containing (Op_Decl) =
+ Visible_Declarations (Parent (Scop))
+ and then List_Containing (Parent (Typ)) =
+ Private_Declarations (Parent (Scop)));
+ end In_Same_Declaration_List;
+
--------------------------
-- Is_Actual_Subprogram --
--------------------------
and then (T1 = Universal_Real or else T1 = Universal_Integer));
end Matches;
+ ------------------
+ -- Operand_Type --
+ ------------------
+
+ function Operand_Type return Entity_Id is
+ Opnd : Node_Id;
+
+ begin
+ if Nkind (N) = N_Function_Call then
+ Opnd := First_Actual (N);
+ else
+ Opnd := Left_Opnd (N);
+ end if;
+
+ return Etype (Opnd);
+ end Operand_Type;
+
------------------------
-- Remove_Conversions --
------------------------
begin
if Nkind (N) not in N_Op
- or else Ada_Version < Ada_05
+ or else Ada_Version < Ada_2005
or else not Is_Overloaded (N)
or else No (Universal_Interpretation (N))
then
It2 := It;
Nam2 := It.Nam;
- if Ada_Version < Ada_05 then
+ -- 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.
- -- Check whether one of the entities is an Ada 2005 entity and we are
- -- operating in an earlier mode, in which case we discard the Ada
- -- 2005 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 Is_Ada_2005_Only (Nam1) then
+ if Ada_Version = Ada_2005 then
+ if Is_Ada_2012_Only (Nam1) then
return It2;
- elsif Is_Ada_2005_Only (Nam2) then
+ elsif Is_Ada_2012_Only (Nam2) then
return It1;
end if;
end if;
Arg1 := Left_Opnd (N);
Arg2 := Right_Opnd (N);
- elsif Is_Entity_Name (N)
- or else Nkind (N) = N_Operator_Symbol
- then
+ elsif Is_Entity_Name (N) then
Arg1 := First_Entity (Entity (N));
Arg2 := Next_Entity (Arg1);
-- case the resolution was to the explicit declaration in the
-- generic, and remains so in the instance.
+ -- The same sort of disambiguation needed for calls is also required
+ -- for the name given in a subprogram renaming, and that case is
+ -- handled here as well. We test Comes_From_Source to exclude this
+ -- treatment for implicit renamings created for formal subprograms.
+
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
+ or else
+ (Nkind (N) in N_Has_Entity
+ and then
+ Nkind (Parent (N)) = N_Subprogram_Renaming_Declaration
+ and then Comes_From_Source (Parent (N)))
then
declare
Actual : Node_Id;
Formal : Entity_Id;
+ Renam : Entity_Id := Empty;
Is_Act1 : constant Boolean := Is_Actual_Subprogram (Nam1);
Is_Act2 : constant Boolean := Is_Actual_Subprogram (Nam2);
return It1;
end if;
- Actual := First_Actual (N);
+ -- In the case of a renamed subprogram, pick up the entity
+ -- of the renaming declaration so we can traverse its
+ -- formal parameters.
+
+ if Nkind (N) in N_Has_Entity then
+ Renam := Defining_Unit_Name (Specification (Parent (N)));
+ end if;
+
+ if Present (Renam) then
+ Actual := First_Formal (Renam);
+ else
+ Actual := First_Actual (N);
+ end if;
+
Formal := First_Formal (Nam1);
while Present (Actual) loop
if Etype (Actual) /= Etype (Formal) then
return It2;
end if;
- Next_Actual (Actual);
+ if Present (Renam) then
+ Next_Formal (Actual);
+ else
+ Next_Actual (Actual);
+ end if;
+
Next_Formal (Formal);
end loop;
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,
+ -- defined operation is directly visible we have a true ambiguity.
+
+ -- If this is a fixed-point multiplication and division in Ada 83 mode,
-- exclude the universal_fixed operator, which often causes ambiguities
-- in legacy code.
+ -- Ditto in Ada 2012, where an ambiguity may arise for an operation
+ -- on a partial view that is completed with a fixed point type. See
+ -- AI05-0020 and AI05-0209. The ambiguity is resolved in favor of the
+ -- user-defined subprogram so that a client of the package has the
+ -- same resulution as the body of the package.
+
else
if (In_Open_Scopes (Scope (User_Subp))
or else Is_Potentially_Use_Visible (User_Subp))
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
+ and then
+ (Ada_Version = Ada_83
+ or else
+ (Ada_Version >= Ada_2012
+ and then
+ In_Same_Declaration_List
+ (Typ, Unit_Declaration_Node (User_Subp))))
then
if It2.Nam = Predef_Subp then
return It1;
elsif (Chars (Nam1) = Name_Op_Eq
or else
Chars (Nam1) = Name_Op_Ne)
- and then Ada_Version >= Ada_05
+ and then Ada_Version >= Ada_2005
and then Etype (User_Subp) = Standard_Boolean
+ and then Ekind (Operand_Type) = E_Anonymous_Access_Type
+ and then
+ In_Same_Declaration_List
+ (Designated_Type (Operand_Type),
+ Unit_Declaration_Node (User_Subp))
then
- declare
- Opnd : Node_Id;
+ if It2.Nam = Predef_Subp then
+ return It1;
+ else
+ return It2;
+ end if;
- begin
- if Nkind (N) = N_Function_Call then
- Opnd := First_Actual (N);
- else
- Opnd := Left_Opnd (N);
- end if;
+ -- An immediately visible operator hides a use-visible user-
+ -- defined operation. This disambiguation cannot take place
+ -- earlier because the visibility of the predefined operator
+ -- can only be established when operand types are known.
- 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;
+ elsif Ekind (User_Subp) = E_Function
+ and then Ekind (Predef_Subp) = E_Operator
+ and then Nkind (N) in N_Op
+ and then not Is_Overloaded (Right_Opnd (N))
+ and then
+ Is_Immediately_Visible (Base_Type (Etype (Right_Opnd (N))))
+ and then Is_Potentially_Use_Visible (User_Subp)
+ then
+ if It2.Nam = Predef_Subp then
+ return It1;
+ else
+ return It2;
+ end if;
else
return No_Interp;
-- 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_05
+ elsif Ada_Version >= Ada_2005
and then
(Ekind (Etype (L)) = E_Anonymous_Access_Type
or else
then
return Etype (L);
- elsif Ada_Version >= Ada_05
+ elsif Ada_Version >= Ada_2005
and then
(Ekind (Etype (R)) = E_Anonymous_Access_Type
or else Ekind (Etype (R)) = E_Anonymous_Access_Subprogram_Type)
-- Is_Ancestor --
-----------------
- function Is_Ancestor (T1, T2 : Entity_Id) return Boolean is
+ function Is_Ancestor
+ (T1 : Entity_Id;
+ T2 : Entity_Id;
+ Use_Full_View : Boolean := False) return Boolean
+ is
BT1 : Entity_Id;
BT2 : Entity_Id;
Par : Entity_Id;
return True;
else
- Par := Etype (BT2);
+ -- Obtain the parent of the base type of T2 (use the full view if
+ -- allowed).
+
+ if Use_Full_View
+ and then Is_Private_Type (BT2)
+ and then Present (Full_View (BT2))
+ then
+ -- No climbing needed if its full view is the root type
+
+ if Full_View (BT2) = Root_Type (Full_View (BT2)) then
+ return False;
+ end if;
+
+ Par := Etype (Full_View (BT2));
+
+ else
+ Par := Etype (BT2);
+ end if;
loop
-- If there was a error on the type declaration, do not recurse
then
return True;
- elsif Etype (Par) /= Par then
+ -- Root type found
+
+ elsif Par = Root_Type (Par) then
+ return False;
+
+ -- Continue climbing
- -- 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)
+ else
+ -- Use the full-view of private types (if allowed)
- if Is_Private_Type (Par)
- and then Is_Interface (Etype (Par))
+ if Use_Full_View
+ and then Is_Private_Type (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 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 --
-------------------
then
return T1;
+ -- In an instance, the specific type may have a private view. Use full
+ -- view to check legality.
+
+ elsif T2 = Any_Access
+ and then Is_Private_Type (T1)
+ and then Present (Full_View (T1))
+ and then Is_Access_Type (Full_View (T1))
+ and then In_Instance
+ then
+ return T1;
+
elsif T2 = Any_Composite
and then Is_Aggregate_Type (T1)
then
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))
+ if Is_Boolean_Type (T)
or else Is_Modular_Integer_Type (T)
- or else T = Universal_Integer;
+ or else T = Universal_Integer
+ or else T = Any_Composite
+ then
+ return True;
+
+ elsif 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)
+ and then not Is_Limited_Composite (T))
+ or else In_Instance
+ or else Available_Full_View_Of_Component (T))
+ then
+ return True;
+
+ else
+ return False;
+ end if;
end Valid_Boolean_Arg;
--------------------------
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))
or else In_Instance)
then
return True;
+
+ elsif Is_Array_Type (T)
+ and then Number_Dimensions (T) = 1
+ and then Is_Discrete_Type (Component_Type (T))
+ and then Available_Full_View_Of_Component (T)
+ then
+ return True;
+
elsif Is_String_Type (T) then
return True;
else
Write_Str (" Index: ");
Write_Int (Int (Interp_Map.Table (Map_Ptr).Index));
Write_Str (" Next: ");
- Write_Int (Int (Interp_Map.Table (Map_Ptr).Next));
+ Write_Int (Interp_Map.Table (Map_Ptr).Next);
Write_Eol;
end Write_Interp_Ref;
OSDN Git Service
