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

1 files changed, 147 insertions, 64 deletions

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;