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.

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 634bbc9..79da3c2 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 e8512cb..bd2cb3e 100644
--- a/gcc/ada/gnat_ugn.texi
+++ b/gcc/ada/gnat_ugn.texi
@@ -10743,6 +10743,9 @@ switch are:
 @code{-gnatw.s} (overridden size clause)
 
 @item 
+@code{-gnatw_s} (ineffective predicate test)
+
+@item 
 @code{-gnatwt} (tracking of deleted conditional code)
 
 @item 
@@ -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 82345ec..1c75722 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 d157488..1931e02 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 2636aba..cee1f30 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.