2013-10-10 Robert Dewar <dewar@adacore.com>

	* sem_aggr.adb (Resolve_Array_Aggregate): Redo duplicate/missing
	choice circuit. Was not quite right in some cases, which showed
	up in ACATS test B43201C.
	* sem_attr.adb (Address_Checks): Make sure name is set right
	for some messages issued.
	* mlib-prj.adb: Minor code reorganization.
	* gnat_ugn.texi: Remove special VMS doc for tagging of warning msgs.
	* exp_ch9.adb: Minor reformatting.

2013-10-10  Tristan Gingold  <gingold@adacore.com>

	* lib-writ.adb (Write_Unit_Information): Adjust previous patch.

2013-10-10  Robert Dewar  <dewar@adacore.com>

	* sem_ch5.adb (Analyze_If_Statement): Warn on redundant if
	statement.
	* sem_util.ads, sem_util.adb (Has_No_Obvious_Side_Effects): New
	function.

2013-10-10  Ed Schonberg  <schonberg@adacore.com>

	* exp_ch9.adb (Expand_N_Timed_Entry_Call): Simplify expansion
	for the case of a dispatching trigger: there is no need to
	duplicate the code or create a subprogram to encapsulate the
	triggering statements. This allows exit statements in the
	triggering statements, that refer to enclosing loops.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@203369 138bc75d-0d04-0410-961f-82ee72b054a4

10 files changed, 301 insertions, 177 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 179607dd347..740745727de 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,5 +1,35 @@
 2013-10-10  Robert Dewar  <dewar@adacore.com>
 
+	* sem_aggr.adb (Resolve_Array_Aggregate): Redo duplicate/missing
+	choice circuit. Was not quite right in some cases, which showed
+	up in ACATS test B43201C.
+	* sem_attr.adb (Address_Checks): Make sure name is set right
+	for some messages issued.
+	* mlib-prj.adb: Minor code reorganization.
+	* gnat_ugn.texi: Remove special VMS doc for tagging of warning msgs.
+	* exp_ch9.adb: Minor reformatting.
+
+2013-10-10  Tristan Gingold  <gingold@adacore.com>
+
+	* lib-writ.adb (Write_Unit_Information): Adjust previous patch.
+
+2013-10-10  Robert Dewar  <dewar@adacore.com>
+
+	* sem_ch5.adb (Analyze_If_Statement): Warn on redundant if
+	statement.
+	* sem_util.ads, sem_util.adb (Has_No_Obvious_Side_Effects): New
+	function.
+
+2013-10-10  Ed Schonberg  <schonberg@adacore.com>
+
+	* exp_ch9.adb (Expand_N_Timed_Entry_Call): Simplify expansion
+	for the case of a dispatching trigger: there is no need to
+	duplicate the code or create a subprogram to encapsulate the
+	triggering statements. This allows exit statements in the
+	triggering statements, that refer to enclosing loops.
+
+2013-10-10  Robert Dewar  <dewar@adacore.com>
+
 	* freeze.adb: Minor reformatting.
 	* sem_ch13.adb (Freeze_Entity_Checks): New procedure
 	(Analyze_Freeze_Entity): Call Freeze_Entity_Checks
diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb
index 738564c0e4a..8db80bde74b 100644
--- a/gcc/ada/exp_ch9.adb
+++ b/gcc/ada/exp_ch9.adb
@@ -11948,7 +11948,10 @@ package body Exp_Ch9 is
    --       end if;
    --    end;
 
-   --  3) Ada 2005 (AI-345): When T.E is a dispatching procedure call;
+   --  3) Ada 2005 (AI-345): When T.E is a dispatching procedure call, there
+   --     is no delay and the triggering statements are executed. We first
+   --     determine the kind of of the triggering call and then execute a
+   --     synchronized operation or a direct call.
 
    --    declare
    --       B  : Boolean := False;
@@ -11965,7 +11968,7 @@ package body Exp_Ch9 is
    --         or else K = Ada.Tags.TK_Tagged
    --       then
    --          <dispatching-call>;
-   --          <triggering-statements>
+   --          B := True;
 
    --       else
    --          S :=
@@ -11989,20 +11992,19 @@ package body Exp_Ch9 is
    --             then
    --                <dispatching-call>;
    --             end if;
