-- --
-- B o d y --
-- --
--- Copyright (C) 2002-2010, AdaCore --
+-- Copyright (C) 2002-2014, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- --
------------------------------------------------------------------------------
+with Ada.Unchecked_Deallocation;
+
package body GNAT.Dynamic_HTables is
-------------------
-------------------
package body Simple_HTable is
+ procedure Free is new
+ Ada.Unchecked_Deallocation (Element_Wrapper, Elmt_Ptr);
---------
-- Get --
end Simple_HTable;
+ ------------------------
+ -- Load_Factor_HTable --
+ ------------------------
+
+ package body Load_Factor_HTable is
+
+ Min_Size_Increase : constant := 5;
+ -- The minimum increase expressed as number of buckets. This value is
+ -- used to determine the new size of small tables and/or small growth
+ -- percentages.
+
+ procedure Attach
+ (Elmt : not null Element_Ptr;
+ Chain : not null Element_Ptr);
+ -- Prepend an element to a bucket chain. Elmt is inserted after the
+ -- dummy head of Chain.
+
+ function Create_Buckets (Size : Positive) return Buckets_Array_Ptr;
+ -- Allocate and initialize a new set of buckets. The buckets are created
+ -- in the range Range_Type'First .. Range_Type'First + Size - 1.
+
+ procedure Detach (Elmt : not null Element_Ptr);
+ -- Remove an element from an arbitrary bucket chain
+
+ function Find
+ (Key : Key_Type;
+ Chain : not null Element_Ptr) return Element_Ptr;
+ -- Try to locate the element which contains a particular key within a
+ -- bucket chain. If no such element exists, return No_Element.
+
+ procedure Free is
+ new Ada.Unchecked_Deallocation (Buckets_Array, Buckets_Array_Ptr);
+
+ procedure Free is
+ new Ada.Unchecked_Deallocation (Element, Element_Ptr);
+
+ function Is_Empty_Chain (Chain : not null Element_Ptr) return Boolean;
+ -- Determine whether a bucket chain contains only one element, namely
+ -- the dummy head.
+
+ ------------
+ -- Attach --
+ ------------
+
+ procedure Attach
+ (Elmt : not null Element_Ptr;
+ Chain : not null Element_Ptr)
+ is
+ begin
+ Chain.Next.Prev := Elmt;
+ Elmt.Next := Chain.Next;
+ Chain.Next := Elmt;
+ Elmt.Prev := Chain;
+ end Attach;
+
+ --------------------
+ -- Create_Buckets --
+ --------------------
+
+ function Create_Buckets (Size : Positive) return Buckets_Array_Ptr is
+ Low_Bound : constant Range_Type := Range_Type'First;
+ Buckets : Buckets_Array_Ptr;
+
+ begin
+ Buckets :=
+ new Buckets_Array (Low_Bound .. Low_Bound + Range_Type (Size) - 1);
+
+ -- Ensure that the dummy head of each bucket chain points to itself
+ -- in both directions.
+
+ for Index in Buckets'Range loop
+ declare
+ Bucket : Element renames Buckets (Index);
+
+ begin
+ Bucket.Prev := Bucket'Unchecked_Access;
+ Bucket.Next := Bucket'Unchecked_Access;
+ end;
+ end loop;
+
+ return Buckets;
+ end Create_Buckets;
+
+ ------------------
+ -- Current_Size --
+ ------------------
+
+ function Current_Size (T : Table) return Positive is
+ begin
+ -- The table should have been properly initialized during object
+ -- elaboration.
+
+ if T.Buckets = null then
+ raise Program_Error;
+
+ -- The size of the table is determined by the number of buckets
+
+ else
+ return T.Buckets'Length;
+ end if;
+ end Current_Size;
+
+ ------------
+ -- Detach --
+ ------------
+
+ procedure Detach (Elmt : not null Element_Ptr) is
+ begin
+ if Elmt.Prev /= null and Elmt.Next /= null then
+ Elmt.Prev.Next := Elmt.Next;
+ Elmt.Next.Prev := Elmt.Prev;
+ Elmt.Prev := null;
+ Elmt.Next := null;
+ end if;
+ end Detach;
+
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (T : in out Table) is
+ Bucket : Element_Ptr;
+ Elmt : Element_Ptr;
+
+ begin
+ -- Inspect the buckets and deallocate bucket chains
+
+ for Index in T.Buckets'Range loop
+ Bucket := T.Buckets (Index)'Unchecked_Access;
+
+ -- The current bucket chain contains an element other than the
+ -- dummy head.
+
+ while not Is_Empty_Chain (Bucket) loop
+
+ -- Skip the dummy head, remove and deallocate the element
+
+ Elmt := Bucket.Next;
+ Detach (Elmt);
+ Free (Elmt);
+ end loop;
+ end loop;
+
+ -- Deallocate the buckets
+
+ Free (T.Buckets);
+ end Finalize;
+
+ ----------
+ -- Find --
+ ----------
+
+ function Find
+ (Key : Key_Type;
+ Chain : not null Element_Ptr) return Element_Ptr
+ is
+ Elmt : Element_Ptr;
+
+ begin
+ -- Skip the dummy head, inspect the bucket chain for an element whose
+ -- key matches the requested key. Since each bucket chain is curcular
+ -- the search must stop once the dummy head is encountered.
+
+ Elmt := Chain.Next;
+ while Elmt /= Chain loop
+ if Equal (Elmt.Key, Key) then
+ return Elmt;
+ end if;
+
+ Elmt := Elmt.Next;
+ end loop;
+
+ return No_Element;
+ end Find;
+
+ ---------
+ -- Get --
+ ---------
+
+ function Get (T : Table; Key : Key_Type) return Value_Type is
+ Bucket : Element_Ptr;
+ Elmt : Element_Ptr;
+
+ begin
+ -- Obtain the bucket chain where the (key, value) pair should reside
+ -- by calculating the proper hash location.
+
+ Bucket := T.Buckets (Hash (Key, Current_Size (T)))'Unchecked_Access;
+
+ -- Try to find an element whose key matches the requested key
+
+ Elmt := Find (Key, Bucket);
+
+ -- The hash table does not contain a matching (key, value) pair
+
+ if Elmt = No_Element then
+ return No_Value;
+ else
+ return Elmt.Val;
+ end if;
+ end Get;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (T : in out Table) is
+ begin
+ pragma Assert (T.Buckets = null);
+
+ T.Buckets := Create_Buckets (Initial_Size);
+ T.Element_Count := 0;
+ end Initialize;
+
+ --------------------
+ -- Is_Empty_Chain --
+ --------------------
+
+ function Is_Empty_Chain (Chain : not null Element_Ptr) return Boolean is
+ begin
+ return Chain.Next = Chain and Chain.Prev = Chain;
+ end Is_Empty_Chain;
+
+ ------------
+ -- Remove --
+ ------------
+
+ procedure Remove (T : in out Table; Key : Key_Type) is
+ Bucket : Element_Ptr;
+ Elmt : Element_Ptr;
+
+ begin
+ -- Obtain the bucket chain where the (key, value) pair should reside
+ -- by calculating the proper hash location.
+
+ Bucket := T.Buckets (Hash (Key, Current_Size (T)))'Unchecked_Access;
+
+ -- Try to find an element whose key matches the requested key
+
+ Elmt := Find (Key, Bucket);
+
+ -- Remove and deallocate the (key, value) pair
+
+ if Elmt /= No_Element then
+ Detach (Elmt);
+ Free (Elmt);
+ end if;
+ end Remove;
+
+ ---------
+ -- Set --
+ ---------
+
+ procedure Set
+ (T : in out Table;
+ Key : Key_Type;
+ Val : Value_Type)
+ is
+ Curr_Size : constant Positive := Current_Size (T);
+
+ procedure Grow;
+ -- Grow the table to a new size according to the desired percentage
+ -- and relocate all existing elements to the new buckets.
+
+ ----------
+ -- Grow --
+ ----------
+
+ procedure Grow is
+ Buckets : Buckets_Array_Ptr;
+ Elmt : Element_Ptr;
+ Hash_Loc : Range_Type;
+ Old_Bucket : Element_Ptr;
+ Old_Buckets : Buckets_Array_Ptr := T.Buckets;
+ Size : Positive;
+
+ begin
+ -- Calculate the new size and allocate a new set of buckets. Note
+ -- that a table with a small size or a small growth percentage may
+ -- not always grow (for example, 10 buckets and 3% increase). In
+ -- that case, enforce a minimum increase.
+
+ Size :=
+ Positive'Max (Curr_Size * ((100 + Growth_Percentage) / 100),
+ Min_Size_Increase);
+ Buckets := Create_Buckets (Size);
+
+ -- Inspect the old buckets and transfer all elements by rehashing
+ -- all (key, value) pairs in the new buckets.
+
+ for Index in Old_Buckets'Range loop
+ Old_Bucket := Old_Buckets (Index)'Unchecked_Access;
+
+ -- The current bucket chain contains an element other than the
+ -- dummy head.
+
+ while not Is_Empty_Chain (Old_Bucket) loop
+
+ -- Skip the dummy head and find the new hash location
+
+ Elmt := Old_Bucket.Next;
+ Hash_Loc := Hash (Elmt.Key, Size);
+
+ -- Remove the element from the old buckets and insert it
+ -- into the new buckets. Note that there is no need to check
+ -- for duplicates because the hash table did not have any to
+ -- begin with.
+
+ Detach (Elmt);
+ Attach
+ (Elmt => Elmt,
+ Chain => Buckets (Hash_Loc)'Unchecked_Access);
+ end loop;
+ end loop;
+
+ -- Associate the new buckets with the table and reclaim the
+ -- storage occupied by the old buckets.
+
+ T.Buckets := Buckets;
+
+ Free (Old_Buckets);
+ end Grow;
+
+ -- Local variables
+
+ subtype LLF is Long_Long_Float;
+
+ Count : Natural renames T.Element_Count;
+ Bucket : Element_Ptr;
+ Hash_Loc : Range_Type;
+
+ -- Start of processing for Set
+
+ begin
+ -- Find the bucket where the (key, value) pair should be inserted by
+ -- computing the proper hash location.
+
+ Hash_Loc := Hash (Key, Curr_Size);
+ Bucket := T.Buckets (Hash_Loc)'Unchecked_Access;
+
+ -- Ensure that the key is not already present in the bucket in order
+ -- to avoid duplicates.
+
+ if Find (Key, Bucket) = No_Element then
+ Attach
+ (Elmt => new Element'(Key, Val, null, null),
+ Chain => Bucket);
+ Count := Count + 1;
+
+ -- Multiple insertions may cause long bucket chains and decrease
+ -- the performance of basic operations. If this is the case, grow
+ -- the table and rehash all existing elements.
+
+ if (LLF (Count) / LLF (Curr_Size)) > LLF (Load_Factor) then
+ Grow;
+ end if;
+ end if;
+ end Set;
+ end Load_Factor_HTable;
+
end GNAT.Dynamic_HTables;
-- --
-- S p e c --
-- --
--- Copyright (C) 1995-2013, AdaCore --
+-- Copyright (C) 1995-2014, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- Hash table searching routines
--- This package contains two separate packages. The Simple_HTable package
--- provides a very simple abstraction that associates one element to one
--- key value and takes care of all allocations automatically using the heap.
--- The Static_HTable package provides a more complex interface that allows
--- complete control over allocation.
+-- This package contains three separate packages. The Simple_HTable package
+-- provides a very simple abstraction that associates one element to one key
+-- value and takes care of all allocations automatically using the heap. The
+-- Static_HTable package provides a more complex interface that allows full
+-- control over allocation. The Load_Factor_HTable package provides a more
+-- complex abstraction where collisions are resolved by chaining, and the
+-- table grows by a percentage after the load factor has been exceeded.
-- This package provides a facility similar to that of GNAT.HTable, except
-- that this package declares types that can be used to define dynamic
-- GNAT.HTable to keep as much coherency as possible between these two
-- related units.
-with Ada.Unchecked_Deallocation;
+private with Ada.Finalization;
+
package GNAT.Dynamic_HTables is
-------------------
Next : Elmt_Ptr;
end record;
- procedure Free is new
- Ada.Unchecked_Deallocation (Element_Wrapper, Elmt_Ptr);
-
procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr);
function Next (E : Elmt_Ptr) return Elmt_Ptr;
function Get_Key (E : Elmt_Ptr) return Key;
end Simple_HTable;
+ ------------------------
+ -- Load_Factor_HTable --
+ ------------------------
+
+ -- A simple hash table abstraction capable of growing once a treshold has
+ -- been exceeded. Collisions are resolved by chaining elements onto lists
+ -- hanging from individual buckets. This implementation does not make any
+ -- effort in minimizing the number of necessary rehashes once the table has
+ -- been expanded, hence the term "simple".
+
+ -- WARNING: This hash table implementation utilizes dynamic allocation.
+ -- Storage reclamation is performed by the hash table.
+
+ -- WARNING: This hash table implementation is not thread-safe. To achieve
+ -- proper concurrency and synchronization, wrap an instance of a table in
+ -- a protected object.
+
+ generic
+ type Range_Type is range <>;
+ -- The underlying range of the hash table. Note that this type must be
+ -- large enough to accomodate multiple expansions of the table.
+
+ type Key_Type is private;
+ type Value_Type is private;
+ -- The types of the (key, value) pair stored in the hash table
+
+ No_Value : Value_Type;
+ -- A predefined value denoting a non-existent value
+
+ Initial_Size : Positive;
+ -- The starting size of the hash table. The hash table must contain at
+ -- least one bucket.
+
+ Growth_Percentage : Positive;
+ -- The amount of increase expressed as a percentage. The hash table must
+ -- grow by at least 1%. To illustrate, a value of 100 will increase the
+ -- table by 100% effectively doubling its size.
+
+ Load_Factor : Float;
+ -- The ratio of the elements stored within the hash table divided by the
+ -- current size of the table. This value acts as the growth treshold. If
+ -- exceeded, the hash table is expanded by Growth_Percentage.
+
+ with function Equal
+ (Left : Key_Type;
+ Right : Key_Type) return Boolean;
+
+ with function Hash
+ (Key : Key_Type;
+ Size : Positive) return Range_Type;
+ -- Parameter Size denotes the current size of the hash table
+
+ package Load_Factor_HTable is
+ type Table is tagged limited private;
+
+ function Current_Size (T : Table) return Positive;
+ -- Obtain the current size of the table
+
+ function Get (T : Table; Key : Key_Type) return Value_Type;
+ -- Obtain the value associated with a key. This routne returns No_Value
+ -- if the key is not present in the hash table.
+
+ procedure Remove (T : in out Table; Key : Key_Type);
+ -- Remove the value associated with the given key. This routine has no
+ -- effect if the key is not present in the hash table.
+
+ procedure Set
+ (T : in out Table;
+ Key : Key_Type;
+ Val : Value_Type);
+ -- Associate a value with a given key. This routine has no effect if the
+ -- the (key, value) pair is already present in the hash table. Note that
+ -- this action may cause the table to grow.
+
+ private
+ -- The following types model a bucket chain. Note that the key is also
+ -- stored for rehashing purposes.
+
+ type Element;
+ type Element_Ptr is access all Element;
+ type Element is record
+ Key : Key_Type;
+ Val : Value_Type;
+ Prev : Element_Ptr := null;
+ Next : Element_Ptr := null;
+ end record;
+
+ No_Element : constant Element_Ptr := null;
+
+ -- The following types model the buckets of the hash table. Each bucket
+ -- has a dummy head to facilitate insertion and deletion of elements.
+
+ type Buckets_Array is array (Range_Type range <>) of aliased Element;
+ type Buckets_Array_Ptr is access all Buckets_Array;
+
+ type Table is new Ada.Finalization.Limited_Controlled with record
+ Buckets : Buckets_Array_Ptr := null;
+
+ Element_Count : Natural := 0;
+ -- The number of (key, value) pairs stored in the hash table
+ end record;
+
+ procedure Finalize (T : in out Table);
+ -- Destroy the contents of a hash table by reclaiming all storage used
+ -- by buckets and their respective chains.
+
+ procedure Initialize (T : in out Table);
+ -- Create a hash table with buckets within the range Range_Type'First ..
+ -- Range_Type'First + Initial_Size - 1.
+
+ end Load_Factor_HTable;
+
end GNAT.Dynamic_HTables;
projects / gcc.git / commitdiff