From d7c37f454912c398302679e780ff69c76a3f843a Mon Sep 17 00:00:00 2001 From: Steve Baird Date: Fri, 13 Dec 2019 09:03:23 +0000 Subject: [PATCH] [Ada] Implement AI12-0101 2019-12-13 Steve Baird gcc/ada/ * exp_ch4.adb (Expand_N_Op_Eq.Is_Equality): Move this function from within Expand_N_Op_Eq.Find_Equality out to immediately within Expand_N_Op_Eq in order to give it greater visibility. Add a new Typ parameter (defaulted to Empty) which, if non-empty, means the function will return False in the case of an equality op for some other type. * (Expand_N_Op_Eq.User_Defined_Primitive_Equality_Op): A new function. Given an untagged record type, finds the corresponding user-defined primitive equality op (if any). May return Empty. Ignores visibility. * (Expand_N_Op): For Ada2012 or later, check for presence of a user-defined primitive equality op before falling back on the usual predefined component-by-component comparison. If found, then call the user-defined op instead. From-SVN: r279341 --- gcc/ada/ChangeLog | 17 ++++++ gcc/ada/exp_ch4.adb | 134 ++++++++++++++++++++++++++++++++------------ 2 files changed, 115 insertions(+), 36 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 1941a3d8e7b..402933b8ab1 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,20 @@ +2019-12-13 Steve Baird + + * exp_ch4.adb (Expand_N_Op_Eq.Is_Equality): Move this function + from within Expand_N_Op_Eq.Find_Equality out to immediately + within Expand_N_Op_Eq in order to give it greater visibility. + Add a new Typ parameter (defaulted to Empty) which, if + non-empty, means the function will return False in the case of + an equality op for some other type. + * (Expand_N_Op_Eq.User_Defined_Primitive_Equality_Op): A new + function. Given an untagged record type, finds the corresponding + user-defined primitive equality op (if any). May return Empty. + Ignores visibility. + * (Expand_N_Op): For Ada2012 or later, check for presence of a + user-defined primitive equality op before falling back on the + usual predefined component-by-component comparison. If found, + then call the user-defined op instead. + 2019-12-13 Justin Squirek * sem_ch6.adb (Check_Overriding_Indicator): Modify condition to diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index bd45f70b95a..19558236e0c 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -7520,10 +7520,21 @@ package body Exp_Ch4 is -- build and analyze call, adding conversions if the operation is -- inherited. + function Is_Equality (Subp : Entity_Id; + Typ : Entity_Id := Empty) return Boolean; + -- Determine whether arbitrary Entity_Id denotes a function with the + -- right name and profile for an equality op, specifically for the + -- base type Typ if Typ is nonempty. + function Find_Equality (Prims : Elist_Id) return Entity_Id; -- Find a primitive equality function within primitive operation list -- Prims. + function User_Defined_Primitive_Equality_Op + (Typ : Entity_Id) return Entity_Id; + -- Find a user-defined primitive equality function for a given untagged + -- record type, ignoring visibility. Return Empty if no such op found. + function Has_Unconstrained_UU_Component (Typ : Entity_Id) return Boolean; -- Determines whether a type has a subcomponent of an unconstrained -- Unchecked_Union subtype. Typ is a record type. @@ -7772,6 +7783,43 @@ package body Exp_Ch4 is Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks); end Build_Equality_Call; + ----------------- + -- Is_Equality -- + ----------------- + + function Is_Equality (Subp : Entity_Id; + Typ : Entity_Id := Empty) return Boolean is + Formal_1 : Entity_Id; + Formal_2 : Entity_Id; + begin + -- The equality function carries name "=", returns Boolean, and has + -- exactly two formal parameters of an identical type. + + if Ekind (Subp) = E_Function + and then Chars (Subp) = Name_Op_Eq + and then Base_Type (Etype (Subp)) = Standard_Boolean + then + Formal_1 := First_Formal (Subp); + Formal_2 := Empty; + + if Present (Formal_1) then + Formal_2 := Next_Formal (Formal_1); + end if; + + return + Present (Formal_1) + and then Present (Formal_2) + and then No (Next_Formal (Formal_2)) + and then Base_Type (Etype (Formal_1)) = + Base_Type (Etype (Formal_2)) + and then + (not Present (Typ) + or else Implementation_Base_Type (Etype (Formal_1)) = Typ); + end if; + + return False; + end Is_Equality; + ------------------- -- Find_Equality -- ------------------- @@ -7781,9 +7829,6 @@ package body Exp_Ch4 is -- Find an equality in a possible alias chain starting from primitive -- operation Prim. - function Is_Equality (Id : Entity_Id) return Boolean; - -- Determine whether arbitrary entity Id denotes an equality - --------------------------- -- Find_Aliased_Equality -- --------------------------- @@ -7807,39 +7852,6 @@ package body Exp_Ch4 is return Empty; end Find_Aliased_Equality; - ----------------- - -- Is_Equality -- - ----------------- - - function Is_Equality (Id : Entity_Id) return Boolean is - Formal_1 : Entity_Id; - Formal_2 : Entity_Id; - - begin - -- The equality function carries name "=", returns Boolean, and - -- has exactly two formal parameters of an identical type. - - if Ekind (Id) = E_Function - and then Chars (Id) = Name_Op_Eq - and then Base_Type (Etype (Id)) = Standard_Boolean - then - Formal_1 := First_Formal (Id); - Formal_2 := Empty; - - if Present (Formal_1) then - Formal_2 := Next_Formal (Formal_1); - end if; - - return - Present (Formal_1) - and then Present (Formal_2) - and then Etype (Formal_1) = Etype (Formal_2) - and then No (Next_Formal (Formal_2)); - end if; - - return False; - end Is_Equality; - -- Local variables Eq_Prim : Entity_Id; @@ -7869,6 +7881,47 @@ package body Exp_Ch4 is return Eq_Prim; end Find_Equality; + ---------------------------------------- + -- User_Defined_Primitive_Equality_Op -- + ---------------------------------------- + + function User_Defined_Primitive_Equality_Op + (Typ : Entity_Id) return Entity_Id + is + Enclosing_Scope : constant Node_Id := Scope (Typ); + E : Entity_Id; + begin + -- Prune this search by somehow not looking at decls that precede + -- the declaration of the first view of Typ (which might be a partial + -- view)??? + + for Private_Entities in Boolean loop + if Private_Entities then + if Ekind (Enclosing_Scope) /= E_Package then + exit; + end if; + E := First_Private_Entity (Enclosing_Scope); + + else + E := First_Entity (Enclosing_Scope); + end if; + + while Present (E) loop + if Is_Equality (E, Typ) then + return E; + end if; + E := Next_Entity (E); + end loop; + end loop; + + if Is_Derived_Type (Typ) then + return User_Defined_Primitive_Equality_Op + (Implementation_Base_Type (Etype (Typ))); + end if; + + return Empty; + end User_Defined_Primitive_Equality_Op; + ------------------------------------ -- Has_Unconstrained_UU_Component -- ------------------------------------ @@ -8190,6 +8243,15 @@ package body Exp_Ch4 is (Find_Equality (Primitive_Operations (Typl))); end if; + -- See AI12-0101 (which only removes a legality rule) and then + -- AI05-0123 (which then applies in the previously illegal case). + -- AI12-0101 is a binding interpretation. + + elsif Ada_Version >= Ada_2012 + and then Present (User_Defined_Primitive_Equality_Op (Typl)) + then + Build_Equality_Call (User_Defined_Primitive_Equality_Op (Typl)); + -- Ada 2005 (AI-216): Program_Error is raised when evaluating the -- predefined equality operator for a type which has a subcomponent -- of an Unchecked_Union type whose nominal subtype is unconstrained. -- 2.30.2