[multiple changes]

2016-10-12  Bob Duff  <duff@adacore.com>

	* xref_lib.adb: Use renamings-of-slices to ensure
	that all references to Tables are properly bounds checked (when
	checks are turned on).
	* g-dyntab.ads, g-dyntab.adb: Default-initialize the array
	components, so we don't get uninitialized pointers in case
	of Tables containing access types.  Misc cleanup of the code
	and comments.

2016-10-12  Ed Schonberg  <schonberg@adacore.com>

	* sem_attr.adb (Analyze_Attribute, case 'Type_Key): Implement
	functionality of attribute, to provide a reasonably unique key
	for a given type and detect any changes in the semantics of the
	type or any of its subcomponents from version to version.

2016-10-12  Bob Duff  <duff@adacore.com>

	* sem_case.adb (Check_Choice_Set): Separate
	checking for duplicates out into a separate pass from checking
	full coverage, because the check for duplicates does not depend
	on predicates. Therefore, we shouldn't do it separately for the
	predicate vs. no-predicate case; we should share code. The code
	for the predicate case was wrong.

From-SVN: r241039

gcc/ada/ChangeLog

+2016-10-12  Bob Duff  <duff@adacore.com>
+
+	* xref_lib.adb: Use renamings-of-slices to ensure
+	that all references to Tables are properly bounds checked (when
+	checks are turned on).
+	* g-dyntab.ads, g-dyntab.adb: Default-initialize the array
+	components, so we don't get uninitialized pointers in case
+	of Tables containing access types.  Misc cleanup of the code
+	and comments.
+
+2016-10-12  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_attr.adb (Analyze_Attribute, case 'Type_Key): Implement
+	functionality of attribute, to provide a reasonably unique key
+	for a given type and detect any changes in the semantics of the
+	type or any of its subcomponents from version to version.
+
+2016-10-12  Bob Duff  <duff@adacore.com>
+
+	* sem_case.adb (Check_Choice_Set): Separate
+	checking for duplicates out into a separate pass from checking
+	full coverage, because the check for duplicates does not depend
+	on predicates. Therefore, we shouldn't do it separately for the
+	predicate vs. no-predicate case; we should share code. The code
+	for the predicate case was wrong.
+
 2016-10-12  Jerome Lambourg  <lambourg@adacore.com>
 
 	* init.c: Make sure to call finit on x86_64-vx7 to reinitialize

gcc/ada/sem_attr.adb

@@ -68,6 +68,7 @@ with Stand;    use Stand;
 with Sinfo;    use Sinfo;
 with Sinput;   use Sinput;
 with System;
+with System.CRC32; use System.CRC32;
 with Stringt;  use Stringt;
 with Style;
 with Stylesw;  use Stylesw;
@@ -6139,37 +6140,142 @@ package body Sem_Attr is
          Check_E0;
          Check_Type;
 
-         --  This processing belongs in Eval_Attribute ???
-
          declare
-            function Type_Key return String_Id;
-            --  A very preliminary implementation. For now, a signature
-            --  consists of only the type name. This is clearly incomplete
-            --  (e.g., adding a new field to a record type should change the
-            --  type's Type_Key attribute).
+            Full_Name  : constant String_Id :=
+              Fully_Qualified_Name_String (Entity (P));
+
+            Deref      : Boolean;
+            --  To simplify the handling of mutually recursive types, follow
+            --  a single dereference link in a composite type.
+
+            CRC        : CRC32;
+            --  The computed signature for the type.
+
+            procedure Compute_Type_Key (T : Entity_Id);
+            --  Create a CRC integer from the declaration of the type, For
+            --  a composite type, fold in the representation of its components
+            --  in recursive fashion. We use directly the source representation
+            --  of the types involved.
 
             --------------
             -- Type_Key --
             --------------
 
-            function Type_Key return String_Id is
-               Full_Name : constant String_Id :=
-                             Fully_Qualified_Name_String (Entity (P));
+            procedure Compute_Type_Key (T : Entity_Id)  is
+               SFI          : Source_File_Index;
+               Buffer       : Source_Buffer_Ptr;
+               P_Min, P_Max : Source_Ptr;
+               Rep          : Node_Id;
+
+               procedure Process_One_Declaration;
+               --  Update CRC with the characters of one type declaration,
+               --  or a representation pragma that applies to the type.
+
+               -----------------------------
+               -- Process_One_Declaration --
+               -----------------------------
+
+               procedure Process_One_Declaration is
+                  Ptr : Source_Ptr;
 
                begin
-               --  Copy all characters in Full_Name but the trailing NUL
+                  Ptr := P_Min;
 
+                  --  Scan type declaration, skipping blanks,
+
+                  while Ptr <= P_Max loop
+                     if Buffer (Ptr) /= ' ' then
+                        System.CRC32.Update (CRC, Buffer (Ptr));
+                     end if;
+
+                     Ptr := Ptr + 1;
+                  end loop;
+               end Process_One_Declaration;
+
+            begin  --  Start of processing for Compute_Type_Key
+
+               if Is_Itype (T) then
+                  return;
+               end if;
+
+               Sloc_Range (Enclosing_Declaration (T), P_Min, P_Max);
+               SFI        := Get_Source_File_Index (P_Min);
+               Buffer     := Source_Text (SFI);
+
+               Process_One_Declaration;
+
+               --  Recurse on relevant component types.
+
+               if Is_Array_Type (T) then
+                  Compute_Type_Key (Component_Type (T));
+
+               elsif Is_Access_Type (T) then
+                  if not Deref then
+                     Deref := True;
+                     Compute_Type_Key (Designated_Type (T));
+                  end if;
+
+               elsif Is_Derived_Type (T) then
+                  Compute_Type_Key (Etype  (T));
+
+               elsif Is_Record_Type (T) then
+                  declare
+                     Comp : Entity_Id;
+                  begin
+                     Comp := First_Component (T);
+                     while Present (Comp) loop
+                        Compute_Type_Key (Etype (Comp));
+
+                        Next_Component (Comp);
+                     end loop;
+                  end;
+               end if;
+
+               --  Fold in representation aspects for the type, which
+               --  appear in the same source buffer.
+
+               Rep := First_Rep_Item (T);
+
+               while Present (Rep) loop
+                  if Comes_From_Source (Rep) then
+                     Sloc_Range (Rep, P_Min, P_Max);
+                     Process_One_Declaration;
+                  end if;
+
+                  Rep := Next_Rep_Item (Rep);
+               end loop;
+            end Compute_Type_Key;
+
+         begin
             Start_String;
+            Deref := False;
+
+            --  Copy all characters in Full_Name but the trailing NUL
+
             for J in 1 .. String_Length (Full_Name) - 1 loop
                Store_String_Char (Get_String_Char (Full_Name, Pos (J)));
             end loop;
 
-               Store_String_Chars ("'Type_Key");
-               return End_String;
-            end Type_Key;
+            --  For standard type return the name of the type. as there is
+            --  no explicit source declaration to use. Otherwise compute
+            --  CRC and convert it to string one character at a time. so as
+            --  not to use Image within the compiler.
 
-         begin
-            Rewrite (N, Make_String_Literal (Loc, Type_Key));
+            if Scope (Entity (P)) /= Standard_Standard then
+               Initialize (CRC);
+               Compute_Type_Key (Entity (P));
+
+               if not Is_Frozen (Entity (P)) then
+                  Error_Msg_N ("premature usage of Type_Key?", N);
+               end if;
+
+               while CRC > 0 loop
+                  Store_String_Char (Character'Val (48 + (CRC rem 10)));
+                  CRC := CRC / 10;
+               end loop;
+            end if;
+
+            Rewrite (N, Make_String_Literal (Loc, End_String));
          end;
 
          Analyze_And_Resolve (N, Standard_String);

gcc/ada/sem_case.adb

@@ -114,10 +114,12 @@ package body Sem_Case is
       Others_Present : Boolean;
       Case_Node      : Node_Id)
    is
-      Predicate_Error : Boolean;
+      Predicate_Error : Boolean := False;
       --  Flag to prevent cascaded errors when a static predicate is known to
       --  be violated by one choice.
 
+      Num_Choices : constant Nat := Choice_Table'Last;
+
       procedure Check_Against_Predicate
         (Pred    : in out Node_Id;
          Choice  : Choice_Bounds;
@@ -130,6 +132,10 @@ package body Sem_Case is
       --  choice that covered a predicate set. Error denotes whether the check
       --  found an illegal intersection.
 
+      procedure Check_Duplicates;
+      --  Check for duplicate choices, and call Dup_Choice is there are any
+      --  such errors. Note that predicates are irrelevant here.
+
       procedure Dup_Choice (Lo, Hi : Uint; C : Node_Id);
       --  Post message "duplication of choice value(s) bla bla at xx". Message
       --  is posted at location C. Caller sets Error_Msg_Sloc for xx.
@@ -236,8 +242,7 @@ package body Sem_Case is
             Val : Uint) return Boolean
          is
          begin
-            return
-              Val = Lo or else Val = Hi or else (Lo < Val and then Val < Hi);
+            return Lo <= Val and then Val <= Hi;
          end Inside_Range;
 
          --  Local variables
@@ -276,14 +281,12 @@ package body Sem_Case is
             return;
          end if;
 
-         --  Step 1: Detect duplicate choices
-
-         if Inside_Range (Choice_Lo, Choice_Hi, Prev_Lo) then
-            Dup_Choice (Prev_Lo, UI_Min (Prev_Hi, Choice_Hi), LocN);
-            Error := True;
+         --  Step 1: Ignore duplicate choices, other than to set the flag,
+         --  because these were already detected by Check_Duplicates.
 
-         elsif Inside_Range (Choice_Lo, Choice_Hi, Prev_Hi) then
-            Dup_Choice (UI_Max (Choice_Lo, Prev_Lo), Prev_Hi, LocN);
+         if Inside_Range (Choice_Lo, Choice_Hi, Prev_Lo)
+           or else  Inside_Range (Choice_Lo, Choice_Hi, Prev_Hi)
+         then
             Error := True;
 
          --  Step 2: Detect full coverage
@@ -447,6 +450,59 @@ package body Sem_Case is
          end if;
       end Check_Against_Predicate;
 
+      ----------------------
+      -- Check_Duplicates --
+      ----------------------
+
+      procedure Check_Duplicates is
+         Prev_Hi : Uint := Expr_Value (Choice_Table (1).Hi);
+      begin
+         for Outer_Index in 2 .. Num_Choices loop
+            declare
+               Choice_Lo : constant Uint :=
+                 Expr_Value (Choice_Table (Outer_Index).Lo);
+               Choice_Hi : constant Uint :=
+                 Expr_Value (Choice_Table (Outer_Index).Hi);
+            begin
+               if Choice_Lo <= Prev_Hi then
+                  --  Choices overlap; this is an error
+
+                  declare
+                     Choice : constant Node_Id :=
+                       Choice_Table (Outer_Index).Node;
+                     Prev_Choice : Node_Id;
+                  begin
+                     --  Find first previous choice that overlaps
+
+                     for Inner_Index in 1 .. Outer_Index - 1 loop
+                        if Choice_Lo <=
+                             Expr_Value (Choice_Table (Inner_Index).Hi)
+                        then
+                           Prev_Choice := Choice_Table (Inner_Index).Node;
+                           exit;
+                        end if;
+                     end loop;
+
+                     if Sloc (Prev_Choice) <= Sloc (Choice) then
+                        Error_Msg_Sloc := Sloc (Prev_Choice);
+                        Dup_Choice
+                          (Choice_Lo, UI_Min (Choice_Hi, Prev_Hi), Choice);
+                     else
+                        Error_Msg_Sloc := Sloc (Choice);
+                        Dup_Choice
+                          (Choice_Lo, UI_Min (Choice_Hi, Prev_Hi),
+                           Prev_Choice);
+                     end if;
+                  end;
+               end if;
+
+               if Choice_Hi > Prev_Hi then
+                  Prev_Hi := Choice_Hi;
+               end if;
+            end;
+         end loop;
+      end Check_Duplicates;
+
       ----------------
       -- Dup_Choice --
       ----------------
@@ -709,17 +765,13 @@ package body Sem_Case is
 
       Bounds_Hi     : constant Node_Id := Type_High_Bound (Bounds_Type);
       Bounds_Lo     : constant Node_Id := Type_Low_Bound  (Bounds_Type);
-      Num_Choices   : constant Nat     := Choice_Table'Last;
       Has_Predicate : constant Boolean :=
                         Is_OK_Static_Subtype (Bounds_Type)
                           and then Has_Static_Predicate (Bounds_Type);
 
-      Choice      : Node_Id;
       Choice_Hi   : Uint;
       Choice_Lo   : Uint;
-      Error       : Boolean;
       Pred        : Node_Id;
-      Prev_Choice : Node_Id;
       Prev_Lo     : Uint;
       Prev_Hi     : Uint;
 
@@ -735,8 +787,6 @@ package body Sem_Case is
          return;
       end if;
 
-      Predicate_Error := False;
-
       --  Choice_Table must start at 0 which is an unused location used by the
       --  sorting algorithm. However the first valid position for a discrete
       --  choice is 1.
@@ -756,9 +806,15 @@ package body Sem_Case is
 
       Sorting.Sort (Positive (Choice_Table'Last));
 
-      --  The type covered by the list of choices is actually a static subtype
-      --  subject to a static predicate. The predicate defines subsets of legal
-      --  values and requires finer grained analysis.
+      --  First check for duplicates. This involved the choices; predicates, if
+      --  any, are irrelevant.
+
+      Check_Duplicates;
+
+      --  Then check for overlaps
+
+      --  If the subtype has a static predicate, the predicate defines subsets
+      --  of legal values and requires finer grained analysis.
 
       --  Note that in GNAT the predicate is considered static if the predicate
       --  expression is static, independently of whether the aspect mentions
@@ -774,8 +830,9 @@ package body Sem_Case is
          Prev_Lo := Expr_Value (Type_Low_Bound (Bounds_Type)) - 1;
          Prev_Hi := Prev_Lo;
 
-         Error   := False;
-
+         declare
+            Error : Boolean := False;
+         begin
             for Index in 1 .. Num_Choices loop
                Check_Against_Predicate
                  (Pred    => Pred,
@@ -784,9 +841,9 @@ package body Sem_Case is
                   Prev_Hi => Prev_Hi,
                   Error   => Error);
 
-            --  The analysis detected an illegal intersection between a choice
-            --  and a static predicate set. Do not examine other choices unless
-            --  all errors are requested.
+               --  The analysis detected an illegal intersection between a
+               --  choice and a static predicate set. Do not examine other
+               --  choices unless all errors are requested.
 
                if Error then
                   Predicate_Error := True;
@@ -796,6 +853,7 @@ package body Sem_Case is
                   end if;
                end if;
             end loop;
+         end;
 
          if Predicate_Error then
             return;
@@ -826,35 +884,11 @@ package body Sem_Case is
             end if;
          end if;
 
-         for Outer_Index in 2 .. Num_Choices loop
-            Choice_Lo := Expr_Value (Choice_Table (Outer_Index).Lo);
-            Choice_Hi := Expr_Value (Choice_Table (Outer_Index).Hi);
-
-            if Choice_Lo <= Prev_Hi then
-               Choice := Choice_Table (Outer_Index).Node;
-
-               --  Find first previous choice that overlaps
-
-               for Inner_Index in 1 .. Outer_Index - 1 loop
-                  if Choice_Lo <=
-                       Expr_Value (Choice_Table (Inner_Index).Hi)
-                  then
-                     Prev_Choice := Choice_Table (Inner_Index).Node;
-                     exit;
-                  end if;
-               end loop;
-
-               if Sloc (Prev_Choice) <= Sloc (Choice) then
-                  Error_Msg_Sloc := Sloc (Prev_Choice);
-                  Dup_Choice
-                    (Choice_Lo, UI_Min (Choice_Hi, Prev_Hi), Choice);
-               else
-                  Error_Msg_Sloc := Sloc (Choice);
-                  Dup_Choice
-                    (Choice_Lo, UI_Min (Choice_Hi, Prev_Hi), Prev_Choice);
-               end if;
+         for Index in 2 .. Num_Choices loop
+            Choice_Lo := Expr_Value (Choice_Table (Index).Lo);
+            Choice_Hi := Expr_Value (Choice_Table (Index).Hi);
 
-            elsif not Others_Present and then Choice_Lo /= Prev_Hi + 1 then
+            if Choice_Lo > Prev_Hi + 1 and then not Others_Present then
                Missing_Choice (Prev_Hi + 1, Choice_Lo - 1);
             end if;
 

gcc/ada/xref_lib.adb

@@ -401,8 +401,9 @@ package body Xref_Lib is
      (File : ALI_File;
       Num  : Positive) return File_Reference
    is
+      Table : Table_Type renames File.Dep.Table (1 .. Last (File.Dep));
    begin
-      return File.Dep.Table (Num);
+      return Table (Num);
    end File_Name;
 
    --------------------
@@ -642,10 +643,15 @@ package body Xref_Lib is
                Token := Gnatchop_Name + 1;
             end if;
 
-            File.Dep.Table (Num_Dependencies) := Add_To_Xref_File
+            declare
+               Table : Table_Type renames
+                 File.Dep.Table (1 .. Last (File.Dep));
+            begin
+               Table (Num_Dependencies) := Add_To_Xref_File
                  (Ali (File_Start .. File_End),
                   Gnatchop_File => Ali (Token .. Ptr - 1),
                   Gnatchop_Offset => Gnatchop_Offset);
+            end;
 
          elsif W_Lines and then Ali (Ptr) = 'W' then
 
@@ -854,6 +860,8 @@ package body Xref_Lib is
          Ptr := Ptr + 1;
       end Skip_To_Matching_Closing_Bracket;
 
+      Table : Table_Type renames File.Dep.Table (1 .. Last (File.Dep));
+
    --  Start of processing for Parse_Identifier_Info
 
    begin
@@ -976,9 +984,9 @@ package body Xref_Lib is
                   --  We don't have a unit number specified, so we set P_Eun to
                   --  the current unit.
 
-                  for K in Dependencies_Tables.First .. Last (File.Dep) loop
+                  for K in Table'Range loop
                      P_Eun := K;
-                     exit when File.Dep.Table (K) = File_Ref;
+                     exit when Table (K) = File_Ref;
                   end loop;
                end if;
 
@@ -1011,7 +1019,7 @@ package body Xref_Lib is
                            Symbol,
                            P_Line,
                            P_Column,
-                           File.Dep.Table (P_Eun));
+                           Table (P_Eun));
                      end if;
                   end;
                end if;
@@ -1029,7 +1037,7 @@ package body Xref_Lib is
                      Add_Entity
                        (Pattern,
                         Get_Symbol_Name (P_Eun, P_Line, P_Column)
-                        & ':' & Get_Gnatchop_File (File.Dep.Table (P_Eun))
+                        & ':' & Get_Gnatchop_File (Table (P_Eun))
                         & ':' & Get_Line (Get_Parent (Decl_Ref))
                         & ':' & Get_Column (Get_Parent (Decl_Ref)),
                         False);
@@ -1080,11 +1088,10 @@ package body Xref_Lib is
 
       if Wide_Search then
          declare
-            File_Ref : File_Reference;
-            pragma Unreferenced (File_Ref);
             File_Name : constant String := Get_Gnatchop_File (File.X_File);
+            Ignored : File_Reference;
          begin
-            File_Ref := Add_To_Xref_File (ALI_File_Name (File_Name), False);
+            Ignored := Add_To_Xref_File (ALI_File_Name (File_Name), False);
          end;
       end if;
 
@@ -1252,6 +1259,8 @@ package body Xref_Lib is
       Ptr     : Positive renames File.Current_Line;
       File_Nr : Natural;
 
+      Table : Table_Type renames File.Dep.Table (1 .. Last (File.Dep));
+
    begin
       while Ali (Ptr) = 'X' loop
 
@@ -1267,8 +1276,8 @@ package body Xref_Lib is
 
          --  If the referenced file is unknown, we simply ignore it
 
-         if File_Nr in Dependencies_Tables.First .. Last (File.Dep) then
-            File.X_File := File.Dep.Table (File_Nr);
+         if File_Nr in Table'Range then
+            File.X_File := Table (File_Nr);
          else
             File.X_File := Empty_File;
          end if;