* [COMMITTED] ada: Emit warnings for (some) ineffective static predicate tests
@ 2023-05-15 9:43 Marc Poulhiès
0 siblings, 0 replies; only message in thread
From: Marc Poulhiès @ 2023-05-15 9:43 UTC (permalink / raw)
To: gcc-patches; +Cc: Steve Baird
From: Steve Baird <baird@adacore.com>
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.
Tested on x86_64-pc-linux-gnu, committed on master.
---
...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 634bbc94c31..79da3c2cbcc 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 e8512cb0471..bd2cb3e5629 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 82345eca09e..1c757228241 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 d1574887de9..1931e02f592 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 2636aba153a..cee1f302490 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.40.0
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2023-05-15 9:43 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2023-05-15 9:43 [COMMITTED] ada: Emit warnings for (some) ineffective static predicate tests 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).