ada: New warning about noncomposing user-defined "="

Print warning for a user-defined "=" that does not compose
as might be expected (i.e. is ignored for predefined "=" of
a containing record or array type). This warning is enabled by
-gnatw_q; we don't enable it by default because it generates
too many false positives. We also don't enable it via -gnatwa.

gcc/ada/

	* exp_ch4.adb
	(Expand_Array_Equality): Do not test Ltyp = Rtyp here, because
	that is necessarily true. Move assertion thereof to more general
	place.
	(Expand_Composite_Equality): Pass in Outer_Type, for use in
	warnings. Rename Typ to be Comp_Type, to more clearly distinguish
	it from Outer_Type. Print warning when appropriate.
	* exp_ch4.ads: Minor comment fix.
	* errout.ads: There is no such pragma as Warning_As_Pragma --
	Warning_As_Error must have been intended. Improve comment for ?x?.
	* exp_ch3.adb
	(Build_Untagged_Equality): Update comment to be accurate for more
	recent versions of Ada.
	* sem_case.adb
	(Choice_Analysis): Declare user-defined "=" functions as abstract.
	* sem_util.ads
	(Is_Bounded_String): Give RM reference in comment.
	* warnsw.ads, warnsw.adb
	(Warn_On_Ignored_Equality): Implement new warning switch -gnatw_q.
	* doc/gnat_ugn/building_executable_programs_with_gnat.rst:
	Document new warning switch.
	* gnat_ugn.texi: Regenerate.

10 files changed, 145 insertions, 34 deletions

diff --git a/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst b/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst
index 83bc50f..31e2e31 100644
--- a/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst
+++ b/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst
@@ -2795,6 +2795,8 @@ of the pragma in the :title:`GNAT_Reference_manual`).
 
   * :switch:`-gnatw.q` (questionable layout of record types)
 
+  * :switch:`-gnatw_q` (ignored equality)
+
   * :switch:`-gnatw_r` (out-of-order record representation clauses)
 
   * :switch:`-gnatw.s` (overridden size clause)
@@ -3687,6 +3689,25 @@ of the pragma in the :title:`GNAT_Reference_manual`).
   a record type would very likely cause inefficiencies.
 
 
+.. index:: -gnatw_q  (gcc)
+
+:switch:`-gnatw_q`
+  *Activate warnings for ignored equality operators.*
+
+  This switch activates warnings for a user-defined "=" function that does
+  not compose (i.e. is ignored for a predefined "=" for a composite type
+  containing a component whose type has the user-defined "=" as
+  primitive). Note that the user-defined "=" must be a primitive operator
+  in order to trigger the warning.
+
+  The default is that these warnings are not given.
+
+.. index:: -gnatw_Q  (gcc)
+
+:switch:`-gnatw_Q`
+  *Suppress warnings for ignored equality operators.*
+
+
 .. index:: -gnatwr  (gcc)
 
 :switch:`-gnatwr`
diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads
index 78fe514..846a4a6 100644
--- a/gcc/ada/errout.ads
+++ b/gcc/ada/errout.ads
@@ -64,7 +64,7 @@ package Errout is
    --  sequences in error messages generate appropriate tags for the output
    --  error messages. If this switch is False, then these sequences are still
    --  recognized (for the purposes of implementing the pattern matching in
-   --  pragmas Warnings (Off,..) and Warning_As_Pragma(...) but do not result
+   --  pragmas Warnings (Off,..) and Warning_As_Error(...) but do not result
    --  in adding the error message tag. The -gnatw.d switch sets this flag
    --  True, -gnatw.D sets this flag False.
 
@@ -314,10 +314,11 @@ package Errout is
    --      continuations, use this in each continuation message.
 
    --    Insertion character ?x? ?.x? ?_x? (warning with switch)
-   --      Like ?, but if the flag Warn_Doc_Switch is True, adds the string
+   --      "x" is a (lower-case) warning switch character.
+   --      Like ??, but if the flag Warn_Doc_Switch is True, adds the string
    --      "[-gnatwx]", "[-gnatw.x]", or "[-gnatw_x]", at the end of the
-   --      warning message. x must be lower case. For continuations, use this
-   --      on each continuation message.
+   --      warning message. For continuations, use this on each continuation
+   --      message.
 
    --    Insertion character ?*? (restriction warning)
    --      Like ?, but if the flag Warn_Doc_Switch is True, adds the string
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index 0d82691..1e70b58 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -4599,7 +4599,8 @@ package body Exp_Ch3 is
       end if;
 
       --  If not inherited and not user-defined, build body as for a type with
-      --  tagged components.
+      --  components of record type (i.e. a type for which "=" composes when
+      --  used as a component in an outer composite type).
 
       if Build_Eq then
          Decl :=
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index b9433c3..4a60ff5 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -151,14 +151,17 @@ package body Exp_Ch4 is
    --  where we allow comparison of "out of range" values.
 
    function Expand_Composite_Equality
-     (Nod : Node_Id;
-      Typ : Entity_Id;
-      Lhs : Node_Id;
-      Rhs : Node_Id) return Node_Id;
+     (Outer_Type : Entity_Id;
+      Nod        : Node_Id;
+      Comp_Type  : Entity_Id;
+      Lhs        : Node_Id;
+      Rhs        : Node_Id) return Node_Id;
    --  Local recursive function used to expand equality for nested composite
    --  types. Used by Expand_Record/Array_Equality. Nod provides the Sloc value
    --  for generated code. Lhs and Rhs are the left and right sides for the
-   --  comparison, and Typ is the type of the objects to compare.
+   --  comparison, and Comp_Typ is the type of the objects to compare.
+   --  Outer_Type is the composite type containing a component of type
+   --  Comp_Type -- used for printing messages.
 
    procedure Expand_Concatenate (Cnode : Node_Id; Opnds : List_Id);
    --  Routine to expand concatenation of a sequence of two or more operands
@@ -1721,7 +1724,8 @@ package body Exp_Ch4 is
              Prefix      => Make_Identifier (Loc, Chars (B)),
              Expressions => Index_List2);
 
-         Test := Expand_Composite_Equality (Nod, Component_Type (Typ), L, R);
+         Test := Expand_Composite_Equality
+           (Typ, Nod, Component_Type (Typ), L, R);
 
          --  If some (sub)component is an unchecked_union, the whole operation
          --  will raise program error.
@@ -1953,7 +1957,6 @@ package body Exp_Ch4 is
       if Ltyp /= Rtyp then
          Ltyp := Base_Type (Ltyp);
          Rtyp := Base_Type (Rtyp);
-         pragma Assert (Ltyp = Rtyp);
       end if;
 
       --  If the array type is distinct from the type of the arguments, it
@@ -1976,6 +1979,7 @@ package body Exp_Ch4 is
          New_Rhs := Rhs;
       end if;
 
+      pragma Assert (Ltyp = Rtyp);
       First_Idx := First_Index (Ltyp);
 
       --  If optimization is enabled and the array boils down to a couple of
@@ -1983,7 +1987,6 @@ package body Exp_Ch4 is
       --  which should be easier to optimize by the code generator.
 
       if Optimization_Level > 0
-        and then Ltyp = Rtyp
         and then Is_Constrained (Ltyp)
         and then Number_Dimensions (Ltyp) = 1
         and then Compile_Time_Known_Bounds (Ltyp)
@@ -2010,7 +2013,7 @@ package body Exp_Ch4 is
                 Prefix      => New_Copy_Tree (New_Rhs),
                 Expressions => New_List (New_Copy_Tree (Low_B)));
 
-            TestL := Expand_Composite_Equality (Nod, Ctyp, L, R);
+            TestL := Expand_Composite_Equality (Ltyp, Nod, Ctyp, L, R);
 
             L :=
               Make_Indexed_Component (Loc,
@@ -2022,7 +2025,7 @@ package body Exp_Ch4 is
                 Prefix      => New_Rhs,
                 Expressions => New_List (New_Copy_Tree (High_B)));
 
