and then Is_Visible_Component (Comp, Sel)
then
- -- AI05-105: if the context is an object renaming with
+ -- AI05-105: if the context is an object renaming with
-- an anonymous access type, the expected type of the
-- object must be anonymous. This is a name resolution rule.
if Nkind (Parent (N)) /= N_Object_Renaming_Declaration
or else No (Access_Definition (Parent (N)))
- or else Ekind (Etype (Comp)) = E_Anonymous_Access_Type
- or else
- Ekind (Etype (Comp)) = E_Anonymous_Access_Subprogram_Type
+ or else Is_Anonymous_Access_Type (Etype (Comp))
then
Set_Entity (Sel, Comp);
Set_Etype (Sel, Etype (Comp));
Op_Id : Entity_Id;
N : Node_Id)
is
- Index : Interp_Index;
+ Index : Interp_Index := 0;
It : Interp;
Found : Boolean := False;
I_F : Interp_Index;
T_F : Entity_Id;
Scop : Entity_Id := Empty;
+ function Check_Access_Object_Types
+ (N : Node_Id; Typ : Entity_Id) return Boolean;
+ -- Check for RM 4.5.2 (9.6/2): When both are of access-to-object types,
+ -- the designated types shall be the same or one shall cover the other,
+ -- and if the designated types are elementary or array types, then the
+ -- designated subtypes shall statically match.
+ -- If N is not overloaded, then its unique type must be compatible as
+ -- per above. Otherwise iterate through the interpretations of N looking
+ -- for a compatible one.
+
+ procedure Check_Compatible_Profiles (N : Node_Id; Typ : Entity_Id);
+ -- Check for RM 4.5.2(9.7/2): When both are of access-to-subprogram
+ -- types, the designated profiles shall be subtype conformant.
+
+ function References_Anonymous_Access_Type
+ (N : Node_Id; Typ : Entity_Id) return Boolean;
+ -- Return True either if N is not overloaded and its Etype is an
+ -- anonymous access type or if one of the interpretations of N refers
+ -- to an anonymous access type compatible with Typ.
+
procedure Try_One_Interp (T1 : Entity_Id);
-- The context of the equality operator plays no role in resolving the
-- arguments, so that if there is more than one interpretation of the
-- and an error can be emitted now, after trying to disambiguate, i.e.
-- applying preference rules.
+ -------------------------------
+ -- Check_Access_Object_Types --
+ -------------------------------
+
+ function Check_Access_Object_Types
+ (N : Node_Id; Typ : Entity_Id) return Boolean
+ is
+ function Check_Designated_Types (DT1, DT2 : Entity_Id) return Boolean;
+ -- Check RM 4.5.2 (9.6/2) on the given designated types.
+
+ ----------------------------
+ -- Check_Designated_Types --
+ ----------------------------
+
+ function Check_Designated_Types
+ (DT1, DT2 : Entity_Id) return Boolean is
+ begin
+ -- If the designated types are elementary or array types, then
+ -- the designated subtypes shall statically match.
+
+ if Is_Elementary_Type (DT1) or else Is_Array_Type (DT1) then
+ if Base_Type (DT1) /= Base_Type (DT2) then
+ return False;
+ else
+ return Subtypes_Statically_Match (DT1, DT2);
+ end if;
+
+ -- Otherwise, the designated types shall be the same or one
+ -- shall cover the other.
+
+ else
+ return DT1 = DT2
+ or else Covers (DT1, DT2)
+ or else Covers (DT2, DT1);
+ end if;
+ end Check_Designated_Types;
+
+ -- Start of processing for Check_Access_Object_Types
+
+ begin
+ -- Return immediately with no checks if Typ is not an
+ -- access-to-object type.
+
+ if not Is_Access_Object_Type (Typ) then
+ return True;
+
+ -- Any_Type is compatible with all types in this context, and is used
+ -- in particular for the designated type of a 'null' value.
+
+ elsif Directly_Designated_Type (Typ) = Any_Type
+ or else Nkind (N) = N_Null
+ then
+ return True;
+ end if;
+
+ if not Is_Overloaded (N) then
+ if Is_Access_Object_Type (Etype (N)) then
+ return Check_Designated_Types
+ (Designated_Type (Typ), Designated_Type (Etype (N)));
+ end if;
+ else
+ declare
+ Typ_Is_Anonymous : constant Boolean :=
+ Is_Anonymous_Access_Type (Typ);
+
+ I : Interp_Index;
+ It : Interp;
+
+ begin
+ Get_First_Interp (N, I, It);
+ while Present (It.Typ) loop
+
+ -- The check on designated types if only relevant when one
+ -- of the types is anonymous, ignore other (non relevant)
+ -- types.
+
+ if (Typ_Is_Anonymous
+ or else Is_Anonymous_Access_Type (It.Typ))
+ and then Is_Access_Object_Type (It.Typ)
+ then
+ if Check_Designated_Types
+ (Designated_Type (Typ), Designated_Type (It.Typ))
+ then
+ return True;
+ end if;
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+ end;
+ end if;
+
+ return False;
+ end Check_Access_Object_Types;
+
+ -------------------------------
+ -- Check_Compatible_Profiles --
+ -------------------------------
+
+ procedure Check_Compatible_Profiles (N : Node_Id; Typ : Entity_Id) is
+ I : Interp_Index;
+ It : Interp;
+ I1 : Interp_Index := 0;
+ Found : Boolean := False;
+ Tmp : Entity_Id;
+
+ begin
+ if not Is_Overloaded (N) then
+ Check_Subtype_Conformant
+ (Designated_Type (Etype (N)), Designated_Type (Typ), N);
+ else
+ Get_First_Interp (N, I, It);
+ while Present (It.Typ) loop
+ if Is_Access_Subprogram_Type (It.Typ) then
+ if not Found then
+ Found := True;
+ Tmp := It.Typ;
+ I1 := I;
+
+ else
+ It := Disambiguate (N, I1, I, Any_Type);
+
+ if It /= No_Interp then
+ Tmp := It.Typ;
+ I1 := I;
+ else
+ Found := False;
+ exit;
+ end if;
+ end if;
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+
+ if Found then
+ Check_Subtype_Conformant
+ (Designated_Type (Tmp), Designated_Type (Typ), N);
+ end if;
+ end if;
+ end Check_Compatible_Profiles;
+
+ --------------------------------------
+ -- References_Anonymous_Access_Type --
+ --------------------------------------
+
+ function References_Anonymous_Access_Type
+ (N : Node_Id; Typ : Entity_Id) return Boolean
+ is
+ I : Interp_Index;
+ It : Interp;
+ begin
+ if not Is_Overloaded (N) then
+ return Is_Anonymous_Access_Type (Etype (N));
+ else
+ Get_First_Interp (N, I, It);
+ while Present (It.Typ) loop
+ if Is_Anonymous_Access_Type (It.Typ)
+ and then (Covers (It.Typ, Typ) or else Covers (Typ, It.Typ))
+ then
+ return True;
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+
+ return False;
+ end if;
+ end References_Anonymous_Access_Type;
+
--------------------
-- Try_One_Interp --
--------------------
procedure Try_One_Interp (T1 : Entity_Id) is
- Bas : Entity_Id;
+ Universal_Access : Boolean;
+ Bas : Entity_Id;
begin
-- Perform a sanity check in case of previous errors
-- In Ada 2005, the equality operator for anonymous access types
-- is declared in Standard, and preference rules apply to it.
+ Universal_Access := Is_Anonymous_Access_Type (T1)
+ or else References_Anonymous_Access_Type (R, T1);
+
if Present (Scop) then
-- Note that we avoid returning if we are currently within a
then
null;
- elsif Ekind (T1) = E_Anonymous_Access_Type
- and then Scop = Standard_Standard
- then
- null;
+ elsif Scop /= Standard_Standard or else not Universal_Access then
- else
-- The scope does not contain an operator for the type
return;
end if;
-- If we have infix notation, the operator must be usable. Within
- -- an instance, if the type is already established we know it is
- -- correct. If an operand is universal it is compatible with any
- -- numeric type.
+ -- an instance, the type may have been immediately visible if the
+ -- types are compatible.
elsif In_Open_Scopes (Scope (Bas))
or else Is_Potentially_Use_Visible (Bas)
or else In_Use (Bas)
or else (In_Use (Scope (Bas)) and then not Is_Hidden (Bas))
-
- -- In an instance, the type may have been immediately visible.
- -- Either the types are compatible, or one operand is universal
- -- (numeric or null).
-
or else
((In_Instance or else In_Inlined_Body)
- and then
- (First_Subtype (T1) = First_Subtype (Etype (R))
- or else Nkind (R) = N_Null
- or else
- (Is_Numeric_Type (T1)
- and then Is_Universal_Numeric_Type (Etype (R)))))
-
- -- In Ada 2005, the equality on anonymous access types is declared
- -- in Standard, and is always visible.
-
- or else Ekind (T1) = E_Anonymous_Access_Type
+ and then Has_Compatible_Type (R, T1))
then
null;
- else
+ elsif not Universal_Access then
-- Save candidate type for subsequent error message, if any
if not Is_Limited_Type (T1) then
-- Ada 2005 (AI-230): Keep restriction imposed by Ada 83 and 95:
-- Do not allow anonymous access types in equality operators.
- if Ada_Version < Ada_2005
- and then Ekind (T1) = E_Anonymous_Access_Type
- then
+ if Ada_Version < Ada_2005 and then Universal_Access then
return;
end if;
-- because that indicates the potential rewriting case where the
-- interpretation to consider is actually "=" and the node may be
-- about to be rewritten by Analyze_Equality_Op.
+ -- Finally, also check for RM 4.5.2 (9.6/2).
if T1 /= Standard_Void_Type
- and then Has_Compatible_Type (R, T1)
+ and then (Universal_Access or else Has_Compatible_Type (R, T1))
and then
((not Is_Limited_Type (T1)
(Nkind (N) /= N_Op_Ne
or else not Is_Tagged_Type (T1)
or else Chars (Op_Id) = Name_Op_Eq)
+
+ and then (not Universal_Access
+ or else Check_Access_Object_Types (R, T1))
then
+ if Universal_Access
+ and then Is_Access_Subprogram_Type (T1)
+ and then Nkind (L) /= N_Null
+ and then Nkind (R) /= N_Null
+ then
+ Check_Compatible_Profiles (R, T1);
+ end if;
+
if Found
and then Base_Type (T1) /= Base_Type (T_F)
then
if Etype (N) = Any_Type then
Found := False;
end if;
-
- elsif Scop = Standard_Standard
- and then Ekind (T1) = E_Anonymous_Access_Type
- then
- Found := True;
end if;
end Try_One_Interp;
if not Is_Overloaded (L) then
Try_One_Interp (Etype (L));
-
else
Get_First_Interp (L, Index, It);
while Present (It.Typ) loop
null;
elsif Nam_In (Op_Name, Name_Op_Multiply, Name_Op_Divide)
- and then Is_Fixed_Point_Type (Etype (Left_Opnd (Op_Node)))
- and then Is_Fixed_Point_Type (Etype (Right_Opnd (Op_Node)))
+ and then Is_Fixed_Point_Type (Etype (Act1))
+ and then Is_Fixed_Point_Type (Etype (Act2))
then
if Pack /= Standard_Standard then
Error := True;
elsif Ada_Version >= Ada_2005
and then Nam_In (Op_Name, Name_Op_Eq, Name_Op_Ne)
- and then Ekind (Etype (Act1)) = E_Anonymous_Access_Type
+ and then (Is_Anonymous_Access_Type (Etype (Act1))
+ or else Is_Anonymous_Access_Type (Etype (Act2)))
then
null;
-- Why no similar processing for case expressions???
elsif Ada_Version >= Ada_2012
- and then Ekind_In (Etype (L), E_Anonymous_Access_Type,
- E_Anonymous_Access_Subprogram_Type)
- and then Ekind_In (Etype (R), E_Anonymous_Access_Type,
- E_Anonymous_Access_Subprogram_Type)
+ and then Is_Anonymous_Access_Type (Etype (L))
+ and then Is_Anonymous_Access_Type (Etype (R))
then
Check_If_Expression (L);
Check_If_Expression (R);
return False;
-- Implicit conversions aren't allowed for anonymous access
- -- parameters. The "not Is_Local_Anonymous_Access_Type" test
- -- is done to exclude anonymous access results.
+ -- parameters. We exclude anonymous access results as well
+ -- as universal_access "=".
elsif not Is_Local_Anonymous_Access (Opnd_Type)
and then Nkind_In (Associated_Node_For_Itype (Opnd_Type),
N_Function_Specification,
N_Procedure_Specification)
+ and then not Nkind_In (Parent (N), N_Op_Eq, N_Op_Ne)
then
Conversion_Error_N
("implicit conversion of anonymous access parameter "
-- implicit conversion is disallowed (by RM12-8.6(27.1/3)).
elsif Type_Access_Level (Opnd_Type) >
- Deepest_Type_Access_Level (Target_Type)
+ Deepest_Type_Access_Level (Target_Type)
then
Conversion_Error_N
("implicit conversion of anonymous access value "
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 In_Inlined_Body)
- or else Ekind (Vis_Type) = E_Anonymous_Access_Type
+ or else Is_Anonymous_Access_Type (Vis_Type)
then
null;
-- 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_Anonymous_Access_Type (T1)
+ and then Is_Anonymous_Access_Type (T2)
and then Is_Generic_Type (Directly_Designated_Type (T1))
and then Get_Instance_Of (Directly_Designated_Type (T1)) =
Directly_Designated_Type (T2)
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 Is_Anonymous_Access_Type (It1.Typ) then
if Ekind (It2.Typ) = Ekind (It1.Typ) then
-- True ambiguity
return It1;
end if;
- elsif Ekind_In (It2.Typ, E_Anonymous_Access_Type,
- E_Anonymous_Access_Subprogram_Type)
- then
+ elsif Is_Anonymous_Access_Type (It2.Typ) then
return It2;
-- No legal interpretation
elsif Nam_In (Chars (Nam1), Name_Op_Eq, Name_Op_Ne)
and then Ada_Version >= Ada_2005
and then Etype (User_Subp) = Standard_Boolean
- and then Ekind (Operand_Type) = E_Anonymous_Access_Type
+ and then Is_Anonymous_Access_Type (Operand_Type)
and then
In_Same_Declaration_List
(Designated_Type (Operand_Type),
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.
- -- Note that this does not preclude one operand to be a pool-specific
- -- access type, as a previous version of this code enforced.
-
- elsif Ada_Version >= Ada_2005
- and then Ekind_In (Etype (L), E_Anonymous_Access_Type,
- E_Anonymous_Access_Subprogram_Type)
- and then Is_Access_Type (Etype (R))
- then
- return Etype (L);
-
- elsif Ada_Version >= Ada_2005
- and then Ekind_In (Etype (R), E_Anonymous_Access_Type,
- E_Anonymous_Access_Subprogram_Type)
- and then Is_Access_Type (Etype (L))
- then
- return Etype (R);
-
-- If one operand is a raise_expression, use type of other operand
elsif Nkind (L) = N_Raise_Expression then
then
return T2;
+ elsif Is_Access_Type (T1)
+ and then Is_Access_Type (T2)
+ and then Is_Class_Wide_Type (Designated_Type (T1))
+ and then not Is_Class_Wide_Type (Designated_Type (T2))
+ and then
+ Is_Ancestor (Root_Type (Designated_Type (T1)), Designated_Type (T2))
+ then
+ return T1;
+
+ elsif Is_Access_Type (T1)
+ and then Is_Access_Type (T2)
+ and then Is_Class_Wide_Type (Designated_Type (T2))
+ and then not Is_Class_Wide_Type (Designated_Type (T1))
+ and then
+ Is_Ancestor (Root_Type (Designated_Type (T2)), Designated_Type (T1))
+ then
+ return T2;
+
elsif Ekind_In (B1, E_Access_Subprogram_Type,
E_Access_Protected_Subprogram_Type)
and then Ekind (Designated_Type (B1)) /= E_Subprogram_Type
then
return T1;
- elsif Ekind_In (T1, E_Allocator_Type,
- E_Access_Attribute_Type,
- E_Anonymous_Access_Type)
+ elsif Ekind_In (T1, E_Allocator_Type, E_Access_Attribute_Type)
and then Is_Access_Type (T2)
then
return T2;
- elsif Ekind_In (T2, E_Allocator_Type,
- E_Access_Attribute_Type,
- E_Anonymous_Access_Type)
+ elsif Ekind_In (T2, E_Allocator_Type, E_Access_Attribute_Type)
and then Is_Access_Type (T1)
then
return T1;
- -- If none of the above cases applies, types are not compatible
+ -- Ada 2005 (AI-230): Support the following operators:
- else
- return Any_Type;
+ -- 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.
+ -- Note that this does not preclude one operand to be a pool-specific
+ -- access type, as a previous version of this code enforced.
+
+ elsif Ada_Version >= Ada_2005 then
+ if Is_Anonymous_Access_Type (T1)
+ and then Is_Access_Type (T2)
+ then
+ return T1;
+
+ elsif Is_Anonymous_Access_Type (T2)
+ and then Is_Access_Type (T1)
+ then
+ return T2;
+ end if;
end if;
+
+ -- If none of the above cases applies, types are not compatible
+
+ return Any_Type;
end Specific_Type;
---------------------
projects / gcc.git / commitdiff