diff options
Diffstat (limited to 'gcc-4.2.1/gcc/ada/a-chtgop.adb')
| -rw-r--r-- | gcc-4.2.1/gcc/ada/a-chtgop.adb | 731 |
1 files changed, 0 insertions, 731 deletions
diff --git a/gcc-4.2.1/gcc/ada/a-chtgop.adb b/gcc-4.2.1/gcc/ada/a-chtgop.adb deleted file mode 100644 index 137b27c00..000000000 --- a/gcc-4.2.1/gcc/ada/a-chtgop.adb +++ /dev/null @@ -1,731 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2005, 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, 51 Franklin Street, Fifth Floor, -- --- Boston, MA 02110-1301, 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); - - ------------ - -- 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); - -- 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. - - 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 (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 (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 - if HT.Busy > 0 then - raise Program_Error; - end if; - - 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_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 HT.Length = 0 then - raise Program_Error; - end if; - - Indx := Index (HT, X); - Prev := HT.Buckets (Indx); - - if Prev = null 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 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; - - -------------- - -- 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; - end if; - - Indx := HT.Buckets'First; - loop - if HT.Buckets (Indx) /= null 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 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; - 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 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; - end loop; - end if; - end loop; - end Generic_Equal; - - ----------------------- - -- Generic_Iteration -- - ----------------------- - - procedure Generic_Iteration (HT : Hash_Table_Type) is - Busy : Natural renames HT'Unrestricted_Access.all.Busy; - - 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; - end loop; - exception - when others => - Busy := Busy - 1; - raise; - end; - - Busy := Busy - 1; - 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 - Clear (HT); - - Hash_Type'Read (Stream, Last); - - Count_Type'Base'Read (Stream, N); - pragma Assert (N >= 0); - - if N = 0 then - return; - end if; - - if HT.Buckets = null - or else HT.Buckets'Last /= Last - then - Free (HT.Buckets); - HT.Buckets := new Buckets_Type (0 .. Last); - end if; - - -- TODO: should we rewrite this algorithm so that it doesn't - -- depend on preserving the exactly length of the hash table - -- array? We would prefer to not have to (re)allocate a - -- buckets array (the array that HT already has might be large - -- enough), and to not have to stream the count of the number - -- of nodes in each bucket. The algorithm below is vestigial, - -- as it was written prior to the meeting in Palma, when the - -- semantics of equality were changed (and which obviated the - -- need to preserve the hash table length). - - loop - Hash_Type'Read (Stream, I); - pragma Assert (I in HT.Buckets'Range); - pragma Assert (HT.Buckets (I) = null); - - 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); - pragma Assert (Next (HT.Buckets (I)) = null); - - 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); - pragma Assert (Next (X) = null); - - Set_Next (Node => Y, Next => X); - Y := X; - - HT.Length := HT.Length + 1; - end loop; - - N := N - M; - - exit when N = 0; - 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; - - -- TODO: see note in Generic_Read??? - - for Indx in HT.Buckets'Range loop - X := HT.Buckets (Indx); - - if X /= null then - M := 1; - loop - X := Next (X); - exit when X = null; - 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); - 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 Source.Busy > 0 then - raise Program_Error; - end if; - - 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; - - ---------- - -- Next -- - ---------- - - function Next - (HT : Hash_Table_Type; - Node : Node_Access) return Node_Access - is - Result : Node_Access := Next (Node); - - begin - 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 then - return Result; - end if; - end loop; - - return null; - 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_Type (0 .. NN - 1); - end if; - - return; - end if; - - if HT.Length = 0 then - if N = 0 then - Free (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; - begin - HT.Buckets := new Buckets_Type (0 .. NN - 1); - Free (X); - end; - - return; - end if; - - if N = HT.Buckets'Length then - return; - end if; - - if N < HT.Buckets'Length then - 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; - - if HT.Busy > 0 then - raise Program_Error; - end if; - - Rehash : declare - Dst_Buckets : Buckets_Access := new Buckets_Type (0 .. NN - 1); - Src_Buckets : Buckets_Access := HT.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 := - 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 (Dst_Buckets); - raise Program_Error; - end; - - Src_Index := Src_Index + 1; - end loop; - - HT.Buckets := Dst_Buckets; - HT.Length := LL; - - Free (Src_Buckets); - end Rehash; - end Reserve_Capacity; - -end Ada.Containers.Hash_Tables.Generic_Operations; |