Commit 7f070fc4 by Hristian Kirtchev Committed by Pierre-Marie de Rodat

[Ada] Clean up of GNAT.Dynamic_HTables

------------
-- Source --
------------

--  operations.adb

with Ada.Text_IO;          use Ada.Text_IO;
with GNAT;                 use GNAT;
with GNAT.Dynamic_HTables; use GNAT.Dynamic_HTables;

procedure Operations is
   procedure Destroy (Val : in out Integer) is null;
   function Hash (Key : Integer) return Bucket_Range_Type;

   package DHT is new Dynamic_Hash_Tables
     (Key_Type              => Integer,
      Value_Type            => Integer,
      No_Value              => 0,
      Expansion_Threshold   => 1.3,
      Expansion_Factor      => 2,
      Compression_Threshold => 0.3,
      Compression_Factor    => 2,
      "="                   => "=",
      Destroy_Value         => Destroy,
      Hash                  => Hash);
   use DHT;

   function Create_And_Populate
     (Low_Key   : Integer;
      High_Key  : Integer;
      Init_Size : Positive) return Dynamic_Hash_Table;
   --  Create a hash table with initial size Init_Size and populate it with
   --  key-value pairs where both keys and values are in the range Low_Key
   --  .. High_Key.

   procedure Check_Empty
     (Caller    : String;
      T         : Dynamic_Hash_Table;
      Low_Key   : Integer;
      High_Key  : Integer);
   --  Ensure that
   --
   --    * The key-value pairs count of hash table T is 0.
   --    * All values for the keys in range Low_Key .. High_Key are 0.

   procedure Check_Keys
     (Caller   : String;
      Iter     : in out Iterator;
      Low_Key  : Integer;
      High_Key : Integer);
   --  Ensure that iterator Iter visits every key in the range Low_Key ..
   --  High_Key exactly once.

   procedure Check_Locked_Mutations
     (Caller : String;
      T      : in out Dynamic_Hash_Table);
   --  Ensure that all mutation operations of hash table T are locked

   procedure Check_Size
     (Caller    : String;
      T         : Dynamic_Hash_Table;
      Exp_Count : Natural);
   --  Ensure that the count of key-value pairs of hash table T matches
   --  expected count Exp_Count. Emit an error if this is not the case.

   procedure Test_Create (Init_Size : Positive);
   --  Verify that all dynamic hash table operations fail on a non-created
   --  table of size Init_Size.

   procedure Test_Delete_Get_Put_Size
     (Low_Key   : Integer;
      High_Key  : Integer;
      Exp_Count : Natural;
      Init_Size : Positive);
   --  Verify that
   --
   --    * Put properly inserts values in the hash table.
   --    * Get properly retrieves all values inserted in the table.
   --    * Delete properly deletes values.
   --    * The size of the hash table properly reflects the number of key-value
   --      pairs.
   --
   --  Low_Key and High_Key denote the range of keys to be inserted, retrieved,
   --  and deleted. Exp_Count is the expected count of key-value pairs n the
   --  hash table. Init_Size denotes the initial size of the table.

   procedure Test_Iterate
     (Low_Key   : Integer;
      High_Key  : Integer;
      Init_Size : Positive);
   --  Verify that iterators
   --
   --    * Properly visit each key exactly once.
   --    * Mutation operations are properly locked and unlocked during
   --      iteration.
   --
   --  Low_Key and High_Key denote the range of keys to be inserted, retrieved,
   --  and deleted. Init_Size denotes the initial size of the table.

   procedure Test_Iterate_Empty (Init_Size : Positive);
   --  Verify that an iterator over an empty hash table
   --
   --    * Does not visit any key
   --    * Mutation operations are properly locked and unlocked during
   --      iteration.
   --
   --  Init_Size denotes the initial size of the table.

   procedure Test_Iterate_Forced
     (Low_Key   : Integer;
      High_Key  : Integer;
      Init_Size : Positive);
   --  Verify that an iterator that is forcefully advanced by just Next
   --
   --    * Properly visit each key exactly once.
   --    * Mutation operations are properly locked and unlocked during
   --      iteration.
   --
   --  Low_Key and High_Key denote the range of keys to be inserted, retrieved,
   --  and deleted. Init_Size denotes the initial size of the table.

   procedure Test_Replace
     (Low_Val   : Integer;
      High_Val  : Integer;
      Init_Size : Positive);
   --  Verify that Put properly updates the value of a particular key. Low_Val
   --  and High_Val denote the range of values to be updated. Init_Size denotes
   --  the initial size of the table.

   procedure Test_Reset
     (Low_Key   : Integer;
      High_Key  : Integer;
      Init_Size : Positive);
   --  Verify that Reset properly destroy and recreats a hash table. Low_Key
   --  and High_Key denote the range of keys to be inserted in the hash table.
   --  Init_Size denotes the initial size of the table.

   -------------------------
   -- Create_And_Populate --
   -------------------------

   function Create_And_Populate
     (Low_Key   : Integer;
      High_Key  : Integer;
      Init_Size : Positive) return Dynamic_Hash_Table
   is
      T : Dynamic_Hash_Table;

   begin
      T := Create (Init_Size);

      for Key in Low_Key .. High_Key loop
         Put (T, Key, Key);
      end loop;

      return T;
   end Create_And_Populate;

   -----------------
   -- Check_Empty --
   -----------------

   procedure Check_Empty
     (Caller    : String;
      T         : Dynamic_Hash_Table;
      Low_Key   : Integer;
      High_Key  : Integer)
   is
      Val : Integer;

   begin
      Check_Size
        (Caller    => Caller,
         T         => T,
         Exp_Count => 0);

      for Key in Low_Key .. High_Key loop
         Val := Get (T, Key);

         if Val /= 0 then
            Put_Line ("ERROR: " & Caller & ": wrong value");
            Put_Line ("expected: 0");
            Put_Line ("got     :" & Val'Img);
         end if;
      end loop;
   end Check_Empty;

   ----------------
   -- Check_Keys --
   ----------------

   procedure Check_Keys
     (Caller   : String;
      Iter     : in out Iterator;
      Low_Key  : Integer;
      High_Key : Integer)
   is
      type Bit_Vector is array (Low_Key .. High_Key) of Boolean;
      pragma Pack (Bit_Vector);

      Count : Natural;
      Key   : Integer;
      Seen  : Bit_Vector := (others => False);

   begin
      --  Compute the number of outstanding keys that have to be iterated on

      Count := High_Key - Low_Key + 1;

      while Has_Next (Iter) loop
         Next (Iter, Key);

         if Seen (Key) then
            Put_Line
              ("ERROR: " & Caller & ": Check_Keys: duplicate key" & Key'Img);
         else
            Seen (Key) := True;
            Count := Count - 1;
         end if;
      end loop;

      --  In the end, all keys must have been iterated on

      if Count /= 0 then
         for Key in Seen'Range loop
            if not Seen (Key) then
               Put_Line
                 ("ERROR: " & Caller & ": Check_Keys: missing key" & Key'Img);
            end if;
         end loop;
      end if;
   end Check_Keys;

   ----------------------------
   -- Check_Locked_Mutations --
   ----------------------------

   procedure Check_Locked_Mutations
     (Caller : String;
      T      : in out Dynamic_Hash_Table)
   is
   begin
      begin
         Delete (T, 1);
         Put_Line ("ERROR: " & Caller & ": Delete: no exception raised");
      exception
         when Iterated =>
            null;
         when others =>
           Put_Line ("ERROR: " & Caller & ": Delete: unexpected exception");
      end;

      begin
         Destroy (T);
         Put_Line ("ERROR: " & Caller & ": Destroy: no exception raised");
      exception
         when Iterated =>
            null;
         when others =>
           Put_Line ("ERROR: " & Caller & ": Destroy: unexpected exception");
      end;

      begin
         Put (T, 1, 1);
         Put_Line ("ERROR: " & Caller & ": Put: no exception raised");
      exception
         when Iterated =>
            null;
         when others =>
           Put_Line ("ERROR: " & Caller & ": Put: unexpected exception");
      end;

      begin
         Reset (T);
         Put_Line ("ERROR: " & Caller & ": Reset: no exception raised");
      exception
         when Iterated =>
            null;
         when others =>
           Put_Line ("ERROR: " & Caller & ": Reset: unexpected exception");
      end;
   end Check_Locked_Mutations;

   ----------------
   -- Check_Size --
   ----------------

   procedure Check_Size
     (Caller    : String;
      T         : Dynamic_Hash_Table;
      Exp_Count : Natural)
   is
      Count : constant Natural := Size (T);

   begin
      if Count /= Exp_Count then
         Put_Line ("ERROR: " & Caller & ": Size: wrong value");
         Put_Line ("expected:" & Exp_Count'Img);
         Put_Line ("got     :" & Count'Img);
      end if;
   end Check_Size;

   ----------
   -- Hash --
   ----------

   function Hash (Key : Integer) return Bucket_Range_Type is
   begin
      return Bucket_Range_Type (Key);
   end Hash;

   -----------------
   -- Test_Create --
   -----------------

   procedure Test_Create (Init_Size : Positive) is
      Count : Natural;
      Iter  : Iterator;
      T     : Dynamic_Hash_Table;
      Val   : Integer;

   begin
      --  Ensure that every routine defined in the API fails on a hash table
      --  which has not been created yet.

      begin
         Delete (T, 1);
         Put_Line ("ERROR: Test_Create: Delete: no exception raised");
      exception
         when Not_Created =>
            null;
         when others =>
           Put_Line ("ERROR: Test_Create: Delete: unexpected exception");
      end;

      begin
         Destroy (T);
         Put_Line ("ERROR: Test_Create: Destroy: no exception raised");
      exception
         when Not_Created =>
            null;
         when others =>
           Put_Line ("ERROR: Test_Create: Destroy: unexpected exception");
      end;

      begin
         Val := Get (T, 1);
         Put_Line ("ERROR: Test_Create: Get: no exception raised");
      exception
         when Not_Created =>
            null;
         when others =>
           Put_Line ("ERROR: Test_Create: Get: unexpected exception");
      end;

      begin
         Iter := Iterate (T);
         Put_Line ("ERROR: Test_Create: Iterate: no exception raised");
      exception
         when Not_Created =>
            null;
         when others =>
           Put_Line ("ERROR: Test_Create: Iterate: unexpected exception");
      end;

      begin
         Put (T, 1, 1);
         Put_Line ("ERROR: Test_Create: Put: no exception raised");
      exception
         when Not_Created =>
            null;
         when others =>
           Put_Line ("ERROR: Test_Create: Put: unexpected exception");
      end;

      begin
         Reset (T);
         Put_Line ("ERROR: Test_Create: Reset: no exception raised");
      exception
         when Not_Created =>
            null;
         when others =>
           Put_Line ("ERROR: Test_Create: Reset: unexpected exception");
      end;

      begin
         Count := Size (T);
         Put_Line ("ERROR: Test_Create: Size: no exception raised");
      exception
         when Not_Created =>
            null;
         when others =>
           Put_Line ("ERROR: Test_Create: Size: unexpected exception");
      end;

      --  Test create

      T := Create (Init_Size);

      --  Clean up the hash table to prevent memory leaks

      Destroy (T);
   end Test_Create;

   ------------------------------
   -- Test_Delete_Get_Put_Size --
   ------------------------------

   procedure Test_Delete_Get_Put_Size
     (Low_Key   : Integer;
      High_Key  : Integer;
      Exp_Count : Natural;
      Init_Size : Positive)
   is
      Exp_Val : Integer;
      T       : Dynamic_Hash_Table;
      Val     : Integer;

   begin
      T := Create_And_Populate (Low_Key, High_Key, Init_Size);

      --  Ensure that its size matches an expected value

      Check_Size
        (Caller    => "Test_Delete_Get_Put_Size",
         T         => T,
         Exp_Count => Exp_Count);

      --  Ensure that every value for the range of keys exists

      for Key in Low_Key .. High_Key loop
         Val := Get (T, Key);

         if Val /= Key then
            Put_Line ("ERROR: Test_Delete_Get_Put_Size: Get: wrong value");
            Put_Line ("expected:" & Key'Img);
            Put_Line ("got     :" & Val'Img);
         end if;
      end loop;

      --  Delete values whose keys are divisible by 10

      for Key in Low_Key .. High_Key loop
         if Key mod 10 = 0 then
            Delete (T, Key);
         end if;
      end loop;

      --  Ensure that all values whose keys were not deleted still exist

      for Key in Low_Key .. High_Key loop
         if Key mod 10 = 0 then
            Exp_Val := 0;
         else
            Exp_Val := Key;
         end if;

         Val := Get (T, Key);

         if Val /= Exp_Val then
            Put_Line ("ERROR: Test_Delete_Get_Put_Size: Get: wrong value");
            Put_Line ("expected:" & Exp_Val'Img);
            Put_Line ("got     :" & Val'Img);
         end if;
      end loop;

      --  Delete all values

      for Key in Low_Key .. High_Key loop
         Delete (T, Key);
      end loop;

      --  Ensure that the hash table is empty

      Check_Empty
        (Caller   => "Test_Delete_Get_Put_Size",
         T        => T,
         Low_Key  => Low_Key,
         High_Key => High_Key);

      --  Clean up the hash table to prevent memory leaks

      Destroy (T);
   end Test_Delete_Get_Put_Size;

   ------------------
   -- Test_Iterate --
   ------------------

   procedure Test_Iterate
     (Low_Key   : Integer;
      High_Key  : Integer;
      Init_Size : Positive)
   is
      Iter_1 : Iterator;
      Iter_2 : Iterator;
      T      : Dynamic_Hash_Table;

   begin
      T := Create_And_Populate (Low_Key, High_Key, Init_Size);

      --  Obtain an iterator. This action must lock all mutation operations of
      --  the hash table.

      Iter_1 := Iterate (T);

      --  Ensure that every mutation routine defined in the API fails on a hash
      --  table with at least one outstanding iterator.

      Check_Locked_Mutations
        (Caller => "Test_Iterate",
         T      => T);

      --  Obtain another iterator

      Iter_2 := Iterate (T);

      --  Ensure that every mutation is still locked

      Check_Locked_Mutations
        (Caller => "Test_Iterate",
         T      => T);

      --  Ensure that all keys are iterable. Note that this does not unlock the
      --  mutation operations of the hash table because Iter_2 is not exhausted
      --  yet.

      Check_Keys
        (Caller   => "Test_Iterate",
         Iter     => Iter_1,
         Low_Key  => Low_Key,
         High_Key => High_Key);

      Check_Locked_Mutations
        (Caller => "Test_Iterate",
         T      => T);

      --  Ensure that all keys are iterable. This action unlocks all mutation
      --  operations of the hash table because all outstanding iterators have
      --  been exhausted.

      Check_Keys
        (Caller   => "Test_Iterate",
         Iter     => Iter_2,
         Low_Key  => Low_Key,
         High_Key => High_Key);

      --  Ensure that all mutation operations are once again callable

      Delete (T, Low_Key);
      Put (T, Low_Key, Low_Key);
      Reset (T);

      --  Clean up the hash table to prevent memory leaks

      Destroy (T);
   end Test_Iterate;

   ------------------------
   -- Test_Iterate_Empty --
   ------------------------

   procedure Test_Iterate_Empty (Init_Size : Positive) is
      Iter : Iterator;
      Key  : Integer;
      T    : Dynamic_Hash_Table;

   begin
      T := Create_And_Populate (0, -1, Init_Size);

      --  Obtain an iterator. This action must lock all mutation operations of
      --  the hash table.

      Iter := Iterate (T);

      --  Ensure that every mutation routine defined in the API fails on a hash
      --  table with at least one outstanding iterator.

      Check_Locked_Mutations
        (Caller => "Test_Iterate_Empty",
         T      => T);

      --  Attempt to iterate over the keys

      while Has_Next (Iter) loop
         Next (Iter, Key);

         Put_Line ("ERROR: Test_Iterate_Empty: key" & Key'Img & " exists");
      end loop;

      --  Ensure that all mutation operations are once again callable

      Delete (T, 1);
      Put (T, 1, 1);
      Reset (T);

      --  Clean up the hash table to prevent memory leaks

      Destroy (T);
   end Test_Iterate_Empty;

   -------------------------
   -- Test_Iterate_Forced --
   -------------------------

   procedure Test_Iterate_Forced
     (Low_Key   : Integer;
      High_Key  : Integer;
      Init_Size : Positive)
   is
      Iter : Iterator;
      Key  : Integer;
      T    : Dynamic_Hash_Table;

   begin
      T := Create_And_Populate (Low_Key, High_Key, Init_Size);

      --  Obtain an iterator. This action must lock all mutation operations of
      --  the hash table.

      Iter := Iterate (T);

      --  Ensure that every mutation routine defined in the API fails on a hash
      --  table with at least one outstanding iterator.

      Check_Locked_Mutations
        (Caller => "Test_Iterate_Forced",
         T      => T);

      --  Forcibly advance the iterator until it raises an exception

      begin
         for Guard in Low_Key .. High_Key + 1 loop
            Next (Iter, Key);
         end loop;

         Put_Line
           ("ERROR: Test_Iterate_Forced: Iterator_Exhausted not raised");
      exception
         when Iterator_Exhausted =>
            null;
         when others =>
            Put_Line ("ERROR: Test_Iterate_Forced: unexpected exception");
      end;

      --  Ensure that all mutation operations are once again callable

      Delete (T, Low_Key);
      Put (T, Low_Key, Low_Key);
      Reset (T);

      --  Clean up the hash table to prevent memory leaks

      Destroy (T);
   end Test_Iterate_Forced;

   ------------------
   -- Test_Replace --
   ------------------

   procedure Test_Replace
     (Low_Val   : Integer;
      High_Val  : Integer;
      Init_Size : Positive)
   is
      Key : constant Integer := 1;
      T   : Dynamic_Hash_Table;
      Val : Integer;

   begin
      T := Create (Init_Size);

      --  Ensure the Put properly updates values with the same key

      for Exp_Val in Low_Val .. High_Val loop
         Put (T, Key, Exp_Val);

         Val := Get (T, Key);

         if Val /= Exp_Val then
            Put_Line ("ERROR: Test_Replace: Get: wrong value");
            Put_Line ("expected:" & Exp_Val'Img);
            Put_Line ("got     :" & Val'Img);
         end if;
      end loop;

      --  Clean up the hash table to prevent memory leaks

      Destroy (T);
   end Test_Replace;

   ----------------
   -- Test_Reset --
   ----------------

   procedure Test_Reset
     (Low_Key   : Integer;
      High_Key  : Integer;
      Init_Size : Positive)
   is
      T : Dynamic_Hash_Table;

   begin
      T := Create_And_Populate (Low_Key, High_Key, Init_Size);

      --  Reset the contents of the hash table

      Reset (T);

      --  Ensure that the hash table is empty

      Check_Empty
        (Caller   => "Test_Reset",
         T        => T,
         Low_Key  => Low_Key,
         High_Key => High_Key);

      --  Clean up the hash table to prevent memory leaks

      Destroy (T);
   end Test_Reset;

--  Start of processing for Operations

begin
   Test_Create (Init_Size => 1);
   Test_Create (Init_Size => 100);

   Test_Delete_Get_Put_Size
     (Low_Key   => 1,
      High_Key  => 1,
      Exp_Count => 1,
      Init_Size => 1);

   Test_Delete_Get_Put_Size
     (Low_Key   => 1,
      High_Key  => 1000,
      Exp_Count => 1000,
      Init_Size => 32);

   Test_Iterate
     (Low_Key   => 1,
      High_Key  => 32,
      Init_Size => 32);

   Test_Iterate_Empty (Init_Size => 32);

   Test_Iterate_Forced
     (Low_Key   => 1,
      High_Key  => 32,
      Init_Size => 32);

   Test_Replace
     (Low_Val   => 1,
      High_Val  => 10,
      Init_Size => 32);

   Test_Reset
     (Low_Key   => 1,
      High_Key  => 1000,
      Init_Size => 100);
end Operations;

----------------------------
-- Compilation and output --
----------------------------

$ gnatmake -q operations.adb -largs -lgmem
$ ./operations
$ gnatmem operations > leaks.txt
$ grep -c "non freed allocations" leaks.txt
0

2019-07-01  Hristian Kirtchev  <kirtchev@adacore.com>

gcc/ada/

	* libgnat/g-dynhta.adb: Use type Dynamic_Hash_Table rather than
	Instance in various routines.
	* libgnat/g-dynhta.ads: Change type Instance to
	Dynamic_Hash_Table. Update various routines that mention the
	type.

gcc/testsuite/

	* gnat.dg/dynhash.adb, gnat.dg/dynhash1.adb: Update.

From-SVN: r272860
parent 68f27c97
2019-07-01 Hristian Kirtchev <kirtchev@adacore.com> 2019-07-01 Hristian Kirtchev <kirtchev@adacore.com>
* libgnat/g-dynhta.adb: Use type Dynamic_Hash_Table rather than
Instance in various routines.
* libgnat/g-dynhta.ads: Change type Instance to
Dynamic_Hash_Table. Update various routines that mention the
type.
2019-07-01 Hristian Kirtchev <kirtchev@adacore.com>
* exp_attr.adb, exp_ch7.adb, exp_unst.adb, sem_ch3.adb, * exp_attr.adb, exp_ch7.adb, exp_unst.adb, sem_ch3.adb,
sem_util.adb, uintp.adb, uintp.ads: Minor reformatting. sem_util.adb, uintp.adb, uintp.ads: Minor reformatting.
......
...@@ -364,11 +364,11 @@ package body GNAT.Dynamic_HTables is ...@@ -364,11 +364,11 @@ package body GNAT.Dynamic_HTables is
end Set_Next; end Set_Next;
end Simple_HTable; end Simple_HTable;
-------------------- -------------------------
-- Dynamic_HTable -- -- Dynamic_Hash_Tables --
-------------------- -------------------------
package body Dynamic_HTable is package body Dynamic_Hash_Tables is
Minimum_Size : constant Bucket_Range_Type := 8; Minimum_Size : constant Bucket_Range_Type := 8;
-- Minimum size of the buckets -- Minimum size of the buckets
...@@ -382,7 +382,9 @@ package body GNAT.Dynamic_HTables is ...@@ -382,7 +382,9 @@ package body GNAT.Dynamic_HTables is
-- Maximum safe size for hash table expansion. Beyond this size, an -- Maximum safe size for hash table expansion. Beyond this size, an
-- expansion will overflow the buckets. -- expansion will overflow the buckets.
procedure Delete_Node (T : Instance; Nod : Node_Ptr); procedure Delete_Node
(T : Dynamic_Hash_Table;
Nod : Node_Ptr);
pragma Inline (Delete_Node); pragma Inline (Delete_Node);
-- Detach and delete node Nod from table T -- Detach and delete node Nod from table T
...@@ -398,12 +400,12 @@ package body GNAT.Dynamic_HTables is ...@@ -398,12 +400,12 @@ package body GNAT.Dynamic_HTables is
pragma Inline (Ensure_Circular); pragma Inline (Ensure_Circular);
-- Ensure that dummy head Head is circular with respect to itself -- Ensure that dummy head Head is circular with respect to itself
procedure Ensure_Created (T : Instance); procedure Ensure_Created (T : Dynamic_Hash_Table);
pragma Inline (Ensure_Created); pragma Inline (Ensure_Created);
-- Verify that hash table T is created. Raise Not_Created if this is not -- Verify that hash table T is created. Raise Not_Created if this is not
-- the case. -- the case.
procedure Ensure_Unlocked (T : Instance); procedure Ensure_Unlocked (T : Dynamic_Hash_Table);
pragma Inline (Ensure_Unlocked); pragma Inline (Ensure_Unlocked);
-- Verify that hash table T is unlocked. Raise Iterated if this is not -- Verify that hash table T is unlocked. Raise Iterated if this is not
-- the case. -- the case.
...@@ -422,7 +424,7 @@ package body GNAT.Dynamic_HTables is ...@@ -422,7 +424,7 @@ package body GNAT.Dynamic_HTables is
-- otherwise return null. -- otherwise return null.
procedure First_Valid_Node procedure First_Valid_Node
(T : Instance; (T : Dynamic_Hash_Table;
Low_Bkt : Bucket_Range_Type; Low_Bkt : Bucket_Range_Type;
High_Bkt : Bucket_Range_Type; High_Bkt : Bucket_Range_Type;
Idx : out Bucket_Range_Type; Idx : out Bucket_Range_Type;
...@@ -437,7 +439,8 @@ package body GNAT.Dynamic_HTables is ...@@ -437,7 +439,8 @@ package body GNAT.Dynamic_HTables is
new Ada.Unchecked_Deallocation (Bucket_Table, Bucket_Table_Ptr); new Ada.Unchecked_Deallocation (Bucket_Table, Bucket_Table_Ptr);
procedure Free is procedure Free is
new Ada.Unchecked_Deallocation (Hash_Table, Instance); new Ada.Unchecked_Deallocation
(Dynamic_Hash_Table_Attributes, Dynamic_Hash_Table);
procedure Free is procedure Free is
new Ada.Unchecked_Deallocation (Node, Node_Ptr); new Ada.Unchecked_Deallocation (Node, Node_Ptr);
...@@ -451,15 +454,17 @@ package body GNAT.Dynamic_HTables is ...@@ -451,15 +454,17 @@ package body GNAT.Dynamic_HTables is
-- Determine whether node Nod is non-null and does not refer to dummy -- Determine whether node Nod is non-null and does not refer to dummy
-- head Head, thus making it valid. -- head Head, thus making it valid.
function Load_Factor (T : Instance) return Threshold_Type; function Load_Factor (T : Dynamic_Hash_Table) return Threshold_Type;
pragma Inline (Load_Factor); pragma Inline (Load_Factor);
-- Calculate the load factor of hash table T -- Calculate the load factor of hash table T
procedure Lock (T : Instance); procedure Lock (T : Dynamic_Hash_Table);
pragma Inline (Lock); pragma Inline (Lock);
-- Lock all mutation functionality of hash table T -- Lock all mutation functionality of hash table T
procedure Mutate_And_Rehash (T : Instance; Size : Bucket_Range_Type); procedure Mutate_And_Rehash
(T : Dynamic_Hash_Table;
Size : Bucket_Range_Type);
pragma Inline (Mutate_And_Rehash); pragma Inline (Mutate_And_Rehash);
-- Replace the buckets of hash table T with a new set of buckets of size -- Replace the buckets of hash table T with a new set of buckets of size
-- Size. Rehash all key-value pairs from the old to the new buckets. -- Size. Rehash all key-value pairs from the old to the new buckets.
...@@ -476,7 +481,7 @@ package body GNAT.Dynamic_HTables is ...@@ -476,7 +481,7 @@ package body GNAT.Dynamic_HTables is
pragma Inline (Present); pragma Inline (Present);
-- Determine whether node Nod exists -- Determine whether node Nod exists
procedure Unlock (T : Instance); procedure Unlock (T : Dynamic_Hash_Table);
pragma Inline (Unlock); pragma Inline (Unlock);
-- Unlock all mutation functionality of hash table T -- Unlock all mutation functionality of hash table T
...@@ -484,13 +489,13 @@ package body GNAT.Dynamic_HTables is ...@@ -484,13 +489,13 @@ package body GNAT.Dynamic_HTables is
-- Create -- -- Create --
------------ ------------
function Create (Initial_Size : Positive) return Instance is function Create (Initial_Size : Positive) return Dynamic_Hash_Table is
Size : constant Bucket_Range_Type := Size : constant Bucket_Range_Type :=
Bucket_Range_Type'Max Bucket_Range_Type'Max
(Bucket_Range_Type (Initial_Size), Minimum_Size); (Bucket_Range_Type (Initial_Size), Minimum_Size);
-- Ensure that the buckets meet a minimum size -- Ensure that the buckets meet a minimum size
T : constant Instance := new Hash_Table; T : constant Dynamic_Hash_Table := new Dynamic_Hash_Table_Attributes;
begin begin
T.Buckets := new Bucket_Table (0 .. Size - 1); T.Buckets := new Bucket_Table (0 .. Size - 1);
...@@ -503,7 +508,10 @@ package body GNAT.Dynamic_HTables is ...@@ -503,7 +508,10 @@ package body GNAT.Dynamic_HTables is
-- Delete -- -- Delete --
------------ ------------
procedure Delete (T : Instance; Key : Key_Type) is procedure Delete
(T : Dynamic_Hash_Table;
Key : Key_Type)
is
Head : Node_Ptr; Head : Node_Ptr;
Nod : Node_Ptr; Nod : Node_Ptr;
...@@ -531,7 +539,10 @@ package body GNAT.Dynamic_HTables is ...@@ -531,7 +539,10 @@ package body GNAT.Dynamic_HTables is
-- Delete_Node -- -- Delete_Node --
----------------- -----------------
procedure Delete_Node (T : Instance; Nod : Node_Ptr) is procedure Delete_Node
(T : Dynamic_Hash_Table;
Nod : Node_Ptr)
is
procedure Compress; procedure Compress;
pragma Inline (Compress); pragma Inline (Compress);
-- Determine whether hash table T requires compression, and if so, -- Determine whether hash table T requires compression, and if so,
...@@ -586,7 +597,7 @@ package body GNAT.Dynamic_HTables is ...@@ -586,7 +597,7 @@ package body GNAT.Dynamic_HTables is
-- Destroy -- -- Destroy --
------------- -------------
procedure Destroy (T : in out Instance) is procedure Destroy (T : in out Dynamic_Hash_Table) is
begin begin
Ensure_Created (T); Ensure_Created (T);
Ensure_Unlocked (T); Ensure_Unlocked (T);
...@@ -678,7 +689,7 @@ package body GNAT.Dynamic_HTables is ...@@ -678,7 +689,7 @@ package body GNAT.Dynamic_HTables is
-- Ensure_Created -- -- Ensure_Created --
-------------------- --------------------
procedure Ensure_Created (T : Instance) is procedure Ensure_Created (T : Dynamic_Hash_Table) is
begin begin
if not Present (T) then if not Present (T) then
raise Not_Created; raise Not_Created;
...@@ -689,7 +700,7 @@ package body GNAT.Dynamic_HTables is ...@@ -689,7 +700,7 @@ package body GNAT.Dynamic_HTables is
-- Ensure_Unlocked -- -- Ensure_Unlocked --
--------------------- ---------------------
procedure Ensure_Unlocked (T : Instance) is procedure Ensure_Unlocked (T : Dynamic_Hash_Table) is
begin begin
pragma Assert (Present (T)); pragma Assert (Present (T));
...@@ -746,7 +757,7 @@ package body GNAT.Dynamic_HTables is ...@@ -746,7 +757,7 @@ package body GNAT.Dynamic_HTables is
---------------------- ----------------------
procedure First_Valid_Node procedure First_Valid_Node
(T : Instance; (T : Dynamic_Hash_Table;
Low_Bkt : Bucket_Range_Type; Low_Bkt : Bucket_Range_Type;
High_Bkt : Bucket_Range_Type; High_Bkt : Bucket_Range_Type;
Idx : out Bucket_Range_Type; Idx : out Bucket_Range_Type;
...@@ -784,7 +795,10 @@ package body GNAT.Dynamic_HTables is ...@@ -784,7 +795,10 @@ package body GNAT.Dynamic_HTables is
-- Get -- -- Get --
--------- ---------
function Get (T : Instance; Key : Key_Type) return Value_Type is function Get
(T : Dynamic_Hash_Table;
Key : Key_Type) return Value_Type
is
Head : Node_Ptr; Head : Node_Ptr;
Nod : Node_Ptr; Nod : Node_Ptr;
...@@ -815,7 +829,7 @@ package body GNAT.Dynamic_HTables is ...@@ -815,7 +829,7 @@ package body GNAT.Dynamic_HTables is
function Has_Next (Iter : Iterator) return Boolean is function Has_Next (Iter : Iterator) return Boolean is
Is_OK : constant Boolean := Is_Valid (Iter); Is_OK : constant Boolean := Is_Valid (Iter);
T : constant Instance := Iter.Table; T : constant Dynamic_Hash_Table := Iter.Table;
begin begin
pragma Assert (Present (T)); pragma Assert (Present (T));
...@@ -835,7 +849,7 @@ package body GNAT.Dynamic_HTables is ...@@ -835,7 +849,7 @@ package body GNAT.Dynamic_HTables is
-- Is_Empty -- -- Is_Empty --
-------------- --------------
function Is_Empty (T : Instance) return Boolean is function Is_Empty (T : Dynamic_Hash_Table) return Boolean is
begin begin
Ensure_Created (T); Ensure_Created (T);
...@@ -870,7 +884,7 @@ package body GNAT.Dynamic_HTables is ...@@ -870,7 +884,7 @@ package body GNAT.Dynamic_HTables is
-- Iterate -- -- Iterate --
------------- -------------
function Iterate (T : Instance) return Iterator is function Iterate (T : Dynamic_Hash_Table) return Iterator is
Iter : Iterator; Iter : Iterator;
begin begin
...@@ -906,7 +920,7 @@ package body GNAT.Dynamic_HTables is ...@@ -906,7 +920,7 @@ package body GNAT.Dynamic_HTables is
-- Load_Factor -- -- Load_Factor --
----------------- -----------------
function Load_Factor (T : Instance) return Threshold_Type is function Load_Factor (T : Dynamic_Hash_Table) return Threshold_Type is
pragma Assert (Present (T)); pragma Assert (Present (T));
pragma Assert (Present (T.Buckets)); pragma Assert (Present (T.Buckets));
...@@ -920,7 +934,7 @@ package body GNAT.Dynamic_HTables is ...@@ -920,7 +934,7 @@ package body GNAT.Dynamic_HTables is
-- Lock -- -- Lock --
---------- ----------
procedure Lock (T : Instance) is procedure Lock (T : Dynamic_Hash_Table) is
begin begin
-- The hash table may be locked multiple times if multiple iterators -- The hash table may be locked multiple times if multiple iterators
-- are operating over it. -- are operating over it.
...@@ -932,7 +946,10 @@ package body GNAT.Dynamic_HTables is ...@@ -932,7 +946,10 @@ package body GNAT.Dynamic_HTables is
-- Mutate_And_Rehash -- -- Mutate_And_Rehash --
----------------------- -----------------------
procedure Mutate_And_Rehash (T : Instance; Size : Bucket_Range_Type) is procedure Mutate_And_Rehash
(T : Dynamic_Hash_Table;
Size : Bucket_Range_Type)
is
procedure Rehash (From : Bucket_Table_Ptr; To : Bucket_Table_Ptr); procedure Rehash (From : Bucket_Table_Ptr; To : Bucket_Table_Ptr);
pragma Inline (Rehash); pragma Inline (Rehash);
-- Remove all nodes from buckets From and rehash them into buckets To -- Remove all nodes from buckets From and rehash them into buckets To
...@@ -1031,7 +1048,7 @@ package body GNAT.Dynamic_HTables is ...@@ -1031,7 +1048,7 @@ package body GNAT.Dynamic_HTables is
procedure Next (Iter : in out Iterator; Key : out Key_Type) is procedure Next (Iter : in out Iterator; Key : out Key_Type) is
Is_OK : constant Boolean := Is_Valid (Iter); Is_OK : constant Boolean := Is_Valid (Iter);
Saved : constant Node_Ptr := Iter.Curr_Nod; Saved : constant Node_Ptr := Iter.Curr_Nod;
T : constant Instance := Iter.Table; T : constant Dynamic_Hash_Table := Iter.Table;
Head : Node_Ptr; Head : Node_Ptr;
begin begin
...@@ -1109,7 +1126,7 @@ package body GNAT.Dynamic_HTables is ...@@ -1109,7 +1126,7 @@ package body GNAT.Dynamic_HTables is
-- Present -- -- Present --
------------- -------------
function Present (T : Instance) return Boolean is function Present (T : Dynamic_Hash_Table) return Boolean is
begin begin
return T /= Nil; return T /= Nil;
end Present; end Present;
...@@ -1118,7 +1135,11 @@ package body GNAT.Dynamic_HTables is ...@@ -1118,7 +1135,11 @@ package body GNAT.Dynamic_HTables is
-- Put -- -- Put --
--------- ---------
procedure Put (T : Instance; Key : Key_Type; Value : Value_Type) is procedure Put
(T : Dynamic_Hash_Table;
Key : Key_Type;
Value : Value_Type)
is
procedure Expand; procedure Expand;
pragma Inline (Expand); pragma Inline (Expand);
-- Determine whether hash table T requires expansion, and if so, -- Determine whether hash table T requires expansion, and if so,
...@@ -1223,7 +1244,7 @@ package body GNAT.Dynamic_HTables is ...@@ -1223,7 +1244,7 @@ package body GNAT.Dynamic_HTables is
-- Reset -- -- Reset --
----------- -----------
procedure Reset (T : Instance) is procedure Reset (T : Dynamic_Hash_Table) is
begin begin
Ensure_Created (T); Ensure_Created (T);
Ensure_Unlocked (T); Ensure_Unlocked (T);
...@@ -1243,7 +1264,7 @@ package body GNAT.Dynamic_HTables is ...@@ -1243,7 +1264,7 @@ package body GNAT.Dynamic_HTables is
-- Size -- -- Size --
---------- ----------
function Size (T : Instance) return Natural is function Size (T : Dynamic_Hash_Table) return Natural is
begin begin
Ensure_Created (T); Ensure_Created (T);
...@@ -1254,13 +1275,13 @@ package body GNAT.Dynamic_HTables is ...@@ -1254,13 +1275,13 @@ package body GNAT.Dynamic_HTables is
-- Unlock -- -- Unlock --
------------ ------------
procedure Unlock (T : Instance) is procedure Unlock (T : Dynamic_Hash_Table) is
begin begin
-- The hash table may be locked multiple times if multiple iterators -- The hash table may be locked multiple times if multiple iterators
-- are operating over it. -- are operating over it.
T.Iterators := T.Iterators - 1; T.Iterators := T.Iterators - 1;
end Unlock; end Unlock;
end Dynamic_HTable; end Dynamic_Hash_Tables;
end GNAT.Dynamic_HTables; end GNAT.Dynamic_HTables;
...@@ -258,9 +258,9 @@ package GNAT.Dynamic_HTables is ...@@ -258,9 +258,9 @@ package GNAT.Dynamic_HTables is
Nil : constant Instance := Instance (Tab.Nil); Nil : constant Instance := Instance (Tab.Nil);
end Simple_HTable; end Simple_HTable;
-------------------- -------------------------
-- Dynamic_HTable -- -- Dynamic_Hash_Tables --
-------------------- -------------------------
-- The following package offers a hash table abstraction with the following -- The following package offers a hash table abstraction with the following
-- characteristics: -- characteristics:
...@@ -275,7 +275,7 @@ package GNAT.Dynamic_HTables is ...@@ -275,7 +275,7 @@ package GNAT.Dynamic_HTables is
-- --
-- The following use pattern must be employed when operating this table: -- The following use pattern must be employed when operating this table:
-- --
-- Table : Instance := Create (<some size>); -- Table : Dynamic_Hash_Table := Create (<some size>);
-- --
-- <various operations> -- <various operations>
-- --
...@@ -333,7 +333,7 @@ package GNAT.Dynamic_HTables is ...@@ -333,7 +333,7 @@ package GNAT.Dynamic_HTables is
with function Hash (Key : Key_Type) return Bucket_Range_Type; with function Hash (Key : Key_Type) return Bucket_Range_Type;
-- Map an arbitrary key into the range of buckets -- Map an arbitrary key into the range of buckets
package Dynamic_HTable is package Dynamic_Hash_Tables is
---------------------- ----------------------
-- Table operations -- -- Table operations --
...@@ -342,37 +342,44 @@ package GNAT.Dynamic_HTables is ...@@ -342,37 +342,44 @@ package GNAT.Dynamic_HTables is
-- The following type denotes a hash table handle. Each instance must be -- The following type denotes a hash table handle. Each instance must be
-- created using routine Create. -- created using routine Create.
type Instance is private; type Dynamic_Hash_Table is private;
Nil : constant Instance; Nil : constant Dynamic_Hash_Table;
function Create (Initial_Size : Positive) return Instance; function Create (Initial_Size : Positive) return Dynamic_Hash_Table;
-- Create a new table with bucket capacity Initial_Size. This routine -- Create a new table with bucket capacity Initial_Size. This routine
-- must be called at the start of a hash table's lifetime. -- must be called at the start of a hash table's lifetime.
procedure Delete (T : Instance; Key : Key_Type); procedure Delete
(T : Dynamic_Hash_Table;
Key : Key_Type);
-- Delete the value which corresponds to key Key from hash table T. The -- Delete the value which corresponds to key Key from hash table T. The
-- routine has no effect if the value is not present in the hash table. -- routine has no effect if the value is not present in the hash table.
-- This action will raise Iterated if the hash table has outstanding -- This action will raise Iterated if the hash table has outstanding
-- iterators. If the load factor drops below Compression_Threshold, the -- iterators. If the load factor drops below Compression_Threshold, the
-- size of the buckets is decreased by Copression_Factor. -- size of the buckets is decreased by Copression_Factor.
procedure Destroy (T : in out Instance); procedure Destroy (T : in out Dynamic_Hash_Table);
-- Destroy the contents of hash table T, rendering it unusable. This -- Destroy the contents of hash table T, rendering it unusable. This
-- routine must be called at the end of a hash table's lifetime. This -- routine must be called at the end of a hash table's lifetime. This
-- action will raise Iterated if the hash table has outstanding -- action will raise Iterated if the hash table has outstanding
-- iterators. -- iterators.
function Get (T : Instance; Key : Key_Type) return Value_Type; function Get
(T : Dynamic_Hash_Table;
Key : Key_Type) return Value_Type;
-- Obtain the value which corresponds to key Key from hash table T. If -- Obtain the value which corresponds to key Key from hash table T. If
-- the value does not exist, return No_Value. -- the value does not exist, return No_Value.
function Is_Empty (T : Instance) return Boolean; function Is_Empty (T : Dynamic_Hash_Table) return Boolean;
-- Determine whether hash table T is empty -- Determine whether hash table T is empty
function Present (T : Instance) return Boolean; function Present (T : Dynamic_Hash_Table) return Boolean;
-- Determine whether hash table T exists -- Determine whether hash table T exists
procedure Put (T : Instance; Key : Key_Type; Value : Value_Type); procedure Put
(T : Dynamic_Hash_Table;
Key : Key_Type;
Value : Value_Type);
-- Associate value Value with key Key in hash table T. If the table -- Associate value Value with key Key in hash table T. If the table
-- already contains a mapping of the same key to a previous value, the -- already contains a mapping of the same key to a previous value, the
-- previous value is overwritten. This action will raise Iterated if -- previous value is overwritten. This action will raise Iterated if
...@@ -380,12 +387,12 @@ package GNAT.Dynamic_HTables is ...@@ -380,12 +387,12 @@ package GNAT.Dynamic_HTables is
-- over Expansion_Threshold, the size of the buckets is increased by -- over Expansion_Threshold, the size of the buckets is increased by
-- Expansion_Factor. -- Expansion_Factor.
procedure Reset (T : Instance); procedure Reset (T : Dynamic_Hash_Table);
-- Destroy the contents of hash table T, and reset it to its initial -- Destroy the contents of hash table T, and reset it to its initial
-- created state. This action will raise Iterated if the hash table -- created state. This action will raise Iterated if the hash table
-- has outstanding iterators. -- has outstanding iterators.
function Size (T : Instance) return Natural; function Size (T : Dynamic_Hash_Table) return Natural;
-- Obtain the number of key-value pairs in hash table T -- Obtain the number of key-value pairs in hash table T
------------------------- -------------------------
...@@ -412,7 +419,7 @@ package GNAT.Dynamic_HTables is ...@@ -412,7 +419,7 @@ package GNAT.Dynamic_HTables is
-- iterator has been exhausted, restore all mutation functionality of -- iterator has been exhausted, restore all mutation functionality of
-- the associated hash table. -- the associated hash table.
function Iterate (T : Instance) return Iterator; function Iterate (T : Dynamic_Hash_Table) return Iterator;
-- Obtain an iterator over the keys of hash table T. This action locks -- Obtain an iterator over the keys of hash table T. This action locks
-- all mutation functionality of the associated hash table. -- all mutation functionality of the associated hash table.
...@@ -461,7 +468,7 @@ package GNAT.Dynamic_HTables is ...@@ -461,7 +468,7 @@ package GNAT.Dynamic_HTables is
-- The following type represents a hash table -- The following type represents a hash table
type Hash_Table is record type Dynamic_Hash_Table_Attributes is record
Buckets : Bucket_Table_Ptr := null; Buckets : Bucket_Table_Ptr := null;
-- Reference to the compressing / expanding buckets -- Reference to the compressing / expanding buckets
...@@ -475,8 +482,8 @@ package GNAT.Dynamic_HTables is ...@@ -475,8 +482,8 @@ package GNAT.Dynamic_HTables is
-- Number of key-value pairs in the buckets -- Number of key-value pairs in the buckets
end record; end record;
type Instance is access Hash_Table; type Dynamic_Hash_Table is access Dynamic_Hash_Table_Attributes;
Nil : constant Instance := null; Nil : constant Dynamic_Hash_Table := null;
-- The following type represents a key iterator -- The following type represents a key iterator
...@@ -491,9 +498,9 @@ package GNAT.Dynamic_HTables is ...@@ -491,9 +498,9 @@ package GNAT.Dynamic_HTables is
-- always point to a valid node. A value of null indicates that the -- always point to a valid node. A value of null indicates that the
-- iterator is exhausted. -- iterator is exhausted.
Table : Instance := null; Table : Dynamic_Hash_Table := null;
-- Reference to the associated hash table -- Reference to the associated hash table
end record; end record;
end Dynamic_HTable; end Dynamic_Hash_Tables;
end GNAT.Dynamic_HTables; end GNAT.Dynamic_HTables;
2019-07-01 Hristian Kirtchev <kirtchev@adacore.com> 2019-07-01 Hristian Kirtchev <kirtchev@adacore.com>
* gnat.dg/dynhash.adb, gnat.dg/dynhash1.adb: Update.
2019-07-01 Hristian Kirtchev <kirtchev@adacore.com>
* gnat.dg/freezing1.adb, gnat.dg/freezing1.ads, * gnat.dg/freezing1.adb, gnat.dg/freezing1.ads,
gnat.dg/freezing1_pack.adb, gnat.dg/freezing1_pack.ads: New gnat.dg/freezing1_pack.adb, gnat.dg/freezing1_pack.ads: New
testcase. testcase.
......
...@@ -5,9 +5,10 @@ with GNAT; use GNAT; ...@@ -5,9 +5,10 @@ with GNAT; use GNAT;
with GNAT.Dynamic_HTables; use GNAT.Dynamic_HTables; with GNAT.Dynamic_HTables; use GNAT.Dynamic_HTables;
procedure Dynhash is procedure Dynhash is
procedure Destroy (Val : in out Integer) is null;
function Hash (Key : Integer) return Bucket_Range_Type; function Hash (Key : Integer) return Bucket_Range_Type;
package DHT is new Dynamic_HTable package DHT is new Dynamic_Hash_Tables
(Key_Type => Integer, (Key_Type => Integer,
Value_Type => Integer, Value_Type => Integer,
No_Value => 0, No_Value => 0,
...@@ -16,20 +17,21 @@ procedure Dynhash is ...@@ -16,20 +17,21 @@ procedure Dynhash is
Compression_Threshold => 0.3, Compression_Threshold => 0.3,
Compression_Factor => 2, Compression_Factor => 2,
"=" => "=", "=" => "=",
Destroy_Value => Destroy,
Hash => Hash); Hash => Hash);
use DHT; use DHT;
function Create_And_Populate function Create_And_Populate
(Low_Key : Integer; (Low_Key : Integer;
High_Key : Integer; High_Key : Integer;
Init_Size : Positive) return Instance; Init_Size : Positive) return Dynamic_Hash_Table;
-- Create a hash table with initial size Init_Size and populate it with -- Create a hash table with initial size Init_Size and populate it with
-- key-value pairs where both keys and values are in the range Low_Key -- key-value pairs where both keys and values are in the range Low_Key
-- .. High_Key. -- .. High_Key.
procedure Check_Empty procedure Check_Empty
(Caller : String; (Caller : String;
T : Instance; T : Dynamic_Hash_Table;
Low_Key : Integer; Low_Key : Integer;
High_Key : Integer); High_Key : Integer);
-- Ensure that -- Ensure that
...@@ -45,12 +47,14 @@ procedure Dynhash is ...@@ -45,12 +47,14 @@ procedure Dynhash is
-- Ensure that iterator Iter visits every key in the range Low_Key .. -- Ensure that iterator Iter visits every key in the range Low_Key ..
-- High_Key exactly once. -- High_Key exactly once.
procedure Check_Locked_Mutations (Caller : String; T : in out Instance); procedure Check_Locked_Mutations
(Caller : String;
T : in out Dynamic_Hash_Table);
-- Ensure that all mutation operations of hash table T are locked -- Ensure that all mutation operations of hash table T are locked
procedure Check_Size procedure Check_Size
(Caller : String; (Caller : String;
T : Instance; T : Dynamic_Hash_Table;
Exp_Count : Natural); Exp_Count : Natural);
-- Ensure that the count of key-value pairs of hash table T matches -- Ensure that the count of key-value pairs of hash table T matches
-- expected count Exp_Count. Emit an error if this is not the case. -- expected count Exp_Count. Emit an error if this is not the case.
...@@ -134,9 +138,9 @@ procedure Dynhash is ...@@ -134,9 +138,9 @@ procedure Dynhash is
function Create_And_Populate function Create_And_Populate
(Low_Key : Integer; (Low_Key : Integer;
High_Key : Integer; High_Key : Integer;
Init_Size : Positive) return Instance Init_Size : Positive) return Dynamic_Hash_Table
is is
T : Instance; T : Dynamic_Hash_Table;
begin begin
T := Create (Init_Size); T := Create (Init_Size);
...@@ -154,7 +158,7 @@ procedure Dynhash is ...@@ -154,7 +158,7 @@ procedure Dynhash is
procedure Check_Empty procedure Check_Empty
(Caller : String; (Caller : String;
T : Instance; T : Dynamic_Hash_Table;
Low_Key : Integer; Low_Key : Integer;
High_Key : Integer) High_Key : Integer)
is is
...@@ -227,7 +231,10 @@ procedure Dynhash is ...@@ -227,7 +231,10 @@ procedure Dynhash is
-- Check_Locked_Mutations -- -- Check_Locked_Mutations --
---------------------------- ----------------------------
procedure Check_Locked_Mutations (Caller : String; T : in out Instance) is procedure Check_Locked_Mutations
(Caller : String;
T : in out Dynamic_Hash_Table)
is
begin begin
begin begin
Delete (T, 1); Delete (T, 1);
...@@ -276,7 +283,7 @@ procedure Dynhash is ...@@ -276,7 +283,7 @@ procedure Dynhash is
procedure Check_Size procedure Check_Size
(Caller : String; (Caller : String;
T : Instance; T : Dynamic_Hash_Table;
Exp_Count : Natural) Exp_Count : Natural)
is is
Count : constant Natural := Size (T); Count : constant Natural := Size (T);
...@@ -305,7 +312,7 @@ procedure Dynhash is ...@@ -305,7 +312,7 @@ procedure Dynhash is
procedure Test_Create (Init_Size : Positive) is procedure Test_Create (Init_Size : Positive) is
Count : Natural; Count : Natural;
Iter : Iterator; Iter : Iterator;
T : Instance; T : Dynamic_Hash_Table;
Val : Integer; Val : Integer;
begin begin
...@@ -402,7 +409,7 @@ procedure Dynhash is ...@@ -402,7 +409,7 @@ procedure Dynhash is
Init_Size : Positive) Init_Size : Positive)
is is
Exp_Val : Integer; Exp_Val : Integer;
T : Instance; T : Dynamic_Hash_Table;
Val : Integer; Val : Integer;
begin begin
...@@ -483,7 +490,7 @@ procedure Dynhash is ...@@ -483,7 +490,7 @@ procedure Dynhash is
is is
Iter_1 : Iterator; Iter_1 : Iterator;
Iter_2 : Iterator; Iter_2 : Iterator;
T : Instance; T : Dynamic_Hash_Table;
begin begin
T := Create_And_Populate (Low_Key, High_Key, Init_Size); T := Create_And_Populate (Low_Key, High_Key, Init_Size);
...@@ -552,7 +559,7 @@ procedure Dynhash is ...@@ -552,7 +559,7 @@ procedure Dynhash is
procedure Test_Iterate_Empty (Init_Size : Positive) is procedure Test_Iterate_Empty (Init_Size : Positive) is
Iter : Iterator; Iter : Iterator;
Key : Integer; Key : Integer;
T : Instance; T : Dynamic_Hash_Table;
begin begin
T := Create_And_Populate (0, -1, Init_Size); T := Create_And_Populate (0, -1, Init_Size);
...@@ -599,7 +606,7 @@ procedure Dynhash is ...@@ -599,7 +606,7 @@ procedure Dynhash is
is is
Iter : Iterator; Iter : Iterator;
Key : Integer; Key : Integer;
T : Instance; T : Dynamic_Hash_Table;
begin begin
T := Create_And_Populate (Low_Key, High_Key, Init_Size); T := Create_And_Populate (Low_Key, High_Key, Init_Size);
...@@ -653,7 +660,7 @@ procedure Dynhash is ...@@ -653,7 +660,7 @@ procedure Dynhash is
Init_Size : Positive) Init_Size : Positive)
is is
Key : constant Integer := 1; Key : constant Integer := 1;
T : Instance; T : Dynamic_Hash_Table;
Val : Integer; Val : Integer;
begin begin
...@@ -687,7 +694,7 @@ procedure Dynhash is ...@@ -687,7 +694,7 @@ procedure Dynhash is
High_Key : Integer; High_Key : Integer;
Init_Size : Positive) Init_Size : Positive)
is is
T : Instance; T : Dynamic_Hash_Table;
begin begin
T := Create_And_Populate (Low_Key, High_Key, Init_Size); T := Create_And_Populate (Low_Key, High_Key, Init_Size);
......
-- { dg-do run }
with Ada.Text_IO; use Ada.Text_IO; with Ada.Text_IO; use Ada.Text_IO;
with GNAT; use GNAT; with GNAT; use GNAT;
with GNAT.Dynamic_HTables; use GNAT.Dynamic_HTables; with GNAT.Dynamic_HTables; use GNAT.Dynamic_HTables;
procedure Dynhash1 is procedure Dynhash1 is
procedure Destroy (Val : in out Integer) is null;
function Hash (Key : Integer) return Bucket_Range_Type is function Hash (Key : Integer) return Bucket_Range_Type is
begin begin
return Bucket_Range_Type (Key); return Bucket_Range_Type (Key);
end Hash; end Hash;
package Integer_Hash_Tables is new Dynamic_HTable package Integer_Hash_Tables is new Dynamic_Hash_Tables
(Key_Type => Integer, (Key_Type => Integer,
Value_Type => Integer, Value_Type => Integer,
No_Value => 0, No_Value => 0,
...@@ -17,11 +20,12 @@ procedure Dynhash1 is ...@@ -17,11 +20,12 @@ procedure Dynhash1 is
Compression_Threshold => 0.3, Compression_Threshold => 0.3,
Compression_Factor => 2, Compression_Factor => 2,
"=" => "=", "=" => "=",
Destroy_Value => Destroy,
Hash => Hash); Hash => Hash);
use Integer_Hash_Tables; use Integer_Hash_Tables;
Siz : Natural; Siz : Natural;
T : Instance; T : Dynamic_Hash_Table;
begin begin
T := Create (8); T := Create (8);
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment