From a3594ab9646e083eb0e5984907285f6f2162eeea Mon Sep 17 00:00:00 2001 From: Steve Baird Date: Thu, 15 Dec 2022 16:50:05 -0800 Subject: [PATCH] ada: Emit warnings for (some) ineffective static predicate tests Generate a warning if a static predicate tests for a value that does not belong to the parent subtype. For example, in subtype S is Positive with Static_Predicate => S not in 0 | 11 | 222; the 0 is ineffective because Positive already excludes that value. Generation of this new warning is controlled by the -gnatw_s switch, which can also be enabled via -gnatwa. gcc/ada/ * warnsw.ads: Add a new element, Warn_On_Ineffective_Predicate_Test, to the Opt_Warnings_Enum enumeration type. * warnsw.adb: Bind "-gnatw_s" to the new Warn_On_Ineffective_Predicate_Test switch. Add the new switch to the set of switches enabled by -gnata . * sem_ch13.adb (Build_Discrete_Static_Predicate): Declare new local procedure, Warn_If_Test_Ineffective, which conditionally generates new warning. Call this new procedure when building a new element of an RList. * doc/gnat_ugn/building_executable_programs_with_gnat.rst: Document the -gnatw_s switch (and the corresponding -gnatw_S switch). * gnat_ugn.texi: Regenerate. --- ...building_executable_programs_with_gnat.rst | 21 ++++ gcc/ada/gnat_ugn.texi | 35 +++++- gcc/ada/sem_ch13.adb | 113 ++++++++++++++---- gcc/ada/warnsw.adb | 6 +- gcc/ada/warnsw.ads | 9 +- 5 files changed, 158 insertions(+), 26 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 634bbc94c31f..79da3c2cbccf 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 @@ -2801,6 +2801,8 @@ of the pragma in the :title:`GNAT_Reference_manual`). * :switch:`-gnatw.s` (overridden size clause) + * :switch:`-gnatw_s` (ineffective predicate test) + * :switch:`-gnatwt` (tracking of deleted conditional code) * :switch:`-gnatw.u` (unordered enumeration) @@ -3834,6 +3836,25 @@ of the pragma in the :title:`GNAT_Reference_manual`). warnings when an array component size overrides a size clause. +.. index:: -gnatw_s (gcc) +.. index:: Warnings + +:switch:`-gnatw_s` + *Activate warnings on ineffective predicate tests.* + + This switch activates warnings on Static_Predicate aspect + specifications that test for values that do not belong to + the parent subtype. Not all such ineffective tests are detected. + +.. index:: -gnatw_S (gcc) + +:switch:`-gnatw_S` + *Suppress warnings on ineffective predicate tests.* + + This switch suppresses warnings on Static_Predicate aspect + specifications that test for values that do not belong to + the parent subtype. + .. index:: -gnatwt (gcc) .. index:: Deactivated code, warnings .. index:: Deleted code, warnings diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index e8512cb04713..bd2cb3e56292 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -10742,6 +10742,9 @@ switch are: @item @code{-gnatw.s} (overridden size clause) +@item +@code{-gnatw_s} (ineffective predicate test) + @item @code{-gnatwt} (tracking of deleted conditional code) @@ -12155,6 +12158,36 @@ representation clauses that override size clauses, and similar warnings when an array component size overrides a size clause. @end table +@geindex -gnatw_s (gcc) + +@geindex Warnings + + +@table @asis + +@item @code{-gnatw_s} + +`Activate warnings on ineffective predicate tests.' + +This switch activates warnings on Static_Predicate aspect +specifications that test for values that do not belong to +the parent subtype. Not all such ineffective tests are detected. +@end table + +@geindex -gnatw_S (gcc) + + +@table @asis + +@item @code{-gnatw_S} + +`Suppress warnings on ineffective predicate tests.' + +This switch suppresses warnings on Static_Predicate aspect +specifications that test for values that do not belong to +the parent subtype. +@end table + @geindex -gnatwt (gcc) @geindex Deactivated code @@ -29433,8 +29466,8 @@ to permit their use in free software. @printindex ge -@anchor{gnat_ugn/gnat_utility_programs switches-related-to-project-files}@w{ } @anchor{cf}@w{ } +@anchor{gnat_ugn/gnat_utility_programs switches-related-to-project-files}@w{ } @c %**end of body @bye diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 82345eca09e2..1c7572282419 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -8872,6 +8872,10 @@ package body Sem_Ch13 is -- Given a type, if it has a static predicate, then set Result to the -- predicate as a range list, otherwise set Static.all to False. + procedure Warn_If_Test_Ineffective (REntry : REnt; N : Node_Id); + -- Issue a warning if REntry includes only values that are + -- outside the range TLo .. THi. + ----------- -- "and" -- ----------- @@ -9126,8 +9130,9 @@ package body Sem_Ch13 is (Exp : Node_Id; Static : access Boolean) return RList is - Op : Node_Kind; - Val : Uint; + Op : Node_Kind; + Val : Uint; + Val_Bearer : Node_Id; begin -- Static expression can only be true or false @@ -9178,14 +9183,14 @@ package body Sem_Ch13 is if Is_Type_Ref (Left_Opnd (Exp)) and then Is_OK_Static_Expression (Right_Opnd (Exp)) then - Val := Expr_Value (Right_Opnd (Exp)); + Val_Bearer := Right_Opnd (Exp); -- Typ is right operand elsif Is_Type_Ref (Right_Opnd (Exp)) and then Is_OK_Static_Expression (Left_Opnd (Exp)) then - Val := Expr_Value (Left_Opnd (Exp)); + Val_Bearer := Left_Opnd (Exp); -- Invert sense of comparison @@ -9204,30 +9209,41 @@ package body Sem_Ch13 is return False_Range; end if; + Val := Expr_Value (Val_Bearer); + -- Construct range according to comparison operation - case Op is - when N_Op_Eq => - return RList'(1 => REnt'(Val, Val)); + declare + REntry : REnt; + begin + case Op is + when N_Op_Eq => + REntry := (Val, Val); - when N_Op_Ge => - return RList'(1 => REnt'(Val, BHi)); + when N_Op_Ge => + REntry := (Val, THi); - when N_Op_Gt => - return RList'(1 => REnt'(Val + 1, BHi)); + when N_Op_Gt => + REntry := (Val + 1, THi); - when N_Op_Le => - return RList'(1 => REnt'(BLo, Val)); + when N_Op_Le => + REntry := (TLo, Val); - when N_Op_Lt => - return RList'(1 => REnt'(BLo, Val - 1)); + when N_Op_Lt => + REntry := (TLo, Val - 1); - when N_Op_Ne => - return RList'(REnt'(BLo, Val - 1), REnt'(Val + 1, BHi)); + when N_Op_Ne => + Warn_If_Test_Ineffective ((Val, Val), Val_Bearer); + return RList'(REnt'(TLo, Val - 1), + REnt'(Val + 1, THi)); - when others => - raise Program_Error; - end case; + when others => + raise Program_Error; + end case; + + Warn_If_Test_Ineffective (REntry, Val_Bearer); + return RList'(1 => REntry); + end; -- Membership (IN) @@ -9443,7 +9459,12 @@ package body Sem_Ch13 is else SLo := Expr_Value (Low_Bound (N)); SHi := Expr_Value (High_Bound (N)); - return RList'(1 => REnt'(SLo, SHi)); + declare + REntry : constant REnt := (SLo, SHi); + begin + Warn_If_Test_Ineffective (REntry, N); + return RList'(1 => REntry); + end; end if; -- Others case @@ -9469,7 +9490,12 @@ package body Sem_Ch13 is elsif Is_OK_Static_Expression (N) then Val := Expr_Value (N); - return RList'(1 => REnt'(Val, Val)); + declare + REntry : constant REnt := (Val, Val); + begin + Warn_If_Test_Ineffective (REntry, N); + return RList'(1 => REntry); + end; -- Identifier (other than static expression) case @@ -9541,6 +9567,49 @@ package body Sem_Ch13 is end; end Stat_Pred; + procedure Warn_If_Test_Ineffective (REntry : REnt; N : Node_Id) is + + procedure IPT_Warning (Msg : String); + -- Emit warning + + ----------------- + -- IPT_Warning -- + ----------------- + procedure IPT_Warning (Msg : String) is + begin + Error_Msg_N ("ineffective predicate test " & Msg & "?_s?", N); + end IPT_Warning; + + -- Start of processing for Warn_If_Test_Ineffective + + begin + -- Do nothing if warning disabled + + if not Warn_On_Ineffective_Predicate_Test then + null; + + -- skip null-range corner cases + + elsif (REntry.Lo > REntry.Hi) or else (TLo > THi) then + null; + + -- warn if no overlap between subtype bounds and the given range + + elsif REntry.Lo > THi or else REntry.Hi < TLo then + Error_Msg_Uint_1 := REntry.Lo; + if REntry.Lo /= REntry.Hi then + Error_Msg_Uint_2 := REntry.Hi; + IPT_Warning ("range: ^ .. ^"); + elsif Is_Enumeration_Type (Typ) and then + Nkind (N) in N_Identifier | N_Expanded_Name + then + IPT_Warning ("value: &"); + else + IPT_Warning ("value: ^"); + end if; + end if; + end Warn_If_Test_Ineffective; + -- Start of processing for Build_Discrete_Static_Predicate begin diff --git a/gcc/ada/warnsw.adb b/gcc/ada/warnsw.adb index d1574887de9d..1931e02f5925 100644 --- a/gcc/ada/warnsw.adb +++ b/gcc/ada/warnsw.adb @@ -93,14 +93,15 @@ package body Warnsw is '_' => ('b' | 'd' | 'e' | 'f' | 'g' | 'h' | 'i' | 'j' | 'k' | 'l' | 'm' | - 'n' | 'o' | 's' | 't' | 'u' | 'v' | 'w' | 'x' | 'y' | 'z' => + 'n' | 'o' | 't' | 'u' | 'v' | 'w' | 'x' | 'y' | 'z' => No_Such_Warning, 'a' => X.Warn_On_Anonymous_Allocators, 'c' => X.Warn_On_Unknown_Compile_Time_Warning, 'p' => X.Warn_On_Pedantic_Checks, 'q' => X.Warn_On_Ignored_Equality, - 'r' => X.Warn_On_Component_Order)); + 'r' => X.Warn_On_Component_Order, + 's' => X.Warn_On_Ineffective_Predicate_Test)); All_Warnings : constant Warnings_State := -- Warnings set by -gnatw.e (X.Elab_Info_Messages | @@ -130,6 +131,7 @@ package body Warnsw is X.Warn_On_Biased_Representation | -- -gnatw.b X.Warn_On_Constant | -- -gnatwk X.Warn_On_Export_Import | -- -gnatwx + X.Warn_On_Ineffective_Predicate_Test | -- -gnatw_s X.Warn_On_Late_Primitives | -- -gnatw.j X.Warn_On_Modified_Unread | -- -gnatwm X.Warn_On_No_Value_Assigned | -- -gnatwv diff --git a/gcc/ada/warnsw.ads b/gcc/ada/warnsw.ads index 2636aba153aa..cee1f302490f 100644 --- a/gcc/ada/warnsw.ads +++ b/gcc/ada/warnsw.ads @@ -71,6 +71,7 @@ package Warnsw is Warn_On_Export_Import, Warn_On_Hiding, Warn_On_Ignored_Equality, + Warn_On_Ineffective_Predicate_Test, Warn_On_Late_Primitives, Warn_On_Modified_Unread, Warn_On_No_Value_Assigned, @@ -155,6 +156,7 @@ package Warnsw is Warn_On_Elab_Access | Warn_On_Hiding | Warn_On_Ignored_Equality | + Warn_On_Ineffective_Predicate_Test | Warn_On_Late_Primitives | Warn_On_Modified_Unread | Warn_On_Non_Local_Exception | @@ -215,7 +217,7 @@ package Warnsw is -- of the old ABE mechanism. Implementation_Unit_Warnings : Boolean renames F (X.Implementation_Unit_Warnings); - -- Set True to active warnings for use of implementation internal units. + -- Set True to activate warnings for use of implementation internal units. -- Modified by use of -gnatwi/-gnatwI. Ineffective_Inline_Warnings : Boolean renames F (X.Ineffective_Inline_Warnings); @@ -333,6 +335,11 @@ package Warnsw is -- whose type has the user-defined "=" as primitive). Off by default, and -- set by -gnatw_q (but not -gnatwa). + Warn_On_Ineffective_Predicate_Test : Boolean renames F (X.Warn_On_Ineffective_Predicate_Test); + -- Set to True to generate warnings if a static predicate is testing for + -- values that do not belong to the parent subtype. Modified by use of + -- -gnatw_s/S. + Warn_On_Late_Primitives : Boolean renames F (X.Warn_On_Late_Primitives); -- Warn when tagged type public primitives are defined after its private -- extensions. -- 2.43.5