From 606e70fd3d8abf2a74fab56faeecfb8e249178ca Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 14 Apr 2020 03:29:43 -0400 Subject: [PATCH] [Ada] ACATS 4.1L - B452002 - Wrong universal access "=" rules 2020-06-18 Arnaud Charlet gcc/ada/ * sem_ch4.adb (Find_Equality_Types.Check_Access_Object_Types): New function, used to implement RM 4.5.2 (9.6/2). (Find_Equality_Types.Check_Compatible_Profiles): New function, used to implement RM 4.5.2(9.7/2). (Find_Equality_Types.Reference_Anonymous_Access_Type): New function. (Find_Equality_Types.Try_One_Interp): Fix handling of anonymous access types which was accepting both too much and too little. Remove accumulated special and incomplete cases for instantiations, replaced by Has_Compatible_Type. (Analyze_Overloaded_Selected_Component): Use Is_Anonymous_Access_Type instead of Ekind_In. * sem_res.adb: Code cleanup and bug fix: use Is_Anonymous_Access_Type instead of Ekind_In. Relax checking of anonymous access parameter when universal_access "=" is involved. * sem_type.adb: Likewise. (Find_Unique_Type): Move code from here... (Specific_Type): ...to here. Also add missing handling of access to class wide types. * einfo.ads, einfo.adb (Is_Access_Object_Type): New. --- gcc/ada/einfo.adb | 5 + gcc/ada/einfo.ads | 4 + gcc/ada/sem_ch4.adb | 258 +++++++++++++++++++++++++++++++++++++++++++-------- gcc/ada/sem_res.adb | 20 ++-- gcc/ada/sem_type.adb | 103 ++++++++++---------- 5 files changed, 291 insertions(+), 99 deletions(-) diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 8280d3b..b482709 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -3644,6 +3644,11 @@ package body Einfo is -- Classification Functions -- ------------------------------ + function Is_Access_Object_Type (Id : E) return B is + begin + return Is_Access_Type (Id) and then not Is_Access_Subprogram_Type (Id); + end Is_Access_Object_Type; + function Is_Access_Type (Id : E) return B is begin return Ekind (Id) in Access_Kind; diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 8cf9d2e..32f5593 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -2331,6 +2331,9 @@ package Einfo is -- Is_Access_Type (synthesized) -- Applies to all entities, true for access types and subtypes +-- Is_Access_Object_Type (synthesized) +-- Applies to all entities, true for access-to-object types and subtypes + -- Is_Activation_Record (Flag305) -- Applies to E_In_Parameters generated in Exp_Unst for nested -- subprograms, to mark the added formal that carries the activation @@ -7588,6 +7591,7 @@ package Einfo is -- Is_Generic_Type where the Ekind does not provide the needed -- information). + function Is_Access_Object_Type (Id : E) return B; function Is_Access_Type (Id : E) return B; function Is_Access_Protected_Subprogram_Type (Id : E) return B; function Is_Access_Subprogram_Type (Id : E) return B; diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index bc841c0..556f209 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -3929,15 +3929,13 @@ package body Sem_Ch4 is 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)); @@ -6542,13 +6540,33 @@ package body Sem_Ch4 is 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 @@ -6556,12 +6574,183 @@ package body Sem_Ch4 is -- 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 @@ -6581,6 +6770,9 @@ package body Sem_Ch4 is -- 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 @@ -6601,48 +6793,28 @@ package body Sem_Ch4 is 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 @@ -6655,9 +6827,7 @@ package body Sem_Ch4 is -- 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; @@ -6675,9 +6845,10 @@ package body Sem_Ch4 is -- 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) @@ -6692,7 +6863,18 @@ package body Sem_Ch4 is (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 @@ -6724,11 +6906,6 @@ package body Sem_Ch4 is 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; @@ -6763,7 +6940,6 @@ package body Sem_Ch4 is if not Is_Overloaded (L) then Try_One_Interp (Etype (L)); - else Get_First_Interp (L, Index, It); while Present (It.Typ) loop diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 0a6d61f..e6b4e6c 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -1547,8 +1547,8 @@ package body Sem_Res is 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; @@ -1559,7 +1559,8 @@ package body Sem_Res is 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; @@ -8470,10 +8471,8 @@ package body Sem_Res is -- 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); @@ -13327,13 +13326,14 @@ package body Sem_Res is 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 " @@ -13355,7 +13355,7 @@ package body Sem_Res is -- 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 " diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb index a224418..d975edc 100644 --- a/gcc/ada/sem_type.adb +++ b/gcc/ada/sem_type.adb @@ -376,7 +376,7 @@ package body Sem_Type is 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; @@ -1242,8 +1242,8 @@ package body Sem_Type is -- 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) @@ -1888,9 +1888,7 @@ package body Sem_Type is 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 @@ -1901,9 +1899,7 @@ package body Sem_Type is 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 @@ -2121,7 +2117,7 @@ package body Sem_Type is 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), @@ -2252,35 +2248,6 @@ package body Sem_Type is 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 @@ -3438,6 +3405,24 @@ package body Sem_Type is 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 @@ -3452,25 +3437,47 @@ package body Sem_Type is 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; --------------------- -- 2.7.4