-            TestH := Expand_Composite_Equality (Nod, Ctyp, L, R);
+            TestH := Expand_Composite_Equality (Ltyp, Nod, Ctyp, L, R);
 
             return
               Make_And_Then (Loc, Left_Opnd => TestL, Right_Opnd => TestH);
@@ -2435,20 +2438,21 @@ package body Exp_Ch4 is
    --  case because it is not possible to respect normal Ada visibility rules.
 
    function Expand_Composite_Equality
-     (Nod : Node_Id;
-      Typ : Entity_Id;
-      Lhs : Node_Id;
-      Rhs : Node_Id) return Node_Id
+     (Outer_Type : Entity_Id;
+      Nod        : Node_Id;
+      Comp_Type  : Entity_Id;
+      Lhs        : Node_Id;
+      Rhs        : Node_Id) return Node_Id
    is
       Loc       : constant Source_Ptr := Sloc (Nod);
       Full_Type : Entity_Id;
       Eq_Op     : Entity_Id;
 
    begin
-      if Is_Private_Type (Typ) then
-         Full_Type := Underlying_Type (Typ);
+      if Is_Private_Type (Comp_Type) then
+         Full_Type := Underlying_Type (Comp_Type);
       else
-         Full_Type := Typ;
+         Full_Type := Comp_Type;
       end if;
 
       --  If the private type has no completion the context may be the
@@ -2473,7 +2477,7 @@ package body Exp_Ch4 is
       --  Case of tagged record types
 
       if Is_Tagged_Type (Full_Type) then
-         Eq_Op := Find_Primitive_Eq (Typ);
+         Eq_Op := Find_Primitive_Eq (Comp_Type);
          pragma Assert (Present (Eq_Op));
 
          return
@@ -2635,18 +2639,20 @@ package body Exp_Ch4 is
 
          --  Equality composes in Ada 2012 for untagged record types. It also
          --  composes for bounded strings, because they are part of the
-         --  predefined environment. We could make it compose for bounded
-         --  strings by making them tagged, or by making sure all subcomponents
-         --  are set to the same value, even when not used. Instead, we have
-         --  this special case in the compiler, because it's more efficient.
-
-         elsif Ada_Version >= Ada_2012 or else Is_Bounded_String (Typ) then
+         --  predefined environment (see 4.5.2(32.1/1)). We could make it
+         --  compose for bounded strings by making them tagged, or by making
+         --  sure all subcomponents are set to the same value, even when not
+         --  used. Instead, we have this special case in the compiler, because
+         --  it's more efficient.
 
+         elsif Ada_Version >= Ada_2012 or else Is_Bounded_String (Comp_Type)
+         then
             --  If no TSS has been created for the type, check whether there is
             --  a primitive equality declared for it.
 
             declare
-               Op : constant Node_Id := Build_Eq_Call (Typ, Loc, Lhs, Rhs);
+               Op : constant Node_Id :=
+                 Build_Eq_Call (Comp_Type, Loc, Lhs, Rhs);
 
             begin
                --  Use user-defined primitive if it exists, otherwise use
@@ -2666,6 +2672,33 @@ package body Exp_Ch4 is
       --  Case of non-record types (always use predefined equality)
 
       else
+         --  Print a warning if there is a user-defined "=", because it can be
+         --  surprising that the predefined "=" takes precedence over it.
+
+         --  Suppress the warning if the "user-defined" one is in the
+         --  predefined library, because those are defined to compose
+         --  properly by RM-4.5.2(32.1/1). Intrinsics also compose.
+
+         declare
+            Op : constant Entity_Id := Find_Primitive_Eq (Comp_Type);
+         begin
+            if Warn_On_Ignored_Equality
+              and then Present (Op)
+              and then not In_Predefined_Unit (Base_Type (Comp_Type))
+              and then not Is_Intrinsic_Subprogram (Op)
+            then
+               pragma Assert
+                 (Is_First_Subtype (Outer_Type)
+                   or else Is_Generic_Actual_Type (Outer_Type));
+               Error_Msg_Node_1 := Outer_Type;
+               Error_Msg_Node_2 := Comp_Type;
+               Error_Msg
+                 ("?_q?""="" for type & uses predefined ""="" for }", Loc);
+               Error_Msg_Sloc := Sloc (Op);
+               Error_Msg ("\?_q?""="" # is ignored here", Loc);
+            end if;
+         end;
+
          return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs);
       end if;
    end Expand_Composite_Equality;