-
-   --             <triggering-statements>
-   --          else
-   --             <timed-statements>
-   --          end if;
+   --         end if;
    --       end if;
+
+   --      if B then
+   --          <triggering-statements>
+   --      else
+   --          <timed-statements>
+   --      end if;
    --    end;
 
    --  The triggering statement and the sequence of timed statements have not
    --  been analyzed yet (see Analyzed_Timed_Entry_Call), but they may contain
-   --  global references if within an instantiation. To prevent duplication
-   --  between various uses of those statements, they are encapsulated into a
-   --  local procedure which is invoked multiple time when the trigger is a
-   --  dispatching call.
+   --  global references if within an instantiation.
 
    procedure Expand_N_Timed_Entry_Call (N : Node_Id) is
       Loc : constant Source_Ptr := Sloc (N);
@@ -12045,63 +12047,6 @@ package body Exp_Ch9 is
       P : Entity_Id;  --  Parameter block
       S : Entity_Id;  --  Primitive operation slot
 
-      procedure Rewrite_Triggering_Statements;
-      --  If the trigger is a dispatching call, the expansion inserts multiple
-      --  copies of the abortable part. This is both inefficient, and may lead
-      --  to duplicate definitions that the back-end will reject, when the
-      --  abortable part includes loops. This procedure rewrites the abortable
-      --  part into a call to a generated procedure.
-
-      -----------------------------------
-      -- Rewrite_Triggering_Statements --
-      -----------------------------------
-
-      procedure Rewrite_Triggering_Statements is
-         Proc : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA);
-         Decl : Node_Id;
-         Stat : Node_Id;
-
-      begin
-         Decl :=
-           Make_Subprogram_Body (Loc,
-             Specification              =>
-               Make_Procedure_Specification (Loc, Defining_Unit_Name => Proc),
-             Declarations               => New_List,
-             Handled_Statement_Sequence =>
-               Make_Handled_Sequence_Of_Statements (Loc, E_Stats));
-
-         Append_To (Decls, Decl);
-
-         --  Adjust the scope of blocks in the procedure. Needed because blocks
-         --  generate declarations that are processed before other analysis
-         --  takes place, and their scope is already set. The backend depends
-         --  on the scope chain to determine the legality of some anonymous
-         --  types, and thus we must indicate that the block is within the new
-         --  procedure.
-
-         Stat := First (E_Stats);
-         while Present (Stat) loop
-            if Nkind (Stat) = N_Block_Statement then
-               Insert_Before (Stat,
-                 Make_Implicit_Label_Declaration (Sloc (Stat),
-                   Defining_Identifier =>
-                     Make_Defining_Identifier (
-                       Sloc (Stat), Chars (Identifier (Stat)))));
-            end if;
-
-            Next (Stat);
-         end loop;
-
-         --  Analyze (Decl);
-
-         --  Rewrite abortable part into a call to this procedure.
-
-         E_Stats :=
-           New_List
-             (Make_Procedure_Call_Statement (Loc,
-                Name => New_Occurrence_Of (Proc, Loc)));
-      end Rewrite_Triggering_Statements;
-
    --  Start of processing for Expand_N_Timed_Entry_Call
 
    begin
@@ -12144,7 +12089,6 @@ package body Exp_Ch9 is
       if Is_Disp_Select then
          Extract_Dispatching_Call (E_Call, Call_Ent, Obj, Actuals, Formals);
          Decls := New_List;
-         Rewrite_Triggering_Statements;
 
          Stmts := New_List;
 
@@ -12349,20 +12293,10 @@ package body Exp_Ch9 is
          --       then
          --          <dispatching-call>
          --       end if;
-         --       <triggering-statements>
-         --    else
-         --       <timed-statements>
          --    end if;
 
