------------------------------------------------------------------------------ -- -- -- GNAT LIBRARY COMPONENTS -- -- -- -- ADA.CONTAINERS.HASH_TABLES.GENERIC_OPERATIONS -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004 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- -- -- 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. -- -- -- -- 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. -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ -- This body needs commenting ??? with Ada.Containers.Prime_Numbers; with Ada.Unchecked_Deallocation; with System; use type System.Address; 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); ------------ -- 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 HT.Buckets := null; HT.Length := 0; if N = 0 then return; end if; HT.Buckets := new Buckets_Type (Src_Buckets'Range); -- 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 ??? for Src_Index in Src_Buckets'Range loop Src_Node := Src_Buckets (Src_Index); if Src_Node /= Null_Node then declare Dst_Node : constant Node_Access := Copy_Node (Src_Node); -- See note above pragma Assert (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_Node loop declare Dst_Node : constant Node_Access := Copy_Node (Src_Node); -- See note above pragma Assert (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; ----------- -- Clear -- ----------- procedure Clear (HT : in out Hash_Table_Type) is Index : Hash_Type := 0; Node : Node_Access; begin while HT.Length > 0 loop while HT.Buckets (Index) = Null_Node 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_Node; end loop; end; end loop; end Clear; --------------------------- -- Delete_Node_Sans_Free -- --------------------------- procedure Delete_Node_Sans_Free (HT : in out Hash_Table_Type; X : Node_Access) is pragma Assert (X /= Null_Node); Indx : Hash_Type; Prev : Node_Access; Curr : Node_Access; begin if HT.Length = 0 then raise Program_Error; end if; Indx := Index (HT, X); Prev := HT.Buckets (Indx); if Prev = Null_Node then raise Program_Error; end if; if Prev = X then HT.Buckets (Indx) := Next (Prev); HT.Length := HT.Length - 1; return; end if; if HT.Length = 1 then raise Program_Error; end if; loop Curr := Next (Prev); if Curr = Null_Node then raise Program_Error; 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; --------------------- -- 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); end Finalize; ----------- -- First -- ----------- function First (HT : Hash_Table_Type) return Node_Access is Indx : Hash_Type; begin if HT.Length = 0 then return Null_Node; end if; Indx := HT.Buckets'First; loop if HT.Buckets (Indx) /= Null_Node then return HT.Buckets (Indx); end if; Indx := Indx + 1; end loop; end First; --------------------- -- 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_Node loop Node := Buckets (J); Buckets (J) := Next (Node); Free (Node); end loop; end loop; Free (Buckets); end Free_Hash_Table; ------------------- -- Generic_Equal -- ------------------- function Generic_Equal (L, R : Hash_Table_Type) return Boolean is L_Index : Hash_Type; L_Node : Node_Access; N : Count_Type; begin if L'Address = R'Address then return True; end if; if L.Length /= R.Length then return False; end if; if L.Length = 0 then return True; end if; L_Index := 0; loop L_Node := L.Buckets (L_Index); exit when L_Node /= Null_Node; L_Index := L_Index + 1; end loop; 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_Node then if N = 0 then return True; end if; loop L_Index := L_Index + 1; L_Node := L.Buckets (L_Index); exit when L_Node /= Null_Node; end loop; end if; end loop; end Generic_Equal; ----------------------- -- Generic_Iteration -- ----------------------- procedure Generic_Iteration (HT : Hash_Table_Type) is Node : Node_Access; begin if HT.Buckets = null or else HT.Length = 0 then return; end if; for Indx in HT.Buckets'Range loop Node := HT.Buckets (Indx); while Node /= Null_Node loop Process (Node); Node := Next (Node); end loop; end loop; end Generic_Iteration; ------------------ -- Generic_Read -- ------------------ procedure Generic_Read (Stream : access Root_Stream_Type'Class; HT : out Hash_Table_Type) is X, Y : Node_Access; Last, I : Hash_Type; N, M : Count_Type'Base; 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); if Last /= 0 then HT.Buckets := new Buckets_Type (0 .. Last); 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); Count_Type'Base'Read (Stream, M); pragma Assert (M >= 1); pragma Assert (M <= N); HT.Buckets (I) := New_Node (Stream); pragma Assert (HT.Buckets (I) /= Null_Node); pragma Assert (Next (HT.Buckets (I)) = Null_Node); Y := HT.Buckets (I); 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; ------------------- -- Generic_Write -- ------------------- procedure Generic_Write (Stream : 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; for Indx in HT.Buckets'Range loop X := HT.Buckets (Indx); if X /= Null_Node then M := 1; loop X := Next (X); exit when X = Null_Node; M := M + 1; end loop; Hash_Type'Write (Stream, Indx); Count_Type'Base'Write (Stream, M); X := HT.Buckets (Indx); for J in Count_Type range 1 .. M loop Write (Stream, X); X := Next (X); end loop; pragma Assert (X = Null_Node); end if; end loop; 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; if Target.Length > 0 then raise Constraint_Error; end if; Free (Target.Buckets); Target.Buckets := Source.Buckets; Source.Buckets := null; Target.Length := Source.Length; Source.Length := 0; end Move; ---------- -- Next -- ---------- function Next (HT : Hash_Table_Type; Node : Node_Access) return Node_Access is Result : Node_Access := Next (Node); begin if Result /= Null_Node 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 return Result; end if; end loop; return Null_Node; 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_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; pragma Assert (L > 0); L := L - 1; end loop; 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; -- 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; end Ada.Containers.Hash_Tables.Generic_Operations;