@@ -13347,7 +13380,7 @@ package body Exp_Ch4 is
             end if;
 
             Check :=
-              Expand_Composite_Equality (Nod, Etype (C),
+              Expand_Composite_Equality (Typ, Nod, Etype (C),
                Lhs =>
                  Make_Selected_Component (Loc,
                    Prefix        => New_Lhs,
diff --git a/gcc/ada/exp_ch4.ads b/gcc/ada/exp_ch4.ads
index eb9b506..7efd105 100644
--- a/gcc/ada/exp_ch4.ads
+++ b/gcc/ada/exp_ch4.ads
@@ -97,7 +97,7 @@ package Exp_Ch4 is
    --  individually to yield the required Boolean result. Loc is the
    --  location for the generated nodes. Typ is the type of the record, and
    --  Lhs, Rhs are the record expressions to be compared, these
-   --  expressions need not to be analyzed but have to be side-effect free.
+   --  expressions need not be analyzed but have to be side-effect free.
    --  Nod provides the Sloc value for generated code.
 
    procedure Expand_Set_Membership (N : Node_Id);
diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi
index 0f23d5b..ff5cfa9 100644
--- a/gcc/ada/gnat_ugn.texi
+++ b/gcc/ada/gnat_ugn.texi
@@ -10733,6 +10733,9 @@ switch are:
 @code{-gnatw.q} (questionable layout of record types)
 
 @item 
+@code{-gnatw_q} (ignored equality)
+
+@item 
 @code{-gnatw_r} (out-of-order record representation clauses)
 
 @item 
@@ -11948,6 +11951,34 @@ This switch suppresses warnings for cases where the default layout of
 a record type would very likely cause inefficiencies.
 @end table
 
+@geindex -gnatw_q (gcc)
+
+
+@table @asis
+
+@item @code{-gnatw_q}
+
+`Activate warnings for ignored equality operators.'
+
+This switch activates warnings for a user-defined “=” function that does
+not compose (i.e. is ignored for a predefined “=” for a composite type
+containing a component whose type has the user-defined “=” as
+primitive). Note that the user-defined “=” must be a primitive operator
+in order to trigger the warning.
+
+The default is that these warnings are not given.
+@end table
+
+@geindex -gnatw_Q (gcc)
+
+
+@table @asis
+
+@item @code{-gnatw_Q}
+
+`Suppress warnings for ignored equality operators.'
+@end table
+
 @geindex -gnatwr (gcc)
 
 
diff --git a/gcc/ada/sem_case.adb b/gcc/ada/sem_case.adb
index bb732b7..244e53f 100644
--- a/gcc/ada/sem_case.adb
+++ b/gcc/ada/sem_case.adb
@@ -192,8 +192,13 @@ package body Sem_Case is
            record
               Low, High : Uint;
            end record;
+         function "=" (X, Y : Discrete_Range_Info) return Boolean is abstract;
+         --  Here (and below), we don't use "=", which is a good thing,
+         --  because it wouldn't work, because the user-defined "=" on
+         --  Uint does not compose according to Ada rules.
 
          type Composite_Range_Info is array (Part_Id) of Discrete_Range_Info;
+         function "=" (X, Y : Composite_Range_Info) return Boolean is abstract;
 
          type Choice_Range_Info (Is_Others : Boolean := False) is
            record
@@ -204,6 +209,7 @@ package body Sem_Case is
                     null;
               end case;
            end record;
+         function "=" (X, Y : Choice_Range_Info) return Boolean is abstract;
 
          type Choices_Range_Info is array (Choice_Id) of Choice_Range_Info;
 
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index 2126bed..e651b20 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -1887,7 +1887,7 @@ package Sem_Util is
 
    function Is_Bounded_String (T : Entity_Id) return Boolean;
    --  True if T is a bounded string type. Used to make sure "=" composes
-   --  properly for bounded string types.
+   --  properly for bounded string types (see 4.5.2(32.1/1)).
 
    function Is_By_Protected_Procedure (Id : Entity_Id) return Boolean;
    --  Determine whether entity Id denotes a procedure with synchronization
diff --git a/gcc/ada/warnsw.adb b/gcc/ada/warnsw.adb
index 4a7dcc3..733c962 100644
--- a/gcc/ada/warnsw.adb
+++ b/gcc/ada/warnsw.adb
@@ -80,6 +80,7 @@ package body Warnsw is
       Warn_On_Questionable_Layout          := Setting;
       Warn_On_Questionable_Missing_Parens  := Setting;
       Warn_On_Record_Holes                 := Setting;
+      Warn_On_Ignored_Equality             := Setting;
       Warn_On_Component_Order              := Setting;
       Warn_On_Redundant_Constructs         := Setting;
       Warn_On_Reverse_Bit_Order            := Setting;
@@ -181,6 +182,8 @@ package body Warnsw is
         W.Warn_On_Questionable_Missing_Parens;
       Warn_On_Record_Holes                 :=
         W.Warn_On_Record_Holes;
+      Warn_On_Ignored_Equality              :=
+        W.Warn_On_Ignored_Equality;
       Warn_On_Component_Order              :=
         W.Warn_On_Component_Order;
       Warn_On_Redundant_Constructs         :=
@@ -295,6 +298,8 @@ package body Warnsw is
         Warn_On_Questionable_Missing_Parens;
       W.Warn_On_Record_Holes                 :=
         Warn_On_Record_Holes;
+      W.Warn_On_Ignored_Equality             :=
+        Warn_On_Ignored_Equality;
       W.Warn_On_Component_Order              :=
         Warn_On_Component_Order;
       W.Warn_On_Redundant_Constructs         :=
@@ -516,6 +521,12 @@ package body Warnsw is
          when 'P' =>
             Warn_On_Pedantic_Checks := False;
 
+         when 'q' =>
+            Warn_On_Ignored_Equality := True;
+
+         when 'Q' =>
+            Warn_On_Ignored_Equality := False;
+
          when 'r' =>
             Warn_On_Component_Order := True;
 
diff --git a/gcc/ada/warnsw.ads b/gcc/ada/warnsw.ads
index 8fe5ef7..9edd6be 100644
--- a/gcc/ada/warnsw.ads
+++ b/gcc/ada/warnsw.ads
@@ -77,6 +77,12 @@ package Warnsw is
    --  Warn when explicit record component clauses leave uncovered holes (gaps)
    --  in a record layout. Off by default, set by -gnatw.h (but not -gnatwa).
 
+   Warn_On_Ignored_Equality : Boolean := False;
+   --  Warn when a user-defined "=" function does not compose (i.e. is ignored
+   --  for a predefined "=" for a composite type containing a component of
+   --  whose type has the user-defined "=" as primitive). Off by default, and
+   --  set by -gnatw_q (but not -gnatwa).
+
    Warn_On_Component_Order : Boolean := False;
    --  Warn when record component clauses are out of order with respect to the
    --  component declarations, or if the memory layout is out of order with
@@ -140,6 +146,7 @@ package Warnsw is
       Warn_On_Questionable_Layout          : Boolean;
       Warn_On_Questionable_Missing_Parens  : Boolean;
       Warn_On_Record_Holes                 : Boolean;
+      Warn_On_Ignored_Equality             : Boolean;
       Warn_On_Component_Order              : Boolean;
       Warn_On_Redundant_Constructs         : Boolean;
       Warn_On_Reverse_Bit_Order            : Boolean;
@@ -156,7 +163,7 @@ package Warnsw is
    end record;
 
    function Save_Warnings return Warning_Record;
-   --  Returns current settingh of warnings
+   --  Returns current settings of warnings
 
    procedure Restore_Warnings (W : Warning_Record);
    --  Restores current settings of warning flags from W