[multiple changes]

2017-04-27  Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_elab.adb Add new type Visited_Element
	and update the contents of table Elab_Visited.	Various code clean up.
	(Check_Elab_Call): Determine whether a prior call to
	the same subprogram was already examined within the same context.
	(Check_Internal_Call_Continue): Register the subprogram being
	called as examined within a particular context. Do not suppress
	elaboration warnings.

2017-04-27  Gary Dismukes  <dismukes@adacore.com>

	* xoscons.adb, osint.ads: Minor reformatting.

2017-04-27  Bob Duff  <duff@adacore.com>

	* g-dyntab.ads, g-dyntab.adb: Misc cleanup. Rename
	Table_Count_Type --> Table_Last_Type, because the name
	was confusing (a "count" usually starts at zero).  Add
	functionality supported or needed by other tables packages
	(Move, Release_Threshold).
	* g-table.ads, g-table.adb: This is now just a thin wrapper
	around g-dyntab.ads/g-dyntab.adb.  Add functionality supported
	or needed by other tables packages (Save, Restore).
	* table.ads, table.adb: This is now just a thin wrapper around
	* g-table.ads/g-table.adb.
	* namet.h, scos.h, uintp.h: These files are reaching into the
	private data of some instances of g-table, whose names changed,
	so the above change requires some adjustment here. It now uses
	public interfaces.

2017-04-27  Bob Duff  <duff@adacore.com>

	* namet.adb, namet.ads: Minor: remove unused procedures.

2017-04-27  Eric Botcazou  <ebotcazou@adacore.com>

	* checks.adb (Apply_Scalar_Range_Check): Initialize Ok variable too.
	(Minimize_Eliminate_Overflows): Initialize Llo and Lhi.
	Add pragma Warnings on Rtype variable in nested block.	*
	* exp_ch3.adb (Build_Init_Statements): Initialize VAR_LOC.
	* exp_ch4.adb (Expand_Concatenate): Initialize 3 variables.
	(Size_In_Storage_Elements): Add pragma Warnings on Res variable.
	* exp_ch7.adb (Build_Adjust_Statements): Initialize Bod_Stmts.
	(Process_Component_List_For_Finalize): Initialize Counter_Id.
	(Build_Finalize_Statements): Initialize Bod_Stmts.
	* exp_disp.adb (Expand_Dispatching_Call): Initialize SCIL_Node.

2017-04-27  Claire Dross  <dross@adacore.com>

	* a-cfhama.adb, a-cfhamai.ads (=): Generic parameter removed to
	allow the use of regular equality over elements in contracts.
	(Formal_Model): Ghost package containing model functions that are
	used in subprogram contracts.
	(Current_To_Last): Removed, model
	functions should be used instead.
	(First_To_Previous): Removed, model functions should be used instead.
	(Strict_Equal): Removed, model functions should be used instead.
	(No_Overlap): Removed, model functions should be used instead.
	(Equivalent_Keys): Functions over cursors are removed. They were
	awkward with explicit container parameters.
	* a-cofuma.adb, a-cofuma.ads (Lift_Equivalent_Keys): New lemma
	(proof only) procedure to help GNATprove when equivalence over
	keys is not equality.

From-SVN: r247320

1 files changed, 57 insertions, 275 deletions

diff --git a/gcc/ada/g-table.adb b/gcc/ada/g-table.adb
index c5c5891..1c122d7 100644
--- a/gcc/ada/g-table.adb
+++ b/gcc/ada/g-table.adb
@@ -29,8 +29,6 @@
 --                                                                          --
 ------------------------------------------------------------------------------
 
-with GNAT.Heap_Sort_G;
-
 with System;        use System;
 with System.Memory; use System.Memory;
 
@@ -38,53 +36,20 @@ with Ada.Unchecked_Conversion;
 
 package body GNAT.Table is
 
