* [COMMITTED] ada: New warning about noncomposing user-defined "="
@ 2022-11-07 8:41 Marc Poulhiès
0 siblings, 0 replies; only message in thread
From: Marc Poulhiès @ 2022-11-07 8:41 UTC (permalink / raw)
To: gcc-patches; +Cc: Bob Duff
From: Bob Duff <duff@adacore.com>
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.
Tested on x86_64-pc-linux-gnu, committed on master.
---
...building_executable_programs_with_gnat.rst | 21 +++++
gcc/ada/errout.ads | 9 +-
gcc/ada/exp_ch3.adb | 3 +-
gcc/ada/exp_ch4.adb | 85 +++++++++++++------
gcc/ada/exp_ch4.ads | 2 +-
gcc/ada/gnat_ugn.texi | 31 +++++++
gcc/ada/sem_case.adb | 6 ++
gcc/ada/sem_util.ads | 2 +-
gcc/ada/warnsw.adb | 11 +++
gcc/ada/warnsw.ads | 9 +-
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 83bc50f7e91..31e2e31421e 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 78fe51482ac..846a4a6c07b 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 0d826913f75..1e70b584f22 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 b9433c358bf..4a60ff59601 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 eb9b506f35b..7efd1058afa 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 0f23d5b6a35..ff5cfa9dbce 100644
--- a/gcc/ada/gnat_ugn.texi
+++ b/gcc/ada/gnat_ugn.texi
@@ -10732,6 +10732,9 @@ switch are:
@item
@code{-gnatw.q} (questionable layout of record types)
+@item
+@code{-gnatw_q} (ignored equality)
+
@item
@code{-gnatw_r} (out-of-order record representation clauses)
@@ -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 bb732b76eb9..244e53f5752 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 2126beda510..e651b205be2 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 4a7dcc3bdea..733c9620631 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 8fe5ef7f870..9edd6bea37e 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
--
2.34.1
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2022-11-07 8:41 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2022-11-07 8:41 [COMMITTED] ada: New warning about noncomposing user-defined "=" Marc Poulhiès
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).