-- --
-- B o d y --
-- --
--- Copyright (C) 2004 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, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, 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);
+ -- 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.
- -- 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 ???
+ 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_Node then
+ if Src_Node /= null then
declare
Dst_Node : constant Node_Access := Copy_Node (Src_Node);
- -- See note above
+ -- See note above
pragma Assert (Index (HT, Dst_Node) = Src_Index);
end;
Src_Node := Next (Src_Node);
- while Src_Node /= Null_Node loop
+ while Src_Node /= null loop
declare
Dst_Node : constant Node_Access := Copy_Node (Src_Node);
Node : Node_Access;
begin
+ if HT.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors (container is busy)";
+ end if;
+
while HT.Length > 0 loop
- while HT.Buckets (Index) = Null_Node loop
+ while HT.Buckets (Index) = null loop
Index := Index + 1;
end loop;
Bucket := Next (Bucket);
HT.Length := HT.Length - 1;
Free (Node);
- exit when Bucket = Null_Node;
+ exit when Bucket = null;
end loop;
end;
end loop;
(HT : in out Hash_Table_Type;
X : Node_Access)
is
- pragma Assert (X /= Null_Node);
+ pragma Assert (X /= null);
Indx : Hash_Type;
Prev : Node_Access;
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_Node then
- raise Program_Error;
+ if Prev = null then
+ 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_Node then
- raise Program_Error;
+ if Curr = null then
+ raise Program_Error with
+ "attempt to delete node not in its proper hash bucket";
end if;
if Curr = X then
end loop;
end Delete_Node_Sans_Free;
- ---------------------
- -- Ensure_Capacity --
- ---------------------
-
- procedure Ensure_Capacity
- (HT : in out Hash_Table_Type;
- N : Count_Type)
- is
- NN : Hash_Type;
-
- begin
- if N = 0 then
- if HT.Length = 0 then
- Free (HT.Buckets);
-
- elsif HT.Length < HT.Buckets'Length then
- NN := Prime_Numbers.To_Prime (HT.Length);
-
- -- ASSERT: NN >= HT.Length
-
- if NN < HT.Buckets'Length then
- Rehash (HT, Size => NN);
- end if;
- end if;
-
- return;
- end if;
-
- if HT.Buckets = null then
- NN := Prime_Numbers.To_Prime (N);
-
- -- ASSERT: NN >= N
-
- Rehash (HT, Size => NN);
- return;
- end if;
-
- if N <= HT.Length then
- 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
- Rehash (HT, Size => NN);
- end if;
-
- return;
- end if;
-
- -- ASSERT: N > HT.Length
-
- if N = HT.Buckets'Length then
- return;
- end if;
-
- NN := Prime_Numbers.To_Prime (N);
-
- -- ASSERT: NN >= N
- -- ASSERT: NN > HT.Length
-
- if NN /= HT.Buckets'Length then
- Rehash (HT, Size => NN);
- end if;
- end Ensure_Capacity;
-
--------------
-- Finalize --
--------------
procedure Finalize (HT : in out Hash_Table_Type) is
begin
Clear (HT);
- Free (HT.Buckets);
+ Free_Buckets (HT.Buckets);
end Finalize;
-----------
begin
if HT.Length = 0 then
- return Null_Node;
+ return null;
end if;
Indx := HT.Buckets'First;
loop
- if HT.Buckets (Indx) /= Null_Node then
+ if HT.Buckets (Indx) /= null then
return HT.Buckets (Indx);
end if;
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 if;
for J in Buckets'Range loop
- while Buckets (J) /= Null_Node loop
+ while Buckets (J) /= null loop
Node := Buckets (J);
Buckets (J) := Next (Node);
Free (Node);
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_Node;
+ 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_Node then
+ 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_Node;
+ exit when L_Node /= null;
end loop;
end if;
end loop;
Node : Node_Access;
begin
- if HT.Buckets = null
- or else HT.Length = 0
- then
+ if HT.Length = 0 then
return;
end if;
for Indx in HT.Buckets'Range loop
Node := HT.Buckets (Indx);
- while Node /= Null_Node loop
+ while Node /= null loop
Process (Node);
Node := Next (Node);
end loop;
------------------
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
- -- As with the sorted set, it's not clear whether read is allowed to
- -- have side effect if it fails. For now, we assume side effects are
- -- allowed since it simplifies the algorithm ???
- --
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);
+ 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_Node);
+ 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_Node);
- pragma Assert (Next (HT.Buckets (I)) = Null_Node);
+ 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_Node);
- pragma Assert (Next (X) = Null_Node);
-
- 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);
-
- if HT.Length = 0 then
- return;
- end if;
+ procedure Write (Node : Node_Access);
+ pragma Inline (Write);
- for Indx in HT.Buckets'Range loop
- X := HT.Buckets (Indx);
+ procedure Write is new Generic_Iteration (Write);
- if X /= Null_Node then
- M := 1;
- loop
- X := Next (X);
- exit when X = Null_Node;
- 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_Node);
- end if;
- end loop;
+ Count_Type'Base'Write (Stream, HT.Length);
+ Write (HT);
end Generic_Write;
-----------
return;
end if;
- if Target.Length > 0 then
- raise Constraint_Error;
+ if Source.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors (container is busy)";
end if;
- Free (Target.Buckets);
+ Clear (Target);
- Target.Buckets := Source.Buckets;
- Source.Buckets := null;
+ 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 --
----------
Result : Node_Access := Next (Node);
begin
- if Result /= Null_Node then
+ if Result /= null then
return Result;
end if;
for Indx in Index (HT, Node) + 1 .. HT.Buckets'Last loop
Result := HT.Buckets (Indx);
- if Result /= Null_Node then
+ if Result /= null then
return Result;
end if;
end loop;
- return Null_Node;
+ return null;
end Next;
- ------------
- -- Rehash --
- ------------
+ ----------------------
+ -- Reserve_Capacity --
+ ----------------------
- procedure Rehash
- (HT : in out Hash_Table_Type;
- Size : Hash_Type)
+ procedure Reserve_Capacity
+ (HT : in out Hash_Table_Type;
+ N : Count_Type)
is
- subtype Buckets_Range is Hash_Type range 0 .. Size - 1;
+ NN : Hash_Type;
- Dst_Buckets : Buckets_Access := new Buckets_Type (Buckets_Range);
- Src_Buckets : Buckets_Access := HT.Buckets;
+ begin
+ if HT.Buckets = null then
+ if N > 0 then
+ NN := Prime_Numbers.To_Prime (N);
+ HT.Buckets := New_Buckets (Length => NN);
+ end if;
- L : Count_Type renames HT.Length;
- LL : constant Count_Type := L;
+ 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;
- 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);
+ if N = HT.Buckets'Length then
return;
end if;
- -- We might want to change this to iter from 1 .. L instead ???
+ if N < HT.Buckets'Length then
- for Src_Index in Src_Buckets'Range loop
+ -- 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).
- declare
- Src_Bucket : Node_Access renames Src_Buckets (Src_Index);
- begin
- while Src_Bucket /= Null_Node 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;
+ if HT.Length >= HT.Buckets'Length then
+ return;
+ end if;
- pragma Assert (L > 0);
- L := L - 1;
+ NN := Prime_Numbers.To_Prime (HT.Length);
- end loop;
+ if NN >= HT.Buckets'Length then
+ return;
+ end if;
- exception
- when others =>
-
- -- 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_Node loop
- -- X := Dst;
- -- Dst := Succ (Dst);
- -- Free (X);
- -- end loop;
- -- end;
- -- end loop;
-
-
- Free (Dst_Buckets);
- raise;
- end;
+ else
+ NN := Prime_Numbers.To_Prime (Count_Type'Max (N, HT.Length));
- -- exit when L = 0;
- -- need to bother???
+ if NN = HT.Buckets'Length then -- can't expand any more
+ return;
+ end if;
+ end if;
- end loop;
+ if HT.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors (container is busy)";
+ end if;
- pragma Assert (L = 0);
+ Rehash : declare
+ Dst_Buckets : Buckets_Access := New_Buckets (Length => NN);
+ Src_Buckets : Buckets_Access := HT.Buckets;
+ pragma Warnings (Off, Src_Buckets);
- HT.Buckets := Dst_Buckets;
- HT.Length := LL;
+ L : Count_Type renames HT.Length;
+ LL : constant Count_Type := L;
- Free (Src_Buckets);
- end Rehash;
+ Src_Index : Hash_Type := Src_Buckets'First;
-end Ada.Containers.Hash_Tables.Generic_Operations;
+ 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 :=
+ 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;
+ 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;