FreeChainXenon/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

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

Browse source 
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.
This commit is contained in:
Bob Duff 2022-10-17 11:56:27 -04:00 • committed by Marc Poulhiès
parent 9b07c1752b
commit 2702882fdb
10 changed files with 145 additions and 34 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

21
gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst
View file

@ -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`

9
gcc/ada/errout.ads
View file

@ -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

3
gcc/ada/exp_ch3.adb
View file

@ -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 :=

85
gcc/ada/exp_ch4.adb
View file

@ -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,

2
gcc/ada/exp_ch4.ads
View file

@ -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);

31
gcc/ada/gnat_ugn.texi
View file

@ -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)

6
gcc/ada/sem_case.adb
View file

@ -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;

2
gcc/ada/sem_util.ads
View file

@ -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

11
gcc/ada/warnsw.adb
View file

@ -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;

9
gcc/ada/warnsw.ads
View file

@ -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