[Ada] Implement AI12-0101

2019-12-13  Steve Baird  <baird@adacore.com>

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

2 files changed, 115 insertions, 36 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 1941a3d..402933b 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,20 @@
+2019-12-13  Steve Baird  <baird@adacore.com>
+
+	* 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  <squirek@adacore.com>
 
 	* sem_ch6.adb (Check_Overriding_Indicator): Modify condition to
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index bd45f70..1955823 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.