diff options
Diffstat (limited to 'gcc/ada/a-chtgop.adb')
| -rw-r--r-- | gcc/ada/a-chtgop.adb | 701 |
1 files changed, 701 insertions, 0 deletions
diff --git a/gcc/ada/a-chtgop.adb b/gcc/ada/a-chtgop.adb new file mode 100644 index 00000000000..aa27f427c2e --- /dev/null +++ b/gcc/ada/a-chtgop.adb @@ -0,0 +1,701 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; + |