blob: 658b24b91641d9a936eb1cdd0bc23a6d02e48dd7 [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
-- ADA.CONTAINERS.HASH_TABLES.GENERIC_OPERATIONS --
-- --
-- B o d y --
-- --
-- Copyright (C) 2004-2022, Free Software Foundation, Inc. --
-- --
-- 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- This unit was originally developed by Matthew J Heaney. --
------------------------------------------------------------------------------
with Ada.Containers.Prime_Numbers;
with Ada.Unchecked_Deallocation;
with System; use type System.Address;
package body Ada.Containers.Hash_Tables.Generic_Operations is
pragma Warnings (Off, "variable ""Busy*"" is not referenced");
pragma Warnings (Off, "variable ""Lock*"" is not referenced");
-- See comment in Ada.Containers.Helpers
type Buckets_Allocation is access all Buckets_Type;
-- Used for allocation and deallocation (see New_Buckets and Free_Buckets).
-- This is necessary because Buckets_Access has an empty storage pool.
------------
-- Adjust --
------------
procedure Adjust (HT : in out Hash_Table_Type) is
Src_Buckets : constant Buckets_Access := HT.Buckets;
N : constant Count_Type := HT.Length;
Src_Node : Node_Access;
Dst_Prev : Node_Access;
begin
-- If the counts are nonzero, execution is technically erroneous, but
-- it seems friendly to allow things like concurrent "=" on shared
-- constants.
Zero_Counts (HT.TC);
HT.Buckets := null;
HT.Length := 0;
if N = 0 then
return;
end if;
-- Technically it isn't necessary to allocate the exact same length
-- buckets array, because our only requirement is that following
-- assignment the source and target containers compare equal (that is,
-- operator "=" returns True). We can satisfy this requirement with any
-- hash table length, but we decide here to match the length of the
-- source table. This has the benefit that when iterating, elements of
-- the target are delivered in the exact same order as for the source.
HT.Buckets := New_Buckets (Length => Src_Buckets'Length);
for Src_Index in Src_Buckets'Range loop
Src_Node := Src_Buckets (Src_Index);
if Src_Node /= null then
declare
Dst_Node : constant Node_Access := Copy_Node (Src_Node);
-- See note above
pragma Assert (Checked_Index (HT, Dst_Node) = Src_Index);
begin
HT.Buckets (Src_Index) := Dst_Node;
HT.Length := HT.Length + 1;
Dst_Prev := Dst_Node;
end;
Src_Node := Next (Src_Node);
while Src_Node /= null loop
declare
Dst_Node : constant Node_Access := Copy_Node (Src_Node);
-- See note above
pragma Assert (Checked_Index (HT, Dst_Node) = Src_Index);
begin
Set_Next (Node => Dst_Prev, Next => Dst_Node);
HT.Length := HT.Length + 1;
Dst_Prev := Dst_Node;
end;
Src_Node := Next (Src_Node);
end loop;
end if;
end loop;
pragma Assert (HT.Length = N);
end Adjust;
--------------
-- Capacity --
--------------
function Capacity (HT : Hash_Table_Type) return Count_Type is
begin
if HT.Buckets = null then
return 0;
end if;
return HT.Buckets'Length;
end Capacity;
-------------------
-- Checked_Index --
-------------------
function Checked_Index
(Hash_Table : aliased in out Hash_Table_Type;
Buckets : Buckets_Type;
Node : Node_Access) return Hash_Type
is
Lock : With_Lock (Hash_Table.TC'Unrestricted_Access);
begin
return Index (Buckets, Node);
end Checked_Index;
function Checked_Index
(Hash_Table : aliased in out Hash_Table_Type;
Node : Node_Access) return Hash_Type
is
begin
return Checked_Index (Hash_Table, Hash_Table.Buckets.all, Node);
end Checked_Index;
-----------
-- Clear --
-----------
procedure Clear (HT : in out Hash_Table_Type) is
Index : Hash_Type := 0;
Node : Node_Access;
begin
TC_Check (HT.TC);
while HT.Length > 0 loop
while HT.Buckets (Index) = null loop
Index := Index + 1;
end loop;
declare
Bucket : Node_Access renames HT.Buckets (Index);
begin
loop
Node := Bucket;
Bucket := Next (Bucket);
HT.Length := HT.Length - 1;
Free (Node);
exit when Bucket = null;
end loop;
end;
end loop;
end Clear;
--------------------------
-- Delete_Node_At_Index --
--------------------------
procedure Delete_Node_At_Index
(HT : in out Hash_Table_Type;
Indx : Hash_Type;
X : in out Node_Access)
is
Prev : Node_Access;
Curr : Node_Access;
begin
Prev := HT.Buckets (Indx);
if Prev = X then
HT.Buckets (Indx) := Next (Prev);
HT.Length := HT.Length - 1;
Free (X);
return;
end if;
if Checks and then HT.Length = 1 then
raise Program_Error with
"attempt to delete node not in its proper hash bucket";
end if;
loop
Curr := Next (Prev);
if Checks and then Curr = null then
raise Program_Error with
"attempt to delete node not in its proper hash bucket";
end if;
if Curr = X then
Set_Next (Node => Prev, Next => Next (Curr));
HT.Length := HT.Length - 1;
Free (X);
return;
end if;
Prev := Curr;
end loop;
end Delete_Node_At_Index;
---------------------------
-- Delete_Node_Sans_Free --
---------------------------
procedure Delete_Node_Sans_Free
(HT : in out Hash_Table_Type;
X : Node_Access)
is
pragma Assert (X /= null);
Indx : Hash_Type;
Prev : Node_Access;
Curr : Node_Access;
begin
if Checks and then HT.Length = 0 then
raise Program_Error with
"attempt to delete node from empty hashed container";
end if;
Indx := Checked_Index (HT, X);
Prev := HT.Buckets (Indx);
if Checks and then Prev = null then
raise Program_Error with
"attempt to delete node from empty hash bucket";
end if;
if Prev = X then
HT.Buckets (Indx) := Next (Prev);
HT.Length := HT.Length - 1;
return;
end if;
if Checks and then HT.Length = 1 then
raise Program_Error with
"attempt to delete node not in its proper hash bucket";
end if;
loop
Curr := Next (Prev);
if Checks and then Curr = null then
raise Program_Error with
"attempt to delete node not in its proper hash bucket";
end if;
if Curr = X then
Set_Next (Node => Prev, Next => Next (Curr));
HT.Length := HT.Length - 1;
return;
end if;
Prev := Curr;
end loop;
end Delete_Node_Sans_Free;
--------------
-- Finalize --
--------------
procedure Finalize (HT : in out Hash_Table_Type) is
begin
Clear (HT);
Free_Buckets (HT.Buckets);
end Finalize;
-----------
-- First --
-----------
function First
(HT : Hash_Table_Type) return Node_Access
is
Dummy : Hash_Type;
begin
return First (HT, Dummy);
end First;
function First
(HT : Hash_Table_Type;
Position : out Hash_Type) return Node_Access is
begin
if HT.Length = 0 then
Position := Hash_Type'Last;
return null;
end if;
Position := HT.Buckets'First;
loop
if HT.Buckets (Position) /= null then
return HT.Buckets (Position);
end if;
Position := Position + 1;
end loop;
end First;
------------------
-- Free_Buckets --
------------------
procedure Free_Buckets (Buckets : in out Buckets_Access) is
procedure Free is
new Ada.Unchecked_Deallocation (Buckets_Type, Buckets_Allocation);
begin
-- Buckets must have been created by New_Buckets. Here, we convert back
-- to the Buckets_Allocation type, and do the free on that.
Free (Buckets_Allocation (Buckets));
end Free_Buckets;
---------------------
-- Free_Hash_Table --
---------------------
procedure Free_Hash_Table (Buckets : in out Buckets_Access) is
Node : Node_Access;
begin
if Buckets = null then
return;
end if;
for J in Buckets'Range loop
while Buckets (J) /= null loop
Node := Buckets (J);
Buckets (J) := Next (Node);
Free (Node);
end loop;
end loop;
Free_Buckets (Buckets);
end Free_Hash_Table;
-------------------
-- Generic_Equal --
-------------------
function Generic_Equal
(L, R : Hash_Table_Type) return Boolean
is
begin
if L.Length /= R.Length then
return False;
end if;
if L.Length = 0 then
return True;
end if;
declare
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
Lock_L : With_Lock (L.TC'Unrestricted_Access);
Lock_R : With_Lock (R.TC'Unrestricted_Access);
L_Index : Hash_Type;
L_Node : Node_Access;
N : Count_Type;
begin
-- Find the first node of hash table L
L_Index := 0;
loop
L_Node := L.Buckets (L_Index);
exit when L_Node /= null;
L_Index := L_Index + 1;
end loop;
-- For each node of hash table L, search for an equivalent node in
-- hash table R.
N := L.Length;
loop
if not Find (HT => R, Key => L_Node) then
return False;
end if;
N := N - 1;
L_Node := Next (L_Node);
if L_Node = null then
-- We have exhausted the nodes in this bucket
if N = 0 then
return True;
end if;
-- Find the next bucket
loop
L_Index := L_Index + 1;
L_Node := L.Buckets (L_Index);
exit when L_Node /= null;
end loop;
end if;
end loop;
end;
end Generic_Equal;
-----------------------
-- Generic_Iteration --
-----------------------
procedure Generic_Iteration (HT : Hash_Table_Type) is
procedure Wrapper (Node : Node_Access; Dummy_Pos : Hash_Type);
-------------
-- Wrapper --
-------------
procedure Wrapper (Node : Node_Access; Dummy_Pos : Hash_Type) is
begin
Process (Node);
end Wrapper;
procedure Internal_With_Pos is
new Generic_Iteration_With_Position (Wrapper);
-- Start of processing for Generic_Iteration
begin
Internal_With_Pos (HT);
end Generic_Iteration;
-------------------------------------
-- Generic_Iteration_With_Position --
-------------------------------------
procedure Generic_Iteration_With_Position
(HT : Hash_Table_Type)
is
Node : Node_Access;
begin
if HT.Length = 0 then
return;
end if;
for Indx in HT.Buckets'Range loop
Node := HT.Buckets (Indx);
while Node /= null loop
Process (Node, Indx);
Node := Next (Node);
end loop;
end loop;
end Generic_Iteration_With_Position;
------------------
-- Generic_Read --
------------------
procedure Generic_Read
(Stream : not null access Root_Stream_Type'Class;
HT : out Hash_Table_Type)
is
N : Count_Type'Base;
NN : Hash_Type;
begin
Clear (HT);
Count_Type'Base'Read (Stream, N);
if Checks and then N < 0 then
raise Program_Error with "stream appears to be corrupt";
end if;
if N = 0 then
return;
end if;
-- The RM does not specify whether or how the capacity changes when a
-- hash table is streamed in. Therefore we decide here to allocate a new
-- buckets array only when it's necessary to preserve representation
-- invariants.
if HT.Buckets = null
or else HT.Buckets'Length < N
then
Free_Buckets (HT.Buckets);
NN := Prime_Numbers.To_Prime (N);
HT.Buckets := New_Buckets (Length => NN);
end if;
for J in 1 .. N loop
declare
Node : constant Node_Access := New_Node (Stream);
Indx : constant Hash_Type := Checked_Index (HT, Node);
B : Node_Access renames HT.Buckets (Indx);
begin
Set_Next (Node => Node, Next => B);
B := Node;
end;
HT.Length := HT.Length + 1;
end loop;
end Generic_Read;
-------------------
-- Generic_Write --
-------------------
procedure Generic_Write
(Stream : not null access Root_Stream_Type'Class;
HT : Hash_Table_Type)
is
procedure Write (Node : Node_Access);
pragma Inline (Write);
procedure Write is new Generic_Iteration (Write);
-----------
-- Write --
-----------
procedure Write (Node : Node_Access) is
begin
Write (Stream, Node);
end Write;
begin
-- See Generic_Read for an explanation of why we do not stream out the
-- buckets array length too.
Count_Type'Base'Write (Stream, HT.Length);
Write (HT);
end Generic_Write;
-----------
-- Index --
-----------
function Index
(Buckets : Buckets_Type;
Node : Node_Access) return Hash_Type is
begin
return Hash_Node (Node) mod Buckets'Length;
end Index;
function Index
(Hash_Table : Hash_Table_Type;
Node : Node_Access) return Hash_Type is
begin
return Index (Hash_Table.Buckets.all, Node);
end Index;
----------
-- Move --
----------
procedure Move (Target, Source : in out Hash_Table_Type) is
begin
if Target'Address = Source'Address then
return;
end if;
TC_Check (Source.TC);
Clear (Target);
declare
Buckets : constant Buckets_Access := Target.Buckets;
begin
Target.Buckets := Source.Buckets;
Source.Buckets := Buckets;
end;
Target.Length := Source.Length;
Source.Length := 0;
end Move;
-----------------
-- New_Buckets --
-----------------
function New_Buckets (Length : Hash_Type) return Buckets_Access is
subtype Rng is Hash_Type range 0 .. Length - 1;
begin
-- Allocate in Buckets_Allocation'Storage_Pool, then convert to
-- Buckets_Access.
return Buckets_Access (Buckets_Allocation'(new Buckets_Type (Rng)));
end New_Buckets;
----------
-- Next --
----------
function Next
(HT : aliased in out Hash_Table_Type;
Node : Node_Access;
Position : in out Hash_Type) return Node_Access
is
Result : Node_Access;
First : Hash_Type;
begin
-- First, check if the node has other nodes chained to it
Result := Next (Node);
if Result /= null then
return Result;
end if;
-- Check if we were supplied a position for Node, from which we
-- can start iteration on the buckets.
if Position /= Hash_Type'Last then
First := Position + 1;
else
First := Checked_Index (HT, Node) + 1;
end if;
for Indx in First .. HT.Buckets'Last loop
Result := HT.Buckets (Indx);
if Result /= null then
Position := Indx;
return Result;
end if;
end loop;
return null;
end Next;
function Next
(HT : aliased in out Hash_Table_Type;
Node : Node_Access) return Node_Access
is
Pos : Hash_Type := Hash_Type'Last;
begin
return Next (HT, Node, Pos);
end Next;
----------------------
-- Reserve_Capacity --
----------------------
procedure Reserve_Capacity
(HT : in out Hash_Table_Type;
N : Count_Type)
is
NN : Hash_Type;
begin
if HT.Buckets = null then
if N > 0 then
NN := Prime_Numbers.To_Prime (N);
HT.Buckets := New_Buckets (Length => NN);
end if;
return;
end if;
if HT.Length = 0 then
-- This is the easy case. There are no nodes, so no rehashing is
-- necessary. All we need to do is allocate a new buckets array
-- having a length implied by the specified capacity. (We say
-- "implied by" because bucket arrays are always allocated with a
-- length that corresponds to a prime number.)
if N = 0 then
Free_Buckets (HT.Buckets);
return;
end if;
if N = HT.Buckets'Length then
return;
end if;
NN := Prime_Numbers.To_Prime (N);
if NN = HT.Buckets'Length then
return;
end if;
declare
X : Buckets_Access := HT.Buckets;
pragma Warnings (Off, X);
begin
HT.Buckets := New_Buckets (Length => NN);
Free_Buckets (X);
end;
return;
end if;
if N = HT.Buckets'Length then
return;
end if;
if N < HT.Buckets'Length then
-- This is a request to contract the buckets array. The amount of
-- contraction is bounded in order to preserve the invariant that the
-- buckets array length is never smaller than the number of elements
-- (the load factor is 1).
if HT.Length >= HT.Buckets'Length then
return;
end if;
NN := Prime_Numbers.To_Prime (HT.Length);
if NN >= HT.Buckets'Length then
return;
end if;
else
NN := Prime_Numbers.To_Prime (Count_Type'Max (N, HT.Length));
if NN = HT.Buckets'Length then -- can't expand any more
return;
end if;
end if;
TC_Check (HT.TC);
Rehash : declare
Dst_Buckets : Buckets_Access := New_Buckets (Length => NN);
Src_Buckets : Buckets_Access := HT.Buckets;
pragma Warnings (Off, Src_Buckets);
L : Count_Type renames HT.Length;
LL : constant Count_Type := L;
Src_Index : Hash_Type := Src_Buckets'First;
begin
while L > 0 loop
declare
Src_Bucket : Node_Access renames Src_Buckets (Src_Index);
begin
while Src_Bucket /= null loop
declare
Src_Node : constant Node_Access := Src_Bucket;
Dst_Index : constant Hash_Type :=
Checked_Index (HT, Dst_Buckets.all, Src_Node);
Dst_Bucket : Node_Access renames Dst_Buckets (Dst_Index);
begin
Src_Bucket := Next (Src_Node);
Set_Next (Src_Node, Dst_Bucket);
Dst_Bucket := Src_Node;
end;
pragma Assert (L > 0);
L := L - 1;
end loop;
exception
when others =>
-- If there's an error computing a hash value during a
-- rehash, then AI-302 says the nodes "become lost." The
-- issue is whether to actually deallocate these lost nodes,
-- since they might be designated by extant cursors. Here
-- we decide to deallocate the nodes, since it's better to
-- solve real problems (storage consumption) rather than
-- imaginary ones (the user might, or might not, dereference
-- a cursor designating a node that has been deallocated),
-- and because we have a way to vet a dangling cursor
-- reference anyway, and hence can actually detect the
-- problem.
for Dst_Index in Dst_Buckets'Range loop
declare
B : Node_Access renames Dst_Buckets (Dst_Index);
X : Node_Access;
begin
while B /= null loop
X := B;
B := Next (X);
Free (X);
end loop;
end;
end loop;
Free_Buckets (Dst_Buckets);
raise Program_Error with
"hash function raised exception during rehash";
end;
Src_Index := Src_Index + 1;
end loop;
HT.Buckets := Dst_Buckets;
HT.Length := LL;
Free_Buckets (Src_Buckets);
end Rehash;
end Reserve_Capacity;
end Ada.Containers.Hash_Tables.Generic_Operations;