diff options
Diffstat (limited to 'gcc-4.8/gcc/ada/a-chtgop.adb')
-rw-r--r-- | gcc-4.8/gcc/ada/a-chtgop.adb | 703 |
1 files changed, 0 insertions, 703 deletions
diff --git a/gcc-4.8/gcc/ada/a-chtgop.adb b/gcc-4.8/gcc/ada/a-chtgop.adb deleted file mode 100644 index d014dc17c..000000000 --- a/gcc-4.8/gcc/ada/a-chtgop.adb +++ /dev/null @@ -1,703 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.HASH_TABLES.GENERIC_OPERATIONS -- --- -- --- B o d y -- --- -- --- 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 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. -- --- -- --- 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. -- ------------------------------------------------------------------------------- - -with Ada.Containers.Prime_Numbers; -with Ada.Unchecked_Deallocation; - -with System; use type System.Address; - -package body Ada.Containers.Hash_Tables.Generic_Operations is - - 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 -- - ------------ - - 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; - - -- 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); - - 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 with - "attempt to tamper with cursors (container is busy)"; - 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 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 with - "attempt to delete node from empty hash bucket"; - 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 with - "attempt to delete node not in its proper hash bucket"; - end if; - - loop - Curr := Next (Prev); - - if Curr = null then - raise Program_Error with - "attempt to delete node not in its proper hash bucket"; - 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_Buckets (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_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 -- - --------------------- - - 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 (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; - - -- 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; - - -- 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; - end if; - - N := N - 1; - - 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); - exit when L_Node /= null; - 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.Length = 0 then - return; - end if; - - for Indx in HT.Buckets'Range loop - Node := HT.Buckets (Indx); - while Node /= null loop - Process (Node); - Node := Next (Node); - end loop; - end loop; - end Generic_Iteration; - - ------------------ - -- Generic_Read -- - ------------------ - - procedure Generic_Read - (Stream : not null access Root_Stream_Type'Class; - HT : out Hash_Table_Type) - is - N : Count_Type'Base; - NN : Hash_Type; - - begin - Clear (HT); - - Count_Type'Base'Read (Stream, N); - - if N < 0 then - raise Program_Error with "stream appears to be corrupt"; - end if; - - if N = 0 then - return; - end if; - - -- 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. - - 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; - - 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; - end loop; - end Generic_Read; - - ------------------- - -- Generic_Write -- - ------------------- - - procedure Generic_Write - (Stream : not null access Root_Stream_Type'Class; - HT : Hash_Table_Type) - is - procedure Write (Node : Node_Access); - pragma Inline (Write); - - procedure Write is new Generic_Iteration (Write); - - ----------- - -- Write -- - ----------- - - procedure Write (Node : Node_Access) is - begin - Write (Stream, Node); - end Write; - - begin - -- See Generic_Read for an explanation of why we do not stream out the - -- buckets array length too. - - Count_Type'Base'Write (Stream, HT.Length); - Write (HT); - 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 with - "attempt to tamper with cursors (container is busy)"; - 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; - - ----------------- - -- 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 -- - ---------- - - 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 (Length => NN); - end if; - - 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; - - return; - end if; - - if N = HT.Buckets'Length then - return; - end if; - - 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); - - 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 with - "attempt to tamper with cursors (container is busy)"; - end if; - - Rehash : declare - Dst_Buckets : Buckets_Access := New_Buckets (Length => NN); - Src_Buckets : Buckets_Access := HT.Buckets; - pragma Warnings (Off, Src_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_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; |