aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.8/gcc/ada/a-chtgop.adb
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.8/gcc/ada/a-chtgop.adb')
-rw-r--r--gcc-4.8/gcc/ada/a-chtgop.adb703
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;