aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.7/gcc/ada/a-chtgbo.adb
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.7/gcc/ada/a-chtgbo.adb')
-rw-r--r--gcc-4.7/gcc/ada/a-chtgbo.adb485
1 files changed, 0 insertions, 485 deletions
diff --git a/gcc-4.7/gcc/ada/a-chtgbo.adb b/gcc-4.7/gcc/ada/a-chtgbo.adb
deleted file mode 100644
index 1a395d3b3..000000000
--- a/gcc-4.7/gcc/ada/a-chtgbo.adb
+++ /dev/null
@@ -1,485 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT LIBRARY COMPONENTS --
--- --
--- ADA.CONTAINERS.HASH_TABLES.GENERIC_BOUNDED_OPERATIONS --
--- --
--- B o d y --
--- --
--- Copyright (C) 2004-2011, 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 System; use type System.Address;
-
-package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is
-
- -----------
- -- Clear --
- -----------
-
- procedure Clear (HT : in out Hash_Table_Type'Class) is
- begin
- if HT.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (container is busy)";
- end if;
-
- HT.Length := 0;
- -- HT.Busy := 0;
- -- HT.Lock := 0;
- HT.Free := -1;
- HT.Buckets := (others => 0); -- optimize this somehow ???
- end Clear;
-
- ---------------------------
- -- Delete_Node_Sans_Free --
- ---------------------------
-
- procedure Delete_Node_Sans_Free
- (HT : in out Hash_Table_Type'Class;
- X : Count_Type)
- is
- pragma Assert (X /= 0);
-
- Indx : Hash_Type;
- Prev : Count_Type;
- Curr : Count_Type;
-
- begin
- if HT.Length = 0 then
- raise Program_Error with
- "attempt to delete node from empty hashed container";
- end if;
-
- Indx := Index (HT, HT.Nodes (X));
- Prev := HT.Buckets (Indx);
-
- if Prev = 0 then
- raise Program_Error with
- "attempt to delete node from empty hash bucket";
- end if;
-
- if Prev = X then
- HT.Buckets (Indx) := Next (HT.Nodes (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 (HT.Nodes (Prev));
-
- if Curr = 0 then
- raise Program_Error with
- "attempt to delete node not in its proper hash bucket";
- end if;
-
- if Curr = X then
- Set_Next (HT.Nodes (Prev), Next => Next (HT.Nodes (Curr)));
- HT.Length := HT.Length - 1;
- return;
- end if;
-
- Prev := Curr;
- end loop;
- end Delete_Node_Sans_Free;
-
- -----------
- -- First --
- -----------
-
- function First (HT : Hash_Table_Type'Class) return Count_Type is
- Indx : Hash_Type;
-
- begin
- if HT.Length = 0 then
- return 0;
- end if;
-
- Indx := HT.Buckets'First;
- loop
- if HT.Buckets (Indx) /= 0 then
- return HT.Buckets (Indx);
- end if;
-
- Indx := Indx + 1;
- end loop;
- end First;
-
- ----------
- -- Free --
- ----------
-
- procedure Free
- (HT : in out Hash_Table_Type'Class;
- X : Count_Type)
- is
- N : Nodes_Type renames HT.Nodes;
-
- begin
- -- This subprogram "deallocates" a node by relinking the node off of the
- -- active list and onto the free list. Previously it would flag index
- -- value 0 as an error. The precondition was weakened, so that index
- -- value 0 is now allowed, and this value is interpreted to mean "do
- -- nothing". This makes its behavior analogous to the behavior of
- -- Ada.Unchecked_Deallocation, and allows callers to avoid having to add
- -- special-case checks at the point of call.
-
- if X = 0 then
- return;
- end if;
-
- pragma Assert (X <= HT.Capacity);
-
- -- pragma Assert (N (X).Prev >= 0); -- node is active
- -- Find a way to mark a node as active vs. inactive; we could
- -- use a special value in Color_Type for this. ???
-
- -- The hash table actually contains two data structures: a list for
- -- the "active" nodes that contain elements that have been inserted
- -- onto the container, and another for the "inactive" nodes of the free
- -- store.
- --
- -- We desire that merely declaring an object should have only minimal
- -- cost; specially, we want to avoid having to initialize the free
- -- store (to fill in the links), especially if the capacity is large.
- --
- -- The head of the free list is indicated by Container.Free. If its
- -- value is non-negative, then the free store has been initialized
- -- in the "normal" way: Container.Free points to the head of the list
- -- of free (inactive) nodes, and the value 0 means the free list is
- -- empty. Each node on the free list has been initialized to point
- -- to the next free node (via its Parent component), and the value 0
- -- means that this is the last free node.
- --
- -- If Container.Free is negative, then the links on the free store
- -- have not been initialized. In this case the link values are
- -- implied: the free store comprises the components of the node array
- -- started with the absolute value of Container.Free, and continuing
- -- until the end of the array (Nodes'Last).
- --
- -- ???
- -- It might be possible to perform an optimization here. Suppose that
- -- the free store can be represented as having two parts: one
- -- comprising the non-contiguous inactive nodes linked together
- -- in the normal way, and the other comprising the contiguous
- -- inactive nodes (that are not linked together, at the end of the
- -- nodes array). This would allow us to never have to initialize
- -- the free store, except in a lazy way as nodes become inactive.
-
- -- When an element is deleted from the list container, its node
- -- becomes inactive, and so we set its Next component to value of
- -- the node's index (in the nodes array), to indicate that it is
- -- now inactive. This provides a useful way to detect a dangling
- -- cursor reference. ???
-
- Set_Next (N (X), Next => X); -- Node is deallocated (not on active list)
-
- if HT.Free >= 0 then
- -- The free store has previously been initialized. All we need to
- -- do here is link the newly-free'd node onto the free list.
-
- Set_Next (N (X), HT.Free);
- HT.Free := X;
-
- elsif X + 1 = abs HT.Free then
- -- The free store has not been initialized, and the node becoming
- -- inactive immediately precedes the start of the free store. All
- -- we need to do is move the start of the free store back by one.
-
- HT.Free := HT.Free + 1;
-
- else
- -- The free store has not been initialized, and the node becoming
- -- inactive does not immediately precede the free store. Here we
- -- first initialize the free store (meaning the links are given
- -- values in the traditional way), and then link the newly-free'd
- -- node onto the head of the free store.
-
- -- ???
- -- See the comments above for an optimization opportunity. If
- -- the next link for a node on the free store is negative, then
- -- this means the remaining nodes on the free store are
- -- physically contiguous, starting as the absolute value of
- -- that index value.
-
- HT.Free := abs HT.Free;
-
- if HT.Free > HT.Capacity then
- HT.Free := 0;
-
- else
- for I in HT.Free .. HT.Capacity - 1 loop
- Set_Next (Node => N (I), Next => I + 1);
- end loop;
-
- Set_Next (Node => N (HT.Capacity), Next => 0);
- end if;
-
- Set_Next (Node => N (X), Next => HT.Free);
- HT.Free := X;
- end if;
- end Free;
-
- ----------------------
- -- Generic_Allocate --
- ----------------------
-
- procedure Generic_Allocate
- (HT : in out Hash_Table_Type'Class;
- Node : out Count_Type)
- is
- N : Nodes_Type renames HT.Nodes;
-
- begin
- if HT.Free >= 0 then
- Node := HT.Free;
-
- -- We always perform the assignment first, before we
- -- change container state, in order to defend against
- -- exceptions duration assignment.
-
- Set_Element (N (Node));
- HT.Free := Next (N (Node));
-
- else
- -- A negative free store value means that the links of the nodes
- -- in the free store have not been initialized. In this case, the
- -- nodes are physically contiguous in the array, starting at the
- -- index that is the absolute value of the Container.Free, and
- -- continuing until the end of the array (Nodes'Last).
-
- Node := abs HT.Free;
-
- -- As above, we perform this assignment first, before modifying
- -- any container state.
-
- Set_Element (N (Node));
- HT.Free := HT.Free - 1;
- end if;
- end Generic_Allocate;
-
- -------------------
- -- Generic_Equal --
- -------------------
-
- function Generic_Equal
- (L, R : Hash_Table_Type'Class) return Boolean
- is
- L_Index : Hash_Type;
- L_Node : Count_Type;
-
- 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 := L.Buckets'First;
- loop
- L_Node := L.Buckets (L_Index);
- exit when L_Node /= 0;
- 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.Nodes (L_Node)) then
- return False;
- end if;
-
- N := N - 1;
-
- L_Node := Next (L.Nodes (L_Node));
-
- if L_Node = 0 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 /= 0;
- end loop;
- end if;
- end loop;
- end Generic_Equal;
-
- -----------------------
- -- Generic_Iteration --
- -----------------------
-
- procedure Generic_Iteration (HT : Hash_Table_Type'Class) is
- Node : Count_Type;
-
- begin
- if HT.Length = 0 then
- return;
- end if;
-
- for Indx in HT.Buckets'Range loop
- Node := HT.Buckets (Indx);
- while Node /= 0 loop
- Process (Node);
- Node := Next (HT.Nodes (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'Class)
- is
- N : Count_Type'Base;
-
- 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;
-
- if N > HT.Capacity then
- raise Capacity_Error with "too many elements in stream";
- end if;
-
- for J in 1 .. N loop
- declare
- Node : constant Count_Type := New_Node (Stream);
- Indx : constant Hash_Type := Index (HT, HT.Nodes (Node));
- B : Count_Type renames HT.Buckets (Indx);
- begin
- Set_Next (HT.Nodes (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'Class)
- is
- procedure Write (Node : Count_Type);
- pragma Inline (Write);
-
- procedure Write is new Generic_Iteration (Write);
-
- -----------
- -- Write --
- -----------
-
- procedure Write (Node : Count_Type) is
- begin
- Write (Stream, HT.Nodes (Node));
- end Write;
-
- begin
- Count_Type'Base'Write (Stream, HT.Length);
- Write (HT);
- end Generic_Write;
-
- -----------
- -- Index --
- -----------
-
- function Index
- (Buckets : Buckets_Type;
- Node : Node_Type) return Hash_Type is
- begin
- return Buckets'First + Hash_Node (Node) mod Buckets'Length;
- end Index;
-
- function Index
- (HT : Hash_Table_Type'Class;
- Node : Node_Type) return Hash_Type is
- begin
- return Index (HT.Buckets, Node);
- end Index;
-
- ----------
- -- Next --
- ----------
-
- function Next
- (HT : Hash_Table_Type'Class;
- Node : Count_Type) return Count_Type
- is
- Result : Count_Type := Next (HT.Nodes (Node));
-
- begin
- if Result /= 0 then -- another node in same bucket
- return Result;
- end if;
-
- -- This was the last node in the bucket, so move to the next
- -- bucket, and start searching for next node from there.
-
- for Indx in Index (HT, HT.Nodes (Node)) + 1 .. HT.Buckets'Last loop
- Result := HT.Buckets (Indx);
-
- if Result /= 0 then -- bucket is not empty
- return Result;
- end if;
- end loop;
-
- return 0;
- end Next;
-
-end Ada.Containers.Hash_Tables.Generic_Bounded_Operations;