| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT LIBRARY COMPONENTS -- |
| -- -- |
| -- ADA.CONTAINERS.HASH_TABLES.GENERIC_BOUNDED_OPERATIONS -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 2004-2014, 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 |
| |
| ------------------- |
| -- Checked_Index -- |
| ------------------- |
| |
| function Checked_Index |
| (Hash_Table : aliased in out Hash_Table_Type'Class; |
| Node : Count_Type) return Hash_Type |
| is |
| Result : Hash_Type; |
| |
| B : Natural renames Hash_Table.Busy; |
| L : Natural renames Hash_Table.Lock; |
| |
| begin |
| B := B + 1; |
| L := L + 1; |
| |
| Result := Index (Hash_Table, Hash_Table.Nodes (Node)); |
| |
| B := B - 1; |
| L := L - 1; |
| |
| return Result; |
| |
| exception |
| when others => |
| B := B - 1; |
| L := L - 1; |
| |
| raise; |
| end Checked_Index; |
| |
| ----------- |
| -- 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_At_Index -- |
| -------------------------- |
| |
| procedure Delete_Node_At_Index |
| (HT : in out Hash_Table_Type'Class; |
| Indx : Hash_Type; |
| X : Count_Type) |
| is |
| Prev : Count_Type; |
| Curr : Count_Type; |
| |
| begin |
| 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; |
| |
| Prev := Curr; |
| end loop; |
| end Delete_Node_At_Index; |
| |
| --------------------------- |
| -- 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 := Checked_Index (HT, 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 |
| BL : Natural renames L'Unrestricted_Access.Busy; |
| LL : Natural renames L'Unrestricted_Access.Lock; |
| |
| BR : Natural renames R'Unrestricted_Access.Busy; |
| LR : Natural renames R'Unrestricted_Access.Lock; |
| |
| Result : Boolean; |
| |
| 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; |
| |
| -- Per AI05-0022, the container implementation is required to detect |
| -- element tampering by a generic actual subprogram. |
| |
| BL := BL + 1; |
| LL := LL + 1; |
| |
| BR := BR + 1; |
| LR := LR + 1; |
| |
| -- 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 |
| Result := False; |
| exit; |
| 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 |
| Result := True; |
| exit; |
| 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; |
| |
| BL := BL - 1; |
| LL := LL - 1; |
| |
| BR := BR - 1; |
| LR := LR - 1; |
| |
| return Result; |
| |
| exception |
| when others => |
| BL := BL - 1; |
| LL := LL - 1; |
| |
| BR := BR - 1; |
| LR := LR - 1; |
| |
| raise; |
| 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 := Checked_Index (HT, 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; |
| First : Hash_Type; |
| |
| begin |
| Result := Next (HT.Nodes (Node)); |
| |
| 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. |
| |
| First := Checked_Index (HT'Unrestricted_Access.all, Node) + 1; |
| for Indx in First .. 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; |
