[Ada] Remove out-of-range warning in unreachable code

This patch removes a warning in examples like this:

    if cond then
       return; -- or other jump
    end if;
    X := ...; -- where the value is out of range

where cond is known at compile time. It could, for example, be a generic
formal parameter that is known to be True in some instances.

As a side effect, this patch adds new warnings about unreachable code.

gcc/ada/

	* gnatls.adb (Output_License_Information): Remove pragma
	No_Return; call sites deal with Exit_Program.
	* libgnat/g-socthi.adb (C_Connect): Suppress warning about
	unreachable code.
	* sem_ch5.adb (Check_Unreachable_Code): Special-case if
	statements with static conditions.  If we remove unreachable
	code (including the return statement) from a function, add
	"raise Program_Error", so we won't warn about missing returns.
	Remove Original_Node in test for N_Raise_Statement; it's not
	needed.  Remove test for CodePeer_Mode; if Operating_Mode =
	Generate_Code, then CodePeer_Mode can't be True.  Misc cleanup.
	Do not reuse Nxt variable for unrelated purpose (the usage in
	the Kill_Dead_Code loop is entirely local to the loop).
	* sem_ch6.adb: Add check for Is_Transfer. Misc cleanup.
	* sem_prag.adb: Minor.
	* sem_res.adb: Minor.
	* sem_util.adb: Minor cleanup.
	(Is_Trivial_Boolean): Move to nonnested place, so it can be
	called from elsewhere.
	(Is_Static_Constant_Boolean): New function.
	* sem_util.ads (Is_Trivial_Boolean): Export.
	(Is_Static_Constant_Boolean): New function.

8 files changed, 117 insertions, 64 deletions

diff --git a/gcc/ada/gnatls.adb b/gcc/ada/gnatls.adb
index 7244526..6e7e722 100644
--- a/gcc/ada/gnatls.adb
+++ b/gcc/ada/gnatls.adb
@@ -189,7 +189,6 @@ procedure Gnatls is
    --  Print usage message
 
    procedure Output_License_Information;
-   pragma No_Return (Output_License_Information);
    --  Output license statement, and if not found, output reference to COPYING
 
    function Image (Restriction : Restriction_Id) return String;
@@ -894,8 +893,6 @@ procedure Gnatls is
                      & " for license terms.");
             Write_Eol;
       end case;
-
-      Exit_Program (E_Success);
    end Output_License_Information;
 
    -------------------
diff --git a/gcc/ada/libgnat/g-socthi.adb b/gcc/ada/libgnat/g-socthi.adb
index e70b85b..f5a3df9 100644
--- a/gcc/ada/libgnat/g-socthi.adb
+++ b/gcc/ada/libgnat/g-socthi.adb
@@ -187,7 +187,9 @@ package body GNAT.Sockets.Thin is
          return Res;
       end if;
 
-      declare
+      pragma Warnings (Off, "unreachable code");
+      declare -- unreachable if Thread_Blocking_IO is statically True
+         pragma Warnings (On, "unreachable code");
          WSet : aliased Fd_Set;
          Now  : aliased Timeval;
 
diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb
index f38c213..b2a3661 100644
--- a/gcc/ada/sem_ch5.adb
+++ b/gcc/ada/sem_ch5.adb
@@ -4425,7 +4425,7 @@ package body Sem_Ch5 is
 
             if not (Present (Current_Subprogram)
                     and then Ekind (Current_Subprogram) = E_Function
-                    and then (Nkind (Original_Node (N)) = N_Raise_Statement
+                    and then (Nkind (N) in N_Raise_Statement
                                 or else
                               (Nkind (N) = N_Procedure_Call_Statement
                                and then Is_Entity_Name (Name (N))
@@ -4444,39 +4444,59 @@ package body Sem_Ch5 is
                --  unreachable code, since it is useless and we don't want
                --  to generate junk warnings.
 
-               --  We skip this step if we are not in code generation mode
-               --  or CodePeer mode.
+               --  We skip this step if we are not in code generation mode.
 
                --  This is the one case where we remove dead code in the
                --  semantics as opposed to the expander, and we do not want
                --  to remove code if we are not in code generation mode, since
                --  this messes up the tree or loses useful information for
-               --  CodePeer.
+               --  analysis tools such as CodePeer.
 
                --  Note that one might react by moving the whole circuit to
                --  exp_ch5, but then we lose the warning in -gnatc mode.
 
-               if Operating_Mode = Generate_Code
-                 and then not CodePeer_Mode
-               then
+               if Operating_Mode = Generate_Code then
                   loop
-                     Nxt := Next (N);
-
-                     --  Quit deleting when we have nothing more to delete
-                     --  or if we hit a label (since someone could transfer
-                     --  control to a label, so we should not delete it).
+                     declare
+                        Del : constant Node_Id := Next (N);
+                        --  Node to be possibly deleted
+                     begin
+                        --  Quit deleting when we have nothing more to delete
+                        --  or if we hit a label (since someone could transfer
+                        --  control to a label, so we should not delete it).
 
-                     exit when No (Nxt) or else Nkind (Nxt) = N_Label;
+                        exit when No (Del) or else Nkind (Del) = N_Label;
 
-                     --  Statement/declaration is to be deleted
+                        --  Statement/declaration is to be deleted
 
-                     Analyze (Nxt);
-                     Remove (Nxt);
-                     Kill_Dead_Code (Nxt);
+                        Analyze (Del);
+                        Kill_Dead_Code (Del);
+                        Remove (Del);
+                     end;
                   end loop;
+
+                  --  If this is a function, we add "raise Program_Error;",
+                  --  because otherwise, we will get incorrect warnings about
+                  --  falling off the end of the function.
+
+                  declare
+                     Subp : constant Entity_Id := Current_Subprogram;
+                  begin
+                     if Present (Subp) and then Ekind (Subp) = E_Function then
+                        Insert_After_And_Analyze (N,
+                          Make_Raise_Program_Error (Sloc (Error_Node),
+                            Reason => PE_Missing_Return));
+                     end if;
+                  end;
+
                end if;
 
-               Error_Msg_N ("??unreachable code!", Error_Node);
+               --  Suppress the warning in instances, because a statement can
+               --  be unreachable in some instances but not others.
+
+               if not In_Instance then
+                  Error_Msg_N ("??unreachable code!", Error_Node);
+               end if;
             end if;
 
          --  If the unconditional transfer of control instruction is the
@@ -4535,9 +4555,33 @@ package body Sem_Ch5 is
             end if;
 
             --  This was one of the cases we are looking for (i.e. the parent
-            --  construct was IF, CASE or block) so decrement count.
-
-            Unblocked_Exit_Count := Unblocked_Exit_Count - 1;
+            --  construct was IF, CASE or block). In most cases, we simply
+            --  decrement the count. However, if the parent is something like:
+            --
+            --     if cond then
+            --        raise ...; -- or some other jump
+            --     end if;
+            --
+            --  where cond is an expression that is known-true at compile time,
+            --  we can treat that as just the jump -- i.e. anything following
+            --  the if statement is unreachable. We don't do this for simple
+            --  cases like "if True" or "if Debug_Flag", because that causes
+            --  too many warnings.
+
+            if Nkind (P) = N_If_Statement
+              and then Present (Then_Statements (P))
+              and then No (Elsif_Parts (P))
+              and then No (Else_Statements (P))
+              and then Is_OK_Static_Expression (Condition (P))
+              and then Is_True (Expr_Value (Condition (P)))
+              and then not Is_Trivial_Boolean (Condition (P))
+              and then not Is_Static_Constant_Name (Condition (P))
+            then
+               pragma Assert (Unblocked_Exit_Count = 2);
+               Unblocked_Exit_Count := 0;
+            else
+               Unblocked_Exit_Count := Unblocked_Exit_Count - 1;
+            end if;
          end if;
       end if;
    end Check_Unreachable_Code;
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 85edfab..4d766b9 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -7564,6 +7564,8 @@ package body Sem_Ch6 is
       Err  : out Boolean;
       Proc : Entity_Id := Empty)
    is
+      pragma Assert (Mode in 'F' | 'P');
+      pragma Assert (if Mode = 'F' then No (Proc));
       Handler : Node_Id;
 
       procedure Check_Statement_Sequence (L : List_Id);
@@ -7613,15 +7615,13 @@ package body Sem_Ch6 is
 
          --  Local variables
 
-         Raise_Exception_Call : Boolean;
+         Raise_Exception_Call : Boolean := False;
          --  Set True if statement sequence terminated by Raise_Exception call
          --  or a Reraise_Occurrence call.
 
       --  Start of processing for Check_Statement_Sequence
 
       begin
-         Raise_Exception_Call := False;
-
          --  Get last real statement
 
          Last_Stm := Last (L);
@@ -7687,7 +7687,8 @@ package body Sem_Ch6 is
 
          while Nkind (Last_Stm) = N_Pragma
 
-         --  Don't count call to SS_Release (can happen after Raise_Exception)
+           --  Don't count call to SS_Release (can happen after
+           --  Raise_Exception).
 
            or else
              (Nkind (Last_Stm) = N_Procedure_Call_Statement
@@ -7696,7 +7697,7 @@ package body Sem_Ch6 is
                 and then
               Is_RTE (Entity (Name (Last_Stm)), RE_SS_Release))
 
-         --  Don't count exception junk
+           --  Don't count exception junk
 
            or else
              (Nkind (Last_Stm) in
@@ -7704,10 +7705,12 @@ package body Sem_Ch6 is
                and then Exception_Junk (Last_Stm))
            or else Nkind (Last_Stm) in N_Push_xxx_Label | N_Pop_xxx_Label
 
-         --  Inserted code, such as finalization calls, is irrelevant: we only
-         --  need to check original source.
+           --  Inserted code, such as finalization calls, is irrelevant; we
+           --  only need to check original source. If we see a transfer of
+           --  control, we stop.
 
-           or else Is_Rewrite_Insertion (Last_Stm)
+           or else (Is_Rewrite_Insertion (Last_Stm)
+                      and then not Is_Transfer (Last_Stm))
          loop
             Prev (Last_Stm);
          end loop;
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index ad43808..a24d19e 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -6694,7 +6694,7 @@ package body Sem_Prag is
                if Loc not in Source_First (Sindex) .. Source_Last (Sindex) then
                   --  We do not want to raise an exception here since this code
                   --  is part of the bootstrap path where we cannot rely on
-                  --  exception proapgation working.
+                  --  exception propagation working.
                   --  Instead the caller should check for N being rewritten as
                   --  a null statement.
                   --  This code triggers when compiling a-except.adb.
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index 4335940..44fc955 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -7196,9 +7196,7 @@ package body Sem_Res is
 
       --  Check unreachable code after calls to procedures with No_Return
 
-      if Ekind (Nam) = E_Procedure
-        and then No_Return (Nam)
-      then
+      if Ekind (Nam) = E_Procedure and then No_Return (Nam) then
          Check_Unreachable_Code (N);
       end if;
 
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 9cff0f7..cfbf010 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -4868,9 +4868,6 @@ package body Sem_Util is
       --  and post-state. Prag is a [refined] postcondition or a contract-cases
       --  pragma. Result_Seen is set when the pragma mentions attribute 'Result
 
-      function Is_Trivial_Boolean (N : Node_Id) return Boolean;
-      --  Determine whether source node N denotes "True" or "False"
-
       -------------------------------------------
       -- Check_Result_And_Post_State_In_Pragma --
       -------------------------------------------
@@ -5243,20 +5240,6 @@ package body Sem_Util is
          end if;
       end Check_Result_And_Post_State_In_Pragma;
 
-      ------------------------
-      -- Is_Trivial_Boolean --
-      ------------------------
-
-      function Is_Trivial_Boolean (N : Node_Id) return Boolean is
-      begin
-         return
-           Comes_From_Source (N)
-             and then Is_Entity_Name (N)
-             and then (Entity (N) = Standard_True
-                         or else
-                       Entity (N) = Standard_False);
-      end Is_Trivial_Boolean;
-
       --  Local variables
 
       Items        : constant Node_Id := Contract (Subp_Id);
@@ -21501,19 +21484,15 @@ package body Sem_Util is
       Kind : constant Node_Kind := Nkind (N);
 
    begin
-      if Kind = N_Simple_Return_Statement
-           or else
-         Kind = N_Extended_Return_Statement
-           or else
-         Kind = N_Goto_Statement
-           or else
-         Kind = N_Raise_Statement
-           or else
-         Kind = N_Requeue_Statement
+      if Kind in N_Simple_Return_Statement
+               | N_Extended_Return_Statement
+               | N_Goto_Statement
+               | N_Raise_Statement
+               | N_Requeue_Statement
       then
          return True;
 
-      elsif (Kind = N_Exit_Statement or else Kind in N_Raise_xxx_Error)
+      elsif Kind in N_Exit_Statement | N_Raise_xxx_Error
         and then No (Condition (N))
       then
          return True;
@@ -21542,6 +21521,29 @@ package body Sem_Util is
       return No (U) or else U = Uint_1;
    end Is_True;
 
+   ------------------------
+   -- Is_Trivial_Boolean --
+   ------------------------
+
+   function Is_Trivial_Boolean (N : Node_Id) return Boolean is
+   begin
+      return Comes_From_Source (N)
+        and then Nkind (N) in N_Identifier | N_Expanded_Name
+        and then Entity (N) in Standard_True | Standard_False;
+   end Is_Trivial_Boolean;
+
+   -----------------------------
+   -- Is_Static_Constant_Name --
+   -----------------------------
+
+   function Is_Static_Constant_Name (N : Node_Id) return Boolean is
+   begin
+      return Comes_From_Source (N)
+        and then Is_Static_Expression (N)
+        and then Nkind (N) in N_Identifier | N_Expanded_Name
+        and then Ekind (Entity (N)) = E_Constant;
+   end Is_Static_Constant_Name;
+
    --------------------------------------
    -- Is_Unchecked_Conversion_Instance --
    --------------------------------------
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index a8afda0..e5b1118 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -2481,6 +2481,13 @@ package Sem_Util is
    --  unconditional transfer of control at run time, i.e. the following
    --  statement definitely will not be executed.
 
+   function Is_Trivial_Boolean (N : Node_Id) return Boolean;
+   --  Determine whether source node N denotes "True" or "False". Note that
+   --  this is not true for expressions that got folded to True or False.
+
+   function Is_Static_Constant_Name (N : Node_Id) return Boolean;
+   --  True if N is a name that statically denotes a static constant.
+
    function Is_Unchecked_Conversion_Instance (Id : Entity_Id) return Boolean;
    --  Determine whether an arbitrary entity denotes an instance of function
    --  Ada.Unchecked_Conversion.