-   Min : constant Integer := Integer (Table_Low_Bound);
-   --  Subscript of the minimum entry in the currently allocated table
-
-   Max : Integer;
-   --  Subscript of the maximum entry in the currently allocated table
-
-   Length : Integer := 0;
-   --  Number of entries in currently allocated table. The value of zero
-   --  ensures that we initially allocate the table.
-
-   Last_Val : Integer;
-   --  Current value of Last
-
-   -----------------------
-   -- Local Subprograms --
-   -----------------------
-
-   procedure Reallocate;
-   --  Reallocate the existing table according to the current value stored
-   --  in Max. Works correctly to do an initial allocation if the table
-   --  is currently null.
-
-   pragma Warnings (Off);
-   --  Turn off warnings. The following unchecked conversions are only used
-   --  internally in this package, and cannot never result in any instances
-   --  of improperly aliased pointers for the client of the package.
-
-   function To_Address is new Ada.Unchecked_Conversion (Table_Ptr, Address);
-   function To_Pointer is new Ada.Unchecked_Conversion (Address, Table_Ptr);
-
-   pragma Warnings (On);
-
    --------------
    -- Allocate --
    --------------
 
-   function Allocate (Num : Integer := 1) return Table_Index_Type is
-      Old_Last : constant Integer := Last_Val;
-
+   procedure Allocate (Num : Integer := 1) is
    begin
-      Last_Val := Last_Val + Num;
-
-      if Last_Val > Max then
-         Reallocate;
-      end if;
+      Tab.Allocate (The_Instance, Num);
+   end Allocate;
 
-      return Table_Index_Type (Old_Last + 1);
+   function Allocate (Num : Integer := 1) return Valid_Table_Index_Type is
+      Result : constant Valid_Table_Index_Type := Last + 1;
+   begin
+      Allocate (Num);
+      return Result;
    end Allocate;
 
    ------------
@@ -93,7 +58,7 @@ package body GNAT.Table is
 
    procedure Append (New_Val : Table_Component_Type) is
    begin
-      Set_Item (Table_Index_Type (Last_Val + 1), New_Val);
+      Tab.Append (The_Instance, New_Val);
    end Append;
 
    ----------------
@@ -102,9 +67,7 @@ package body GNAT.Table is
 
    procedure Append_All (New_Vals : Table_Type) is
    begin
-      for J in New_Vals'Range loop
-         Append (New_Vals (J));
-      end loop;
+      Tab.Append_All (The_Instance, New_Vals);
    end Append_All;
 
    --------------------
@@ -113,7 +76,7 @@ package body GNAT.Table is
 
    procedure Decrement_Last is
    begin
-      Last_Val := Last_Val - 1;
+      Tab.Decrement_Last (The_Instance);
    end Decrement_Last;
 
    -----------
@@ -122,7 +85,7 @@ package body GNAT.Table is
 
    function First return Table_Index_Type is
    begin
-      return Table_Low_Bound;
+      return Tab.First;
    end First;
 
    --------------
@@ -130,12 +93,9 @@ package body GNAT.Table is
    --------------
 
    procedure For_Each is
-      Quit : Boolean := False;
+      procedure For_Each is new Tab.For_Each (Action);
    begin
-      for Index in Table_Low_Bound .. Table_Index_Type (Last_Val) loop
-         Action (Index, Table (Index), Quit);
-         exit when Quit;
-      end loop;
+      For_Each (The_Instance);
    end For_Each;
 
    ----------
@@ -144,9 +104,7 @@ package body GNAT.Table is
 
    procedure Free is
    begin
-      Free (To_Address (Table));
-      Table := null;
-      Length := 0;
+      Tab.Free (The_Instance);
    end Free;
 
    --------------------
@@ -155,201 +113,85 @@ package body GNAT.Table is
 
    procedure Increment_Last is
    begin
-      Last_Val := Last_Val + 1;
-
-      if Last_Val > Max then
-         Reallocate;
-      end if;
+      Tab.Increment_Last (The_Instance);
    end Increment_Last;
 
+   --------------
+   -- Is_Empty --
+   --------------
+
+   function Is_Empty return Boolean is
+   begin
+      return Tab.Is_Empty (The_Instance);
+   end Is_Empty;
+
    ----------
    -- Init --
    ----------
 
    procedure Init is
-      Old_Length : constant Integer := Length;
-
    begin
-      Last_Val := Min - 1;
-      Max      := Min + Table_Initial - 1;
-      Length   := Max - Min + 1;
-
-      --  If table is same size as before (happens when table is never
-      --  expanded which is a common case), then simply reuse it. Note
-      --  that this also means that an explicit Init call right after
-      --  the implicit one in the package body is harmless.
-
-      if Old_Length = Length then
-         return;
-
-      --  Otherwise we can use Reallocate to get a table of the right size.
-      --  Note that Reallocate works fine to allocate a table of the right
-      --  initial size when it is first allocated.
-
-      else
-         Reallocate;
-      end if;
+      Tab.Init (The_Instance);
    end Init;
 
    ----------
    -- Last --
    ----------
 
