ada: Warning for composite equality that calls an abstract equality function

When equality is tested for a composite type that has any record
components whose type has an abstract equality function that will
be called as part of the enclosing type's equality, Program_Error
will be raised.  We now issue a warning on the equality test,
mentioning the component type whose abstract equality function
will trigger the exception.  Note that this is currently only
done for top-level components of the composite type.  Another
limitation is that the warning is not issued when the outer
composite type is tagged.

gcc/ada/ChangeLog:

	* exp_ch4.adb (Expand_N_Op_Eq): Check for warning about call to
	the abstract equality function of a component type, for both array
	and record enclosing types.
	(Warn_On_Abstract_Equality_For_Component): New procedure to issue
	a warning when an abstract equality function of a component type
	will be called and result in Program_Error.

diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index afdc243d302e38e4f0391ca15752beaf97c3ad9d..9c987a6fc43690949f3c83a2ee6b2a4001c565fa 100644 (file)
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -8185,6 +8185,11 @@ package body Exp_Ch4 is
       --  Determines whether a type has a subcomponent of an unconstrained
       --  Unchecked_Union subtype. Typ is a record type.
 
+      procedure Warn_On_Abstract_Equality_For_Component
+        (Comp_Type : Entity_Id);
+      --  If Comp_Type has a user-defined abstract equality function, then
+      --  issue a warning that Program_Error will be raised.
+
       -------------------------
       -- Build_Equality_Call --
       -------------------------
@@ -8409,6 +8414,27 @@ package body Exp_Ch4 is
              Unconstrained_UU_In_Component_List (Optional_Component_List);
       end Has_Unconstrained_UU_Component;
 
+      ---------------------------------------------
+      -- Warn_On_Abstract_Equality_For_Component --
+      ---------------------------------------------
+
+      procedure Warn_On_Abstract_Equality_For_Component
+        (Comp_Type : Entity_Id)
+      is
+         Eq : Entity_Id;
+      begin
+         if Is_Record_Type (Underlying_Type (Comp_Type)) then
+            Eq := Get_User_Defined_Equality (Comp_Type);
+
+            if Present (Eq) and then Is_Abstract_Subprogram (Eq) then
+               Error_Msg_Warn := SPARK_Mode /= On;
+               Error_Msg_NE ("call to abstract equality function of "
+                             & "component type &<<", N, Comp_Type);
+               Error_Msg_N ("\Program_Error [<<", N);
+            end if;
+         end if;
+      end Warn_On_Abstract_Equality_For_Component;
+
       --  Local variables
 
       Typl : Entity_Id;
@@ -8476,6 +8502,7 @@ package body Exp_Ch4 is
       --  Array types
 
       elsif Is_Array_Type (Typl) then
+         Warn_On_Abstract_Equality_For_Component (Component_Type (Typl));
 
          --  If we are doing full validity checking, and it is possible for the
          --  array elements to be invalid then expand out array comparisons to
@@ -8546,6 +8573,18 @@ package body Exp_Ch4 is
 
       elsif Is_Record_Type (Typl) then
 
+         declare
+            Comp : Entity_Id := First_Component (Typl);
+         begin
+            while Present (Comp) loop
+               if Chars (Comp) /= Name_uParent then
+                  Warn_On_Abstract_Equality_For_Component (Etype (Comp));
+               end if;
+
+               Next_Component (Comp);
+            end loop;
+         end;
+
          --  For tagged types, use the primitive "="
 
          if Is_Tagged_Type (Typl) then