-         --  Note: we used to do Copy_Separate_List here, but this was changed
-         --  to New_Copy_List_Tree with no explanation or RH note??? We should
-         --  explain the need for the change ???
-
-         N_Stats := New_Copy_List_Tree (E_Stats);
-
-         Prepend_To (N_Stats,
+         N_Stats := New_List (
            Make_Implicit_If_Statement (N,
-
              Condition =>
                Make_Or_Else (Loc,
                  Left_Opnd =>
@@ -12391,19 +12325,17 @@ package body Exp_Ch9 is
          Append_To (Conc_Typ_Stmts,
            Make_Implicit_If_Statement (N,
              Condition       => New_Reference_To (B, Loc),
-             Then_Statements => N_Stats,
-             Else_Statements => D_Stats));
+             Then_Statements => N_Stats));
 
          --  Generate:
          --    <dispatching-call>;
-         --    <triggering-statements>
-
-         --  Note: the following was Copy_Separate_List but it was changed to
-         --  New_Copy_List_Tree without comments or RH documentation ??? We
-         --  should explain the need for the change ???
+         --    B := True;
 
-         Lim_Typ_Stmts := New_Copy_List_Tree (E_Stats);
-         Prepend_To (Lim_Typ_Stmts, New_Copy_Tree (E_Call));
+         Lim_Typ_Stmts :=
+           New_List (New_Copy_Tree (E_Call),
+             Make_Assignment_Statement (Loc,
+               Name       => New_Occurrence_Of (B, Loc),
+               Expression => New_Occurrence_Of (Standard_True, Loc)));
 
          --  Generate:
          --    if K = Ada.Tags.TK_Limited_Tagged
@@ -12420,8 +12352,24 @@ package body Exp_Ch9 is
              Then_Statements => Lim_Typ_Stmts,
              Else_Statements => Conc_Typ_Stmts));
 
+         --    Generate:
+
+         --    if B then
+         --       <triggering-statements>
+         --    else
+         --       <timed-statements>
+         --    end if;
+
+         Append_To (Stmts,
+           Make_Implicit_If_Statement (N,
+             Condition       => New_Occurrence_Of (B, Loc),
+             Then_Statements => E_Stats,
+             Else_Statements => D_Stats));
+
       else
-         --  Skip assignments to temporaries created for in-out parameters.
+         --  Simple case of a non-dispatching trigger. Skip assignments to
+         --  temporaries created for in-out parameters.
+
          --  This makes unwarranted assumptions about the shape of the expanded
          --  tree for the call, and should be cleaned up ???
 
diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi
index b15aacd980c..c82dab7aa04 100644
--- a/gcc/ada/gnat_ugn.texi
+++ b/gcc/ada/gnat_ugn.texi
@@ -4931,7 +4931,6 @@ this warning option.
 This switch suppresses warnings for implicit dereferences in
 indexed components, slices, and selected components.
 
-@ifclear vms
 @item -gnatw.d
 @emph{Activate tagging of warning messages.}
 @cindex @option{-gnatw.d} (@command{gcc})
@@ -4947,25 +4946,6 @@ affected by the use of @code{-gnatwa}.
 If this switch is set, then warning messages return to the default
 mode in which warnings are not tagged as described above for
 @code{-gnatw.d}.