-   function Last return Table_Index_Type is
+   function Last return Table_Last_Type is
    begin
-      return Table_Index_Type (Last_Val);
+      return Tab.Last (The_Instance);
    end Last;
 
-   ----------------
-   -- Reallocate --
-   ----------------
-
-   procedure Reallocate is
-      New_Size   : size_t;
-      New_Length : Long_Long_Integer;
-
-   begin
-      if Max < Last_Val then
-         pragma Assert (not Locked);
-
-         --  Now increment table length until it is sufficiently large. Use
-         --  the increment value or 10, which ever is larger (the reason
-         --  for the use of 10 here is to ensure that the table does really
-         --  increase in size (which would not be the case for a table of
-         --  length 10 increased by 3% for instance). Do the intermediate
-         --  calculation in Long_Long_Integer to avoid overflow.
-
-         while Max < Last_Val loop
-            New_Length :=
-              Long_Long_Integer (Length) *
-                (100 + Long_Long_Integer (Table_Increment)) / 100;
-            Length := Integer'Max (Integer (New_Length), Length + 10);
-            Max := Min + Length - 1;
-         end loop;
-      end if;
-
-      New_Size :=
-        size_t ((Max - Min + 1) *
-                (Table_Type'Component_Size / Storage_Unit));
-
-      if Table = null then
-         Table := To_Pointer (Alloc (New_Size));
-
-      elsif New_Size > 0 then
-         Table :=
-           To_Pointer (Realloc (Ptr  => To_Address (Table),
-                                Size => New_Size));
-      end if;
-
-      if Length /= 0 and then Table = null then
-         raise Storage_Error;
-      end if;
-
-   end Reallocate;
-
    -------------
    -- Release --
    -------------
 
    procedure Release is
    begin
-      Length := Last_Val - Integer (Table_Low_Bound) + 1;
-      Max    := Last_Val;
-      Reallocate;
+      Tab.Release (The_Instance);
    end Release;
 
+   -------------
+   -- Restore --
+   -------------
+
+   procedure Restore (T : in out Saved_Table) is
+   begin
+      Init;
+      Tab.Move (From => T, To => The_Instance);
+   end Restore;
+
+   ----------
+   -- Save --
+   ----------
+
+   function Save return Saved_Table is
+      Result : Saved_Table;
+   begin
+      Tab.Move (From => The_Instance, To => Result);
+      return Result;
+   end Save;
+
    --------------
    -- Set_Item --
    --------------
 
    procedure Set_Item
-      (Index : Table_Index_Type;
-       Item  : Table_Component_Type)
+     (Index : Valid_Table_Index_Type;
+      Item  : Table_Component_Type)
    is
-      --  If Item is a value within the current allocation, and we are going to
-      --  reallocate, then we must preserve an intermediate copy here before
-      --  calling Increment_Last. Otherwise, if Table_Component_Type is passed
-      --  by reference, we are going to end up copying from storage that might
-      --  have been deallocated from Increment_Last calling Reallocate.
-
-      subtype Allocated_Table_T is
-        Table_Type (Table'First .. Table_Index_Type (Max + 1));
-      --  A constrained table subtype one element larger than the currently
-      --  allocated table.
-
-      Allocated_Table_Address : constant System.Address :=
-                                  Table.all'Address;
-      --  Used for address clause below (we can't use non-static expression
-      --  Table.all'Address directly in the clause because some older versions
-      --  of the compiler do not allow it).
-
-      Allocated_Table : Allocated_Table_T;
-      pragma Import (Ada, Allocated_Table);
-      pragma Suppress (Range_Check, On => Allocated_Table);
-      for Allocated_Table'Address use Allocated_Table_Address;
-      --  Allocated_Table represents the currently allocated array, plus one
-      --  element (the supplementary element is used to have a convenient
-      --  way of computing the address just past the end of the current
-      --  allocation). Range checks are suppressed because this unit uses
-      --  direct calls to System.Memory for allocation, and this can yield
-      --  misaligned storage (and we cannot rely on the bootstrap compiler
-      --  supporting specifically disabling alignment checks, so we need to
-      --  suppress all range checks). It is safe to suppress this check here
-      --  because we know that a (possibly misaligned) object of that type
-      --  does actually exist at that address. ??? We should really improve
-      --  the allocation circuitry here to
-      --  guarantee proper alignment.
-
-      Need_Realloc : constant Boolean := Integer (Index) > Max;
-      --  True if this operation requires storage reallocation (which may
-      --  involve moving table contents around).
-
    begin
-      --  If we're going to reallocate, check whether Item references an
-      --  element of the currently allocated table.
-
-      if Need_Realloc
-        and then Allocated_Table'Address <= Item'Address
-        and then Item'Address <
-                   Allocated_Table (Table_Index_Type (Max + 1))'Address
-      then
-         --  If so, save a copy on the stack because Increment_Last will
-         --  reallocate storage and might deallocate the current table.
-
-         declare
-            Item_Copy : constant Table_Component_Type := Item;
-         begin
-            Set_Last (Index);
-            Table (Index) := Item_Copy;
-         end;
-
-      else
-         --  Here we know that either we won't reallocate (case of Index < Max)
-         --  or that Item is not in the currently allocated table.
-
-         if Integer (Index) > Last_Val then
-            Set_Last (Index);
-         end if;
-
-         Table (Index) := Item;
-      end if;
+      Tab.Set_Item (The_Instance, Index, Item);
    end Set_Item;
 
    --------------
    -- Set_Last --
    --------------
 
-   procedure Set_Last (New_Val : Table_Index_Type) is
+   procedure Set_Last (New_Val : Table_Last_Type) is
    begin
-      if Integer (New_Val) < Last_Val then
-         Last_Val := Integer (New_Val);
-      else
-         Last_Val := Integer (New_Val);
-
-         if Last_Val > Max then
-            Reallocate;
-         end if;
-      end if;
+      Tab.Set_Last (The_Instance, New_Val);
    end Set_Last;
 
    ----------------
@@ -357,69 +199,9 @@ package body GNAT.Table is
    ----------------
 
    procedure Sort_Table is
-
-      Temp : Table_Component_Type;
-      --  A temporary position to simulate index 0
-
-      --  Local subprograms
-
-      function Index_Of (Idx : Natural) return Table_Index_Type;
-      --  Return index of Idx'th element of table
-
-      function Lower_Than (Op1, Op2 : Natural) return Boolean;
-      --  Compare two components
-
-      procedure Move (From : Natural; To : Natural);
-      --  Move one component
-
-      package Heap_Sort is new GNAT.Heap_Sort_G (Move, Lower_Than);
-
-      --------------
-      -- Index_Of --
-      --------------
-
-      function Index_Of (Idx : Natural) return Table_Index_Type is
-         J : constant Integer'Base := Table_Index_Type'Pos (First) + Idx - 1;
-      begin
-         return Table_Index_Type'Val (J);
-      end Index_Of;
-
-      ----------
-      -- Move --
-      ----------
-
-      procedure Move (From : Natural; To : Natural) is
-      begin
-         if From = 0 then
-            Table (Index_Of (To)) := Temp;
-         elsif To = 0 then
-            Temp := Table (Index_Of (From));
-         else
-            Table (Index_Of (To)) := Table (Index_Of (From));
-         end if;
-      end Move;
-
-      ----------------
-      -- Lower_Than --
-      ----------------
-
-      function Lower_Than (Op1, Op2 : Natural) return Boolean is
-      begin
-         if Op1 = 0 then
-            return Lt (Temp, Table (Index_Of (Op2)));
-         elsif Op2 = 0 then
-            return Lt (Table (Index_Of (Op1)), Temp);
-         else
-            return Lt (Table (Index_Of (Op1)), Table (Index_Of (Op2)));
-         end if;
-      end Lower_Than;
-
-   --  Start of processing for Sort_Table
-
+      procedure Sort_Table is new Tab.Sort_Table (Lt);
    begin
-      Heap_Sort.Sort (Natural (Last - First) + 1);
+      Sort_Table (The_Instance);
    end Sort_Table;
 
-begin
-   Init;
 end GNAT.Table;