1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- ADA.CONTAINERS.HASH_TABLES.GENERIC_BOUNDED_OPERATIONS --
9 -- Copyright (C) 2004-2011, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
27 -- This unit was originally developed by Matthew J Heaney. --
28 ------------------------------------------------------------------------------
30 with System; use type System.Address;
32 package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is
38 procedure Clear (HT : in out Hash_Table_Type'Class) is
41 raise Program_Error with
42 "attempt to tamper with cursors (container is busy)";
49 HT.Buckets := (others => 0); -- optimize this somehow ???
52 ---------------------------
53 -- Delete_Node_Sans_Free --
54 ---------------------------
56 procedure Delete_Node_Sans_Free
57 (HT : in out Hash_Table_Type'Class;
60 pragma Assert (X /= 0);
68 raise Program_Error with
69 "attempt to delete node from empty hashed container";
72 Indx := Index (HT, HT.Nodes (X));
73 Prev := HT.Buckets (Indx);
76 raise Program_Error with
77 "attempt to delete node from empty hash bucket";
81 HT.Buckets (Indx) := Next (HT.Nodes (Prev));
82 HT.Length := HT.Length - 1;
87 raise Program_Error with
88 "attempt to delete node not in its proper hash bucket";
92 Curr := Next (HT.Nodes (Prev));
95 raise Program_Error with
96 "attempt to delete node not in its proper hash bucket";
100 Set_Next (HT.Nodes (Prev), Next => Next (HT.Nodes (Curr)));
101 HT.Length := HT.Length - 1;
107 end Delete_Node_Sans_Free;
113 function First (HT : Hash_Table_Type'Class) return Count_Type is
117 if HT.Length = 0 then
121 Indx := HT.Buckets'First;
123 if HT.Buckets (Indx) /= 0 then
124 return HT.Buckets (Indx);
136 (HT : in out Hash_Table_Type'Class;
139 pragma Assert (X > 0);
140 pragma Assert (X <= HT.Capacity);
142 N : Nodes_Type renames HT.Nodes;
143 -- pragma Assert (N (X).Prev >= 0); -- node is active
144 -- Find a way to mark a node as active vs. inactive; we could
145 -- use a special value in Color_Type for this. ???
148 -- The hash table actually contains two data structures: a list for
149 -- the "active" nodes that contain elements that have been inserted
150 -- onto the container, and another for the "inactive" nodes of the free
153 -- We desire that merely declaring an object should have only minimal
154 -- cost; specially, we want to avoid having to initialize the free
155 -- store (to fill in the links), especially if the capacity is large.
157 -- The head of the free list is indicated by Container.Free. If its
158 -- value is non-negative, then the free store has been initialized
159 -- in the "normal" way: Container.Free points to the head of the list
160 -- of free (inactive) nodes, and the value 0 means the free list is
161 -- empty. Each node on the free list has been initialized to point
162 -- to the next free node (via its Parent component), and the value 0
163 -- means that this is the last free node.
165 -- If Container.Free is negative, then the links on the free store
166 -- have not been initialized. In this case the link values are
167 -- implied: the free store comprises the components of the node array
168 -- started with the absolute value of Container.Free, and continuing
169 -- until the end of the array (Nodes'Last).
172 -- It might be possible to perform an optimization here. Suppose that
173 -- the free store can be represented as having two parts: one
174 -- comprising the non-contiguous inactive nodes linked together
175 -- in the normal way, and the other comprising the contiguous
176 -- inactive nodes (that are not linked together, at the end of the
177 -- nodes array). This would allow us to never have to initialize
178 -- the free store, except in a lazy way as nodes become inactive.
180 -- When an element is deleted from the list container, its node
181 -- becomes inactive, and so we set its Next component to value of
182 -- the node's index (in the nodes array), to indicate that it is
183 -- now inactive. This provides a useful way to detect a dangling
184 -- cursor reference. ???
186 Set_Next (N (X), Next => X); -- Node is deallocated (not on active list)
189 -- The free store has previously been initialized. All we need to
190 -- do here is link the newly-free'd node onto the free list.
192 Set_Next (N (X), HT.Free);
195 elsif X + 1 = abs HT.Free then
196 -- The free store has not been initialized, and the node becoming
197 -- inactive immediately precedes the start of the free store. All
198 -- we need to do is move the start of the free store back by one.
200 HT.Free := HT.Free + 1;
203 -- The free store has not been initialized, and the node becoming
204 -- inactive does not immediately precede the free store. Here we
205 -- first initialize the free store (meaning the links are given
206 -- values in the traditional way), and then link the newly-free'd
207 -- node onto the head of the free store.
210 -- See the comments above for an optimization opportunity. If
211 -- the next link for a node on the free store is negative, then
212 -- this means the remaining nodes on the free store are
213 -- physically contiguous, starting as the absolute value of
216 HT.Free := abs HT.Free;
218 if HT.Free > HT.Capacity then
222 for I in HT.Free .. HT.Capacity - 1 loop
223 Set_Next (Node => N (I), Next => I + 1);
226 Set_Next (Node => N (HT.Capacity), Next => 0);
229 Set_Next (Node => N (X), Next => HT.Free);
234 ----------------------
235 -- Generic_Allocate --
236 ----------------------
238 procedure Generic_Allocate
239 (HT : in out Hash_Table_Type'Class;
240 Node : out Count_Type)
242 N : Nodes_Type renames HT.Nodes;
248 -- We always perform the assignment first, before we
249 -- change container state, in order to defend against
250 -- exceptions duration assignment.
252 Set_Element (N (Node));
253 HT.Free := Next (N (Node));
256 -- A negative free store value means that the links of the nodes
257 -- in the free store have not been initialized. In this case, the
258 -- nodes are physically contiguous in the array, starting at the
259 -- index that is the absolute value of the Container.Free, and
260 -- continuing until the end of the array (Nodes'Last).
264 -- As above, we perform this assignment first, before modifying
265 -- any container state.
267 Set_Element (N (Node));
268 HT.Free := HT.Free - 1;
270 end Generic_Allocate;
276 function Generic_Equal
277 (L, R : Hash_Table_Type'Class) return Boolean
285 if L'Address = R'Address then
289 if L.Length /= R.Length then
297 -- Find the first node of hash table L
299 L_Index := L.Buckets'First;
301 L_Node := L.Buckets (L_Index);
302 exit when L_Node /= 0;
303 L_Index := L_Index + 1;
306 -- For each node of hash table L, search for an equivalent node in hash
311 if not Find (HT => R, Key => L.Nodes (L_Node)) then
317 L_Node := Next (L.Nodes (L_Node));
320 -- We have exhausted the nodes in this bucket
326 -- Find the next bucket
329 L_Index := L_Index + 1;
330 L_Node := L.Buckets (L_Index);
331 exit when L_Node /= 0;
337 -----------------------
338 -- Generic_Iteration --
339 -----------------------
341 procedure Generic_Iteration (HT : Hash_Table_Type'Class) is
345 if HT.Length = 0 then
349 for Indx in HT.Buckets'Range loop
350 Node := HT.Buckets (Indx);
353 Node := Next (HT, Node);
356 end Generic_Iteration;
362 procedure Generic_Read
363 (Stream : not null access Root_Stream_Type'Class;
364 HT : out Hash_Table_Type'Class)
371 Count_Type'Base'Read (Stream, N);
374 raise Program_Error with "stream appears to be corrupt";
381 if N > HT.Capacity then
382 raise Capacity_Error with "too many elements in stream";
387 Node : constant Count_Type := New_Node (Stream);
388 Indx : constant Hash_Type := Index (HT, HT.Nodes (Node));
389 B : Count_Type renames HT.Buckets (Indx);
391 Set_Next (HT.Nodes (Node), Next => B);
395 HT.Length := HT.Length + 1;
403 procedure Generic_Write
404 (Stream : not null access Root_Stream_Type'Class;
405 HT : Hash_Table_Type'Class)
407 procedure Write (Node : Count_Type);
408 pragma Inline (Write);
410 procedure Write is new Generic_Iteration (Write);
416 procedure Write (Node : Count_Type) is
418 Write (Stream, HT.Nodes (Node));
422 Count_Type'Base'Write (Stream, HT.Length);
431 (Buckets : Buckets_Type;
432 Node : Node_Type) return Hash_Type is
434 return Buckets'First + Hash_Node (Node) mod Buckets'Length;
438 (HT : Hash_Table_Type'Class;
439 Node : Node_Type) return Hash_Type is
441 return Index (HT.Buckets, Node);
449 (HT : Hash_Table_Type'Class;
450 Node : Count_Type) return Count_Type
452 Result : Count_Type := Next (HT.Nodes (Node));
455 if Result /= 0 then -- another node in same bucket
459 -- This was the last node in the bucket, so move to the next
460 -- bucket, and start searching for next node from there.
462 for Indx in Index (HT, HT.Nodes (Node)) + 1 .. HT.Buckets'Last loop
463 Result := HT.Buckets (Indx);
465 if Result /= 0 then -- bucket is not empty
473 end Ada.Containers.Hash_Tables.Generic_Bounded_Operations;