-- --
-- GNAT LIBRARY COMPONENTS --
-- --
--- A D A . C O N T A I N E R S . --
--- H A S H _ T A B L E S . G E N E R I C _ O P E R A T I O N S --
+-- ADA.CONTAINERS.HASH_TABLES.GENERIC_OPERATIONS --
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2010, 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 2, or (at your option) any later ver- --
+-- 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. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
--- Boston, MA 02110-1301, USA. --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
--- As a special exception, if other files instantiate generics from this --
--- unit, or you link this unit with other files to produce an executable, --
--- this unit does not by itself cause the resulting executable to be --
--- covered by the GNU General Public License. This exception does not --
--- however invalidate any other reasons why the executable file might be --
--- covered by the GNU Public License. --
+-- 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. --
------------------------------------------------------------------------------
--- This body needs commenting ???
-
with Ada.Containers.Prime_Numbers;
with Ada.Unchecked_Deallocation;
package body Ada.Containers.Hash_Tables.Generic_Operations is
- procedure Free is
- new Ada.Unchecked_Deallocation (Buckets_Type, Buckets_Access);
-
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- procedure Rehash
- (HT : in out Hash_Table_Type;
- Size : Hash_Type);
+ 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 --
return;
end if;
- HT.Buckets := new Buckets_Type (Src_Buckets'Range);
- -- TODO: allocate minimum size req'd. (See note below.)
-
- -- NOTE: see note below about these comments.
- -- Probably we have to duplicate the Size (Src), too, in order
- -- to guarantee that
-
- -- Dst := Src;
- -- Dst = Src is true
-
- -- The only quirk is that we depend on the hash value of a dst key
- -- to be the same as the src key from which it was copied.
- -- If we relax the requirement that the hash value must be the
- -- same, then of course we can't guarantee that following
- -- assignment that Dst = Src is true ???
- --
- -- NOTE: 17 Apr 2005
- -- What I said above is no longer true. The semantics of (map) equality
- -- changed, such that we use key in the left map to look up the
- -- equivalent key in the right map, and then compare the elements (using
- -- normal equality) of the equivalent keys. So it doesn't matter that
- -- the maps have different capacities (i.e. the hash tables have
- -- different lengths), since we just look up the key, irrespective of
- -- its map's hash table length. All the RM says we're required to do
- -- it arrange for the target map to "=" the source map following an
- -- assignment (that is, following an Adjust), so it doesn't matter
- -- what the capacity of the target map is. What I'll probably do is
- -- allocate a new hash table that has the minimum size necessary,
- -- instead of allocating a new hash table whose size exactly matches
- -- that of the source. (See the assignment that immediately precedes
- -- these comments.) What we really need is a special Assign operation
- -- (not unlike what we have already for Vector) that allows the user to
- -- choose the capacity of the target.
- -- END NOTE.
+ -- 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);
declare
Dst_Node : constant Node_Access := Copy_Node (Src_Node);
- -- See note above
+ -- See note above
pragma Assert (Index (HT, Dst_Node) = Src_Index);
begin
if HT.Busy > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to tamper with cursors (container is busy)";
end if;
while HT.Length > 0 loop
begin
if HT.Length = 0 then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to delete node from empty hashed container";
end if;
Indx := Index (HT, X);
Prev := HT.Buckets (Indx);
if Prev = null then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to delete node from empty hash bucket";
end if;
if Prev = X then
end if;
if HT.Length = 1 then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to delete node not in its proper hash bucket";
end if;
loop
Curr := Next (Prev);
if Curr = null then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to delete node not in its proper hash bucket";
end if;
if Curr = X then
procedure Finalize (HT : in out Hash_Table_Type) is
begin
Clear (HT);
- Free (HT.Buckets);
+ Free_Buckets (HT.Buckets);
end Finalize;
-----------
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 --
---------------------
end loop;
end loop;
- Free (Buckets);
+ Free_Buckets (Buckets);
end Free_Hash_Table;
-------------------
-------------------
function Generic_Equal
- (L, R : Hash_Table_Type) return Boolean is
-
+ (L, R : Hash_Table_Type) return Boolean
+ is
L_Index : Hash_Type;
L_Node : Node_Access;
return True;
end if;
- L_Index := 0;
+ -- 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;
- N := L.Length;
+ -- 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;
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);
-----------------------
procedure Generic_Iteration (HT : Hash_Table_Type) is
- Busy : Natural renames HT'Unrestricted_Access.all.Busy;
+ Node : Node_Access;
begin
if HT.Length = 0 then
return;
end if;
- Busy := Busy + 1;
-
- declare
- Node : Node_Access;
- begin
- for Indx in HT.Buckets'Range loop
- Node := HT.Buckets (Indx);
- while Node /= null loop
- Process (Node);
- Node := Next (Node);
- end loop;
+ for Indx in HT.Buckets'Range loop
+ Node := HT.Buckets (Indx);
+ while Node /= null loop
+ Process (Node);
+ Node := Next (Node);
end loop;
- exception
- when others =>
- Busy := Busy - 1;
- raise;
- end;
-
- Busy := Busy - 1;
+ end loop;
end Generic_Iteration;
------------------
------------------
procedure Generic_Read
- (Stream : access Root_Stream_Type'Class;
+ (Stream : not null access Root_Stream_Type'Class;
HT : out Hash_Table_Type)
is
- X, Y : Node_Access;
-
- Last, I : Hash_Type;
- N, M : Count_Type'Base;
+ N : Count_Type'Base;
+ NN : Hash_Type;
begin
Clear (HT);
- declare
- B : Buckets_Access := HT.Buckets;
- begin
- HT.Buckets := null;
- HT.Length := 0;
- Free (B); -- can this fail???
- end;
-
- Hash_Type'Read (Stream, Last);
-
- -- TODO: don't immediately deallocate the buckets array we
- -- already have. Instead, allocate a new buckets array only
- -- if it needs to expanded because of the value of Last.
+ Count_Type'Base'Read (Stream, N);
- if Last /= 0 then
- HT.Buckets := new Buckets_Type (0 .. Last);
+ if N < 0 then
+ raise Program_Error with "stream appears to be corrupt";
end if;
- Count_Type'Base'Read (Stream, N);
- pragma Assert (N >= 0);
- while N > 0 loop
- Hash_Type'Read (Stream, I);
- pragma Assert (I in HT.Buckets'Range);
- pragma Assert (HT.Buckets (I) = null);
+ if N = 0 then
+ return;
+ end if;
- Count_Type'Base'Read (Stream, M);
- pragma Assert (M >= 1);
- pragma Assert (M <= N);
+ -- 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.
- HT.Buckets (I) := New_Node (Stream);
- pragma Assert (HT.Buckets (I) /= null);
- pragma Assert (Next (HT.Buckets (I)) = null);
+ 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;
- Y := HT.Buckets (I);
+ for J in 1 .. N loop
+ declare
+ Node : constant Node_Access := New_Node (Stream);
+ Indx : constant Hash_Type := 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;
-
- for J in Count_Type range 2 .. M loop
- X := New_Node (Stream);
- pragma Assert (X /= null);
- pragma Assert (Next (X) = null);
-
- Set_Next (Node => Y, Next => X);
- Y := X;
-
- HT.Length := HT.Length + 1;
- end loop;
-
- N := N - M;
end loop;
end Generic_Read;
-------------------
procedure Generic_Write
- (Stream : access Root_Stream_Type'Class;
+ (Stream : not null access Root_Stream_Type'Class;
HT : Hash_Table_Type)
is
- M : Count_Type'Base;
- X : Node_Access;
-
- begin
- if HT.Buckets = null then
- Hash_Type'Write (Stream, 0);
- else
- Hash_Type'Write (Stream, HT.Buckets'Last);
- end if;
-
- Count_Type'Base'Write (Stream, HT.Length);
+ procedure Write (Node : Node_Access);
+ pragma Inline (Write);
- if HT.Length = 0 then
- return;
- end if;
-
- for Indx in HT.Buckets'Range loop
- X := HT.Buckets (Indx);
+ procedure Write is new Generic_Iteration (Write);
- if X /= null then
- M := 1;
- loop
- X := Next (X);
- exit when X = null;
- M := M + 1;
- end loop;
+ -----------
+ -- Write --
+ -----------
- Hash_Type'Write (Stream, Indx);
- Count_Type'Base'Write (Stream, M);
+ procedure Write (Node : Node_Access) is
+ begin
+ Write (Stream, Node);
+ end Write;
- X := HT.Buckets (Indx);
- for J in Count_Type range 1 .. M loop
- Write (Stream, X);
- X := Next (X);
- end loop;
+ begin
+ -- See Generic_Read for an explanation of why we do not stream out the
+ -- buckets array length too.
- pragma Assert (X = null);
- end if;
- end loop;
+ Count_Type'Base'Write (Stream, HT.Length);
+ Write (HT);
end Generic_Write;
-----------
end if;
if Source.Busy > 0 then
- raise Program_Error;
+ raise Program_Error with
+ "attempt to tamper with cursors (container is busy)";
end if;
Clear (Target);
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 --
----------
return null;
end Next;
- ------------
- -- Rehash --
- ------------
-
- procedure Rehash
- (HT : in out Hash_Table_Type;
- Size : Hash_Type)
- is
- subtype Buckets_Range is Hash_Type range 0 .. Size - 1;
-
- Dst_Buckets : Buckets_Access := new Buckets_Type (Buckets_Range);
- Src_Buckets : Buckets_Access := HT.Buckets;
-
- L : Count_Type renames HT.Length;
- LL : constant Count_Type := L;
-
- begin
- if Src_Buckets = null then
- pragma Assert (L = 0);
- HT.Buckets := Dst_Buckets;
- return;
- end if;
-
- if L = 0 then
- HT.Buckets := Dst_Buckets;
- Free (Src_Buckets);
- return;
- end if;
-
- -- We might want to change this to iter from 1 .. L instead ???
-
- for Src_Index in Src_Buckets'Range 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 :=
- Index (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 =>
-
- -- NOTE: see todo below.
- -- Not clear that we can deallocate the nodes,
- -- because they may be designated by outstanding
- -- iterators. Which means they're now lost... ???
-
- -- for J in NB'Range loop
- -- declare
- -- Dst : Node_Access renames NB (J);
- -- X : Node_Access;
- -- begin
- -- while Dst /= null loop
- -- X := Dst;
- -- Dst := Succ (Dst);
- -- Free (X);
- -- end loop;
- -- end;
- -- end loop;
-
- -- TODO: 17 Apr 2005
- -- What I should do instead is go ahead and deallocate the
- -- nodes, since when assertions are enabled, we vet the
- -- cursors, and we modify the state of a node enough when
- -- it is deallocated in order to detect mischief.
- -- END TODO.
-
- Free (Dst_Buckets);
- raise; -- TODO: raise Program_Error instead
- end;
-
- -- exit when L = 0;
- -- need to bother???
-
- end loop;
-
- pragma Assert (L = 0);
-
- HT.Buckets := Dst_Buckets;
- HT.Length := LL;
-
- Free (Src_Buckets);
- end Rehash;
-
----------------------
-- Reserve_Capacity --
----------------------
NN : Hash_Type;
begin
- if N = 0 then
- if HT.Length = 0 then
- Free (HT.Buckets);
+ if HT.Buckets = null then
+ if N > 0 then
+ NN := Prime_Numbers.To_Prime (N);
+ HT.Buckets := New_Buckets (Length => NN);
+ end if;
- elsif HT.Length < HT.Buckets'Length then
- NN := Prime_Numbers.To_Prime (HT.Length);
+ return;
+ end if;
- -- ASSERT: NN >= HT.Length
+ if HT.Length = 0 then
- if NN < HT.Buckets'Length then
- if HT.Busy > 0 then
- raise Program_Error;
- end if;
+ -- 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.)
- Rehash (HT, Size => NN);
- end if;
+ if N = 0 then
+ Free_Buckets (HT.Buckets);
+ return;
end if;
- return;
- end if;
+ if N = HT.Buckets'Length then
+ return;
+ end if;
- if HT.Buckets = null then
NN := Prime_Numbers.To_Prime (N);
- -- ASSERT: NN >= 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;
- Rehash (HT, Size => NN);
+ if N = HT.Buckets'Length then
return;
end if;
- if N <= HT.Length then
+ 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);
- -- ASSERT: NN >= HT.Length
+ if NN >= HT.Buckets'Length then
+ return;
+ end if;
- if NN < HT.Buckets'Length then
- if HT.Busy > 0 then
- raise Program_Error;
- end if;
+ else
+ NN := Prime_Numbers.To_Prime (Count_Type'Max (N, HT.Length));
- Rehash (HT, Size => NN);
+ if NN = HT.Buckets'Length then -- can't expand any more
+ return;
end if;
+ end if;
- return;
+ if HT.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors (container is busy)";
end if;
- -- ASSERT: N > HT.Length
+ Rehash : declare
+ Dst_Buckets : Buckets_Access := New_Buckets (Length => NN);
+ Src_Buckets : Buckets_Access := HT.Buckets;
+ pragma Warnings (Off, Src_Buckets);
- if N = HT.Buckets'Length then
- return;
- end if;
+ L : Count_Type renames HT.Length;
+ LL : constant Count_Type := L;
- NN := Prime_Numbers.To_Prime (N);
+ Src_Index : Hash_Type := Src_Buckets'First;
- -- ASSERT: NN >= N
- -- ASSERT: NN > HT.Length
+ begin
+ while L > 0 loop
+ declare
+ Src_Bucket : Node_Access renames Src_Buckets (Src_Index);
- if NN /= HT.Buckets'Length then
- if HT.Busy > 0 then
- raise Program_Error;
- end if;
+ begin
+ while Src_Bucket /= null loop
+ declare
+ Src_Node : constant Node_Access := Src_Bucket;
+
+ Dst_Index : constant Hash_Type :=
+ Index (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;
- Rehash (HT, Size => NN);
- end if;
+ 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;
OSDN Git Service