-@end ifclear
-
-@ifset vms
-@item -gnatw.d
-@emph{Activate tagging of warning messages.}
-@cindex @option{-gnatw.d} (@command{gcc})
-If this switch is set, then warning messages are tagged, either with
-the appropriate WARNINGS qualifier string (e.g. [SUSPICIOUS_MODULUS]
-or with ``[enabled by default]'' if the warning is not under control of a
-specific WARNING qualifier switch. This mode is off by default, and is not
-affected by the use of @code{-gnatwa}.
-
-@item -gnatw.D
-@emph{Deactivate tagging of warning messages.}
-@cindex @option{-gnatw.d} (@command{gcc})
-If this switch is set, then warning messages return to the default
-mode in which warnings are not tagged as described above for
-@code{-gnatw.d}.
-@end ifset
 
 @item -gnatwe
 @emph{Treat warnings and style checks as errors.}
diff --git a/gcc/ada/lib-writ.adb b/gcc/ada/lib-writ.adb
index afc83d98b90..c4b5e5088fc 100644
--- a/gcc/ada/lib-writ.adb
+++ b/gcc/ada/lib-writ.adb
@@ -628,6 +628,7 @@ package body Lib.Writ is
             if Is_Generic_Unit (Cunit_Entity (Main_Unit))
               and then
                 Is_Predefined_File_Name (Unit_File_Name (Current_Sem_Unit))
+              and then Linker_Option_Lines.Table (J).Unit = Unit_Num
             then
                Set_Standard_Error;
                Write_Line
diff --git a/gcc/ada/mlib-prj.adb b/gcc/ada/mlib-prj.adb
index 4105901a634..945f9137252 100644
--- a/gcc/ada/mlib-prj.adb
+++ b/gcc/ada/mlib-prj.adb
@@ -1185,9 +1185,9 @@ package body MLib.Prj is
 
                   Delete_File (Get_Name_String (Path), Succ);
 
-                  if not Succ then
-                     null;
-                  end if;
+                  --  We ignore a failure in this Delete_File operation.
+                  --  Is that OK??? If so, worth a comment as to why we
+                  --  are OK with the operation failing
                end;
             end if;
 
diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb
index 96f1a40868b..5aec38a32d0 100644
--- a/gcc/ada/sem_aggr.adb
+++ b/gcc/ada/sem_aggr.adb
@@ -65,23 +65,35 @@ with Uintp;    use Uintp;
 package body Sem_Aggr is
 
    type Case_Bounds is record
-     Choice_Lo   : Node_Id;
-     Choice_Hi   : Node_Id;
-     Choice_Node : Node_Id;
+      Lo : Node_Id;
+      --  Low bound of choice. Once we sort the Case_Table, then entries
+      --  will be in order of ascending Choice_Lo values.
+
+      Hi : Node_Id;
+      --  High Bound of choice. The sort does not pay any attention to the
+      --  high bound, so choices 1 .. 4 and 1 .. 5 could be in either order.
+
+      Highest : Uint;
+      --  If there are duplicates or missing entries, then in the sorted
+      --  table, this records the highest value among Choice_Hi values
+      --  seen so far, including this entry.
+
+      Choice : Node_Id;
+      --  The node of the choice
    end record;
 
    type Case_Table_Type is array (Nat range <>) of Case_Bounds;
-   --  Table type used by Check_Case_Choices procedure
+   --  Table type used by Check_Case_Choices procedure. Entry zero is not
+   --  used (reserved for the sort). Real entries start at one.
 
    -----------------------
    -- Local Subprograms --
    -----------------------
 
    procedure Sort_Case_Table (Case_Table : in out Case_Table_Type);
-   --  Sort the Case Table using the Lower Bound of each Choice as the key.
-   --  A simple insertion sort is used since the number of choices in a case
-   --  statement of variant part will usually be small and probably in near
-   --  sorted order.
+   --  Sort the Case Table using the Lower Bound of each Choice as the key. A
+   --  simple insertion sort is used since the choices in a case statement will
+   --  usually be in near sorted order.
 
    procedure Check_Can_Never_Be_Null (Typ : Entity_Id; Expr : Node_Id);
    --  Ada 2005 (AI-231): Check bad usage of null for a component for which
@@ -1905,8 +1917,9 @@ package body Sem_Aggr is
             --  if a choice in an aggregate is a subtype indication these
             --  denote the lowest and highest values of the subtype
 
-            Table : Case_Table_Type (1 .. Case_Table_Size);
-            --  Used to sort all the different choice values
+            Table : Case_Table_Type (0 .. Case_Table_Size);
+            --  Used to sort all the different choice values. Entry zero is
+            --  reserved for sorting purposes.
 
             Single_Choice : Boolean;
             --  Set to true every time there is a single discrete choice in a
@@ -2018,9 +2031,9 @@ package body Sem_Aggr is
                   end if;
 
                   Nb_Discrete_Choices := Nb_Discrete_Choices + 1;
-                  Table (Nb_Discrete_Choices).Choice_Lo := Low;
-                  Table (Nb_Discrete_Choices).Choice_Hi := High;
-                  Table (Nb_Discrete_Choices).Choice_Node := Choice;
+                  Table (Nb_Discrete_Choices).Lo := Low;
+                  Table (Nb_Discrete_Choices).Hi := High;
+                  Table (Nb_Discrete_Choices).Choice := Choice;
 
                   Next (Choice);
 
@@ -2142,6 +2155,10 @@ package body Sem_Aggr is
                   --  High end of one range and Low end of the next. Should be
                   --  contiguous if there is no hole in the list of values.
 
+                  Lo_Dup : Uint;
+                  Hi_Dup : Uint;
+                  --  End points of duplicated range
+
                   Missing_Or_Duplicates : Boolean := False;
                   --  Set True if missing or duplicate choices found
 
@@ -2189,62 +2206,129 @@ package body Sem_Aggr is
                begin
                   Sort_Case_Table (Table);
 
-                  --  Loop through entries in table to find duplicate indexes
+                  --  First we do a quick linear loop to find out if we have
+                  --  any duplicates or missing entries (usually we have a
+                  --  legal aggregate, so this will get us out quickly).
 
                   for J in 1 .. Nb_Discrete_Choices - 1 loop
-                     Hi_Val := Expr_Value (Table (J).Choice_Hi);
-                     Lo_Val := Expr_Value (Table (J + 1).Choice_Lo);
-
-                     if Hi_Val >= Lo_Val then
-                        Choice := Table (J + 1).Choice_Lo;
-                        Error_Msg_Sloc := Sloc (Table (J).Choice_Hi);
-
-                        if Hi_Val = Lo_Val then
-                           Error_Msg_N
-                             ("index value in array aggregate duplicates "
-                              & "the one given#",
-                              Choice);
-                        else
-                           Error_Msg_N
-                             ("index values in array aggregate duplicate "
-                              & "those given#", Choice);
-                        end if;
+                     Hi_Val := Expr_Value (Table (J).Hi);
+                     Lo_Val := Expr_Value (Table (J + 1).Lo);
 
+                     if Lo_Val <= Hi_Val
+                       or else (Lo_Val > Hi_Val + 1
+                                 and then not Others_Present)
+                     then
                         Missing_Or_Duplicates := True;
-                        Output_Bad_Choices (Lo_Val, Hi_Val, Choice);
+                        exit;
                      end if;
                   end loop;
 
-                  --  Loop through entries in table to find missing indexes.
-                  --  Not needed if others present, since missing impossible.
+                  --  If we have missing or duplicate entries, first fill in
+                  --  the Highest entries to make life easier in the following
+                  --  loops to detect bad entries.
 
-                  if not Others_Present then
-                     for J in 1 .. Nb_Discrete_Choices - 1 loop
-                        Hi_Val := Expr_Value (Table (J).Choice_Hi);
-                        Lo_Val := Expr_Value (Table (J + 1).Choice_Lo);
+                  if Missing_Or_Duplicates then
+                     Table (1).Highest := Expr_Value (Table (1).Hi);
 
-                        if Hi_Val < Lo_Val - 1 then
-                           Choice := Table (J + 1).Choice_Lo;
+                     for J in 2 .. Nb_Discrete_Choices loop
+                        Table (J).Highest :=
+                          UI_Max
+                            (Table (J - 1).Highest, Expr_Value (Table (J).Hi));
+                     end loop;
 
-                           if Hi_Val + 1 = Lo_Val - 1 then
-                              Error_Msg_N
-                                ("missing index value in array aggregate!",
-                                 Choice);
-                           else
-                              Error_Msg_N
-                                ("missing index values in array aggregate!",
-                                 Choice);
-                           end if;
+                     --  Loop through table entries to find duplicate indexes
+
+                     for J in 2 .. Nb_Discrete_Choices loop
+                        Lo_Val := Expr_Value (Table (J).Lo);
+                        Hi_Val := Expr_Value (Table (J).Hi);
+
+                        --  Case where we have duplicates (the lower bound of
+                        --  this choice is less than or equal to the highest
+                        --  high bound found so far).
+
+                        if Lo_Val <= Table (J - 1).Highest then
+
+                           --  We move backwards looking for duplicates. We can
+                           --  abandon this loop as soon as we reach a choice
+                           --  highest value that is less than Lo_Val.
+
+                           for K in reverse 1 .. J - 1 loop
+                              exit when Table (K).Highest < Lo_Val;
+
+                              --  Here we may have duplicates between entries
+                              --  for K and J. Get range of duplicates.
+
+                              Lo_Dup :=
+                                UI_Max (Lo_Val, Expr_Value (Table (K).Lo));
+                              Hi_Dup :=
+                                UI_Min (Hi_Val, Expr_Value (Table (K).Hi));
+
+                              --  Nothing to do if duplicate range is null
 
-                           Missing_Or_Duplicates := True;
-                           Output_Bad_Choices (Hi_Val + 1, Lo_Val - 1, Choice);
+                              if Lo_Dup > Hi_Dup then
+                                 null;
+
+                              --  Otherwise place proper message
+
+                              else
+                                 --  We place message on later choice, with a
+                                 --  line reference to the earlier choice.
+
+                                 if Sloc (Table (J).Choice) <
+                                   Sloc (Table (K).Choice)
+                                 then
+                                    Choice := Table (K).Choice;
+                                    Error_Msg_Sloc := Sloc (Table (J).Choice);
+                                 else
+                                    Choice := Table (J).Choice;
+                                    Error_Msg_Sloc := Sloc (Table (K).Choice);
+                                 end if;
+
+                                 if Lo_Dup = Hi_Dup then
+                                    Error_Msg_N
+                                      ("index value in array aggregate "
+                                       & "duplicates the one given#!", Choice);
+                                 else
+                                    Error_Msg_N
+                                      ("index values in array aggregate "
+                                       & "duplicate those given#!", Choice);
+                                 end if;
+
+                                 Output_Bad_Choices (Lo_Dup, Hi_Dup, Choice);
+                              end if;
+                           end loop;
                         end if;
                      end loop;
-                  end if;
 
-                  --  If either missing or duplicate values, return failure
+                     --  Loop through entries in table to find missing indexes.
+                     --  Not needed if others, since missing impossible.
+
+                     if not Others_Present then
+                        for J in 2 .. Nb_Discrete_Choices loop
+                           Lo_Val := Expr_Value (Table (J).Lo);
+                           Hi_Val := Table (J - 1).Highest;
+
+                           if Lo_Val > Hi_Val + 1 then
+                              Choice := Table (J).Lo;
+
+                              if Hi_Val + 1 = Lo_Val - 1 then
+                                 Error_Msg_N
+                                   ("missing index value in array aggregate!",
+                                    Choice);
+                              else
+                                 Error_Msg_N
+                                   ("missing index values in array aggregate!",
+                                    Choice);
+                              end if;
+
+                              Output_Bad_Choices
+                                (Hi_Val + 1, Lo_Val - 1, Choice);
+                           end if;
+                        end loop;
+                     end if;
+
+                     --  If either missing or duplicate values, return failure
 
-                  if Missing_Or_Duplicates then
                      Set_Etype (N, Any_Composite);
                      return Failure;
                   end if;
@@ -2254,8 +2338,8 @@ package body Sem_Aggr is
             --  STEP 2 (B): Compute aggregate bounds and min/max choices values
 
             if Nb_Discrete_Choices > 0 then
-               Choices_Low  := Table (1).Choice_Lo;
-               Choices_High := Table (Nb_Discrete_Choices).Choice_Hi;
+               Choices_Low  := Table (1).Lo;
+               Choices_High := Table (Nb_Discrete_Choices).Hi;
             end if;
 
             --  If Others is present, then bounds of aggregate come from the
@@ -2566,8 +2650,9 @@ package body Sem_Aggr is
       Check_Unset_Reference (Aggregate_Bounds (N));
 
       if not Others_Present and then Nb_Discrete_Choices = 0 then
-         Set_High_Bound (Aggregate_Bounds (N),
-             Duplicate_Subexpr (High_Bound (Aggregate_Bounds (N))));
+         Set_High_Bound
+           (Aggregate_Bounds (N),
+            Duplicate_Subexpr (High_Bound (Aggregate_Bounds (N))));
       end if;
 
       --  Check the dimensions of each component in the array aggregate
@@ -4636,21 +4721,19 @@ package body Sem_Aggr is
    ---------------------
 
    procedure Sort_Case_Table (Case_Table : in out Case_Table_Type) is
-      L : constant Int := Case_Table'First;
       U : constant Int := Case_Table'Last;
       K : Int;
       J : Int;
       T : Case_Bounds;
 
    begin
-      K := L;
-      while K /= U loop
+      K := 1;
+      while K < U loop
          T := Case_Table (K + 1);
 
          J := K + 1;
-         while J /= L
-           and then Expr_Value (Case_Table (J - 1).Choice_Lo) >
-                    Expr_Value (T.Choice_Lo)
+         while J > 1
+           and then Expr_Value (Case_Table (J - 1).Lo) > Expr_Value (T.Lo)
          loop
             Case_Table (J) := Case_Table (J - 1);
             J := J - 1;
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index dec94a3967b..44692e03823 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -455,6 +455,7 @@ package body Sem_Attr is
                             Reason => PE_Address_Of_Intrinsic));
 
                      else
+                        Error_Msg_Name_1 := Aname;
                         Error_Msg_N
                          ("cannot take % of intrinsic subprogram", N);
                      end if;
diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb
index 9e282fdafa8..e7f464ee171 100644
--- a/gcc/ada/sem_ch5.adb
+++ b/gcc/ada/sem_ch5.adb
@@ -1577,6 +1577,37 @@ package body Sem_Ch5 is
             Remove_Warning_Messages (Then_Statements (N));
          end if;
       end if;
+
+      --  Warn on redundant if statement that has no effect
+
+      if Warn_On_Redundant_Constructs
+
+        --  Condition must not have obvious side effect
+
+        and then Has_No_Obvious_Side_Effects (Condition (N))
+
+        --  No elsif parts of else part
+
+        and then No (Elsif_Parts (N))
+        and then No (Else_Statements (N))
+
+        --  Then must be a single null statement
+
+        and then List_Length (Then_Statements (N)) = 1
+      then
+         --  Go to original node, since we may have rewritten something as
+         --  a null statement (e.g. a case we could figure the outcome of).
+
+         declare
+            T : constant Node_Id := First (Then_Statements (N));
+            S : constant Node_Id := Original_Node (T);
+
+         begin
+            if Comes_From_Source (S) and then Nkind (S) = N_Null_Statement then
+               Error_Msg_N ("if statement has no effect?r?", N);
+            end if;
+         end;
+      end if;
    end Analyze_If_Statement;
 
    ----------------------------------------
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 6913c260884..935b7272e53 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -6456,6 +6456,45 @@ package body Sem_Util is
       return False;
    end Has_Interfaces;
 
