From 7a022cc933a07a32ca2b2fbf95d56da576613868 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Sun, 26 Apr 2020 06:08:29 -0400 Subject: [PATCH] [Ada] universal_access equality and 'Access attributes 2020-06-19 Arnaud Charlet gcc/ada/ * sem_ch4.adb (Find_Equality_Types.Check_Access_Attribute): New. (Find_Equality_Types): Move universal_access related checks at the end of the processing and add call to Check_Access_Attribute. --- gcc/ada/sem_ch4.adb | 63 +++++++++++++++++++++++++++++++++++---------- 1 file changed, 49 insertions(+), 14 deletions(-) diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index fa231358a2c..0f59b40c62a 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -6540,12 +6540,24 @@ package body Sem_Ch4 is Op_Id : Entity_Id; N : Node_Id) is - Index : Interp_Index := 0; - It : Interp; - Found : Boolean := False; - I_F : Interp_Index; - T_F : Entity_Id; - Scop : Entity_Id := Empty; + Index : Interp_Index := 0; + It : Interp; + Found : Boolean := False; + Is_Universal_Access : Boolean := False; + I_F : Interp_Index; + T_F : Entity_Id; + Scop : Entity_Id := Empty; + + procedure Check_Access_Attribute (N : Node_Id); + -- For any object, '[Unchecked_]Access of such object can never be + -- passed as a parameter of a call to the Universal_Access equality + -- operator. + -- This is because the expected type for Obj'Access in a call to + -- the Standard."=" operator whose formals are of type + -- Universal_Access is Universal_Integer, and Universal_Access + -- doesn't have a designated type. For more detail see RM 6.4.1(3) + -- and 3.10.2. + -- This procedure assumes that the context is a universal_access. function Check_Access_Object_Types (N : Node_Id; Typ : Entity_Id) return Boolean; @@ -6574,6 +6586,23 @@ package body Sem_Ch4 is -- and an error can be emitted now, after trying to disambiguate, i.e. -- applying preference rules. + ---------------------------- + -- Check_Access_Attribute -- + ---------------------------- + + procedure Check_Access_Attribute (N : Node_Id) is + begin + if Nkind (N) = N_Attribute_Reference + and then Nam_In (Attribute_Name (N), + Name_Access, + Name_Unchecked_Access) + then + Error_Msg_N + ("access attribute cannot be used as actual for " + & "universal_access equality", N); + end if; + end Check_Access_Attribute; + ------------------------------- -- Check_Access_Object_Types -- ------------------------------- @@ -6867,14 +6896,6 @@ package body Sem_Ch4 is 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 @@ -6887,12 +6908,14 @@ package body Sem_Ch4 is else T_F := It.Typ; + Is_Universal_Access := Universal_Access; end if; else Found := True; T_F := T1; I_F := Index; + Is_Universal_Access := Universal_Access; end if; if not Analyzed (L) then @@ -6947,6 +6970,18 @@ package body Sem_Ch4 is Get_Next_Interp (Index, It); end loop; end if; + + if Is_Universal_Access then + if Is_Access_Subprogram_Type (Etype (L)) + and then Nkind (L) /= N_Null + and then Nkind (R) /= N_Null + then + Check_Compatible_Profiles (R, Etype (L)); + end if; + + Check_Access_Attribute (R); + Check_Access_Attribute (L); + end if; end Find_Equality_Types; ------------------------- -- 2.30.2