From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from mail-wm1-x329.google.com (mail-wm1-x329.google.com [IPv6:2a00:1450:4864:20::329]) by sourceware.org (Postfix) with ESMTPS id 22E673857029 for ; Mon, 7 Nov 2022 08:41:34 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org 22E673857029 Authentication-Results: sourceware.org; dmarc=pass (p=none dis=none) header.from=adacore.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=adacore.com Received: by mail-wm1-x329.google.com with SMTP id 5so6408999wmo.1 for ; Mon, 07 Nov 2022 00:41:34 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; h=content-transfer-encoding:mime-version:message-id:date:subject:cc :to:from:from:to:cc:subject:date:message-id:reply-to; bh=+A2hweQUoU0T0Hr05EYMtytGVOzP4rYlbF1tJ83xmpk=; b=VSbc55lUFeQkOk4tFWcQvRa12aXGhCIfpNN/52Hqj/QBYVJax0ulsOWyl17RI+SVN+ ZYlAJYqtu0xzQL+wV6m+iyx0c/LUQysjwIWRHp/YHLXbI4E4VKfL/V+TRSdi1mNk0rz5 vwUWTjdN4jmth9UIth2DX6a1PubJSt3Jl8lK3asC6aiGxuMOCLz+uyAcR3C4fiCHZv7+ 3UHpv1ij7ena6PO7Dkqb3KG8lJppDzpzjdJJGq7VHLal05ElrhJYc7kYiMhIr6YqW5+C aaxPymQHQhU4fDd8EfputyGs9GbDWMqQrifr2G6PKYTwgu5vO4nOIICb7eOL1qxjGxh4 Ovkw== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20210112; h=content-transfer-encoding:mime-version:message-id:date:subject:cc :to:from:x-gm-message-state:from:to:cc:subject:date:message-id :reply-to; bh=+A2hweQUoU0T0Hr05EYMtytGVOzP4rYlbF1tJ83xmpk=; b=p0tUM2KxrIxjD20Dep/FfJ+IyNk9YTmU9sFzvqtQd0Q6XZVR3u0VNPtH7o4CYZ8KSi bPFzq5nWYEwy4p14gWxZBO3eUoG9/znvQd2S/KosVcU0uUfmKUagYD0IvMSlKA47Am29 xLKRkIFvJ0d7huR0A3X/IfkSYaDwnnN0UwbAlu3L9qaeayxVbKdavmdFqOjRGvBtJVma qimHtiuG/LVk7QXt9RLKSDWeVXFJ3v3wzk6fMfnYEvlfVYY+i3s9eX7YCsI/PtRVvQgr zqnsQ2oS5SJQ0QWM0DrK1/iWeUcba5etB0ilJT6xHwjnz/jfRxXphFKB0olB980Qpj1u 8RUA== X-Gm-Message-State: ACrzQf1gJwPxeTmW/6iLeE5Pe/VFJn3jvxjvZ+oXaWCMKI9JPcvZGpBQ Fec/LQY3wDzCp4eusr47mssDJGbfYX8vNg== X-Google-Smtp-Source: AMsMyM5v4sN9T6FUAPVoiPVTEaruAAQnAXZF/20Crqx/T9E2/22Ik+qKFSX4jMqg8n84TqExMjNSjw== X-Received: by 2002:a05:600c:2d86:b0:3cf:5580:c84c with SMTP id i6-20020a05600c2d8600b003cf5580c84cmr32796762wmg.146.1667810492753; Mon, 07 Nov 2022 00:41:32 -0800 (PST) Received: from poulhies-Precision-5550.lan (static-176-191-105-132.ftth.abo.bbox.fr. [176.191.105.132]) by smtp.gmail.com with ESMTPSA id d33-20020a05600c4c2100b003cf37c5ddc0sm7326613wmp.22.2022.11.07.00.41.31 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Mon, 07 Nov 2022 00:41:32 -0800 (PST) From: =?UTF-8?q?Marc=20Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Bob Duff Subject: [COMMITTED] ada: New warning about noncomposing user-defined "=" Date: Mon, 7 Nov 2022 09:41:29 +0100 Message-Id: <20221107084129.151825-1-poulhies@adacore.com> X-Mailer: git-send-email 2.34.1 MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit X-Spam-Status: No, score=-13.4 required=5.0 tests=BAYES_00,DKIM_SIGNED,DKIM_VALID,DKIM_VALID_AU,DKIM_VALID_EF,GIT_PATCH_0,RCVD_IN_DNSWL_NONE,SPF_HELO_NONE,SPF_PASS,TXREP,WEIRD_QUOTING autolearn=ham autolearn_force=no version=3.4.6 X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on server2.sourceware.org List-Id: From: Bob Duff 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