+   ---------------------------------
+   -- Has_No_Obvious_Side_Effects --
+   ---------------------------------
+
+   function Has_No_Obvious_Side_Effects (N : Node_Id) return Boolean is
+   begin
+      --  For now, just handle literals, constants, and non-volatile
+      --  variables and expressions combining these with operators or
+      --  short circuit forms.
+
+      if Nkind (N) in N_Numeric_Or_String_Literal then
+         return True;
+
+      elsif Nkind (N) = N_Character_Literal then
+         return True;
+
+      elsif Nkind (N) in N_Unary_Op then
+         return Has_No_Obvious_Side_Effects (Right_Opnd (N));
+
+      elsif Nkind (N) in N_Binary_Op or else Nkind (N) in N_Short_Circuit then
+         return Has_No_Obvious_Side_Effects (Left_Opnd (N))
+                   and then
+                Has_No_Obvious_Side_Effects (Right_Opnd (N));
+
+      elsif Nkind (N) in N_Has_Entity then
+         return Present (Entity (N))
+           and then Ekind_In (Entity (N), E_Variable,
+                                          E_Constant,
+                                          E_Enumeration_Literal,
+                                          E_In_Parameter,
+                                          E_Out_Parameter,
+                                          E_In_Out_Parameter)
+           and then not Is_Volatile (Entity (N));
+
+      else
+         return False;
+      end if;
+   end Has_No_Obvious_Side_Effects;
+
    ------------------------
    -- Has_Null_Exclusion --
    ------------------------
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index 3053bee8dcd..d8d7db13451 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -742,6 +742,17 @@ package Sem_Util is
    --  Use_Full_View controls if the check is done using its full view (if
    --  available).
 
+   function Has_No_Obvious_Side_Effects (N : Node_Id) return Boolean;
+   --  This is a simple minded function for determining whether an expression
+   --  has no obvious side effects. It is used only for determining whether
+   --  warnings are needed in certain situations, and is not guaranteed to
+   --  be accurate in either direction. Exceptions may mean an expression
+   --  does in fact have side effects, but this may be ignored and True is
+   --  returned, or a complex expression may in fact be side effect free
+   --  but we don't recognize it here and return False. The Side_Effect_Free
+   --  routine in Remove_Side_Effects is much more extensive and perhaps could
+   --  be shared, so that this routine would be more accurate.
+
    function Has_Null_Exclusion (N : Node_Id) return Boolean;
    --  Determine whether node N has a null exclusion