1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- ADA.CONTAINERS.HASH_TABLES.GENERIC_BOUNDED_OPERATIONS --
9 -- Copyright (C) 2004-2014, 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 function Checked_Index
39 (Hash_Table : aliased in out Hash_Table_Type'Class;
40 Node : Count_Type) return Hash_Type
44 B : Natural renames Hash_Table.Busy;
45 L : Natural renames Hash_Table.Lock;
51 Result := Index (Hash_Table, Hash_Table.Nodes (Node));
70 procedure Clear (HT : in out Hash_Table_Type'Class) is
73 raise Program_Error with
74 "attempt to tamper with cursors (container is busy)";
81 HT.Buckets := (others => 0); -- optimize this somehow ???
84 --------------------------
85 -- Delete_Node_At_Index --
86 --------------------------
88 procedure Delete_Node_At_Index
89 (HT : in out Hash_Table_Type'Class;
97 Prev := HT.Buckets (Indx);
100 raise Program_Error with
101 "attempt to delete node from empty hash bucket";
105 HT.Buckets (Indx) := Next (HT.Nodes (Prev));
106 HT.Length := HT.Length - 1;
110 if HT.Length = 1 then
111 raise Program_Error with
112 "attempt to delete node not in its proper hash bucket";
116 Curr := Next (HT.Nodes (Prev));
119 raise Program_Error with
120 "attempt to delete node not in its proper hash bucket";
125 end Delete_Node_At_Index;
127 ---------------------------
128 -- Delete_Node_Sans_Free --
129 ---------------------------
131 procedure Delete_Node_Sans_Free
132 (HT : in out Hash_Table_Type'Class;
135 pragma Assert (X /= 0);
142 if HT.Length = 0 then
143 raise Program_Error with
144 "attempt to delete node from empty hashed container";
147 Indx := Checked_Index (HT, X);
148 Prev := HT.Buckets (Indx);
151 raise Program_Error with
152 "attempt to delete node from empty hash bucket";
156 HT.Buckets (Indx) := Next (HT.Nodes (Prev));
157 HT.Length := HT.Length - 1;
161 if HT.Length = 1 then
162 raise Program_Error with
163 "attempt to delete node not in its proper hash bucket";
167 Curr := Next (HT.Nodes (Prev));
170 raise Program_Error with
171 "attempt to delete node not in its proper hash bucket";
175 Set_Next (HT.Nodes (Prev), Next => Next (HT.Nodes (Curr)));
176 HT.Length := HT.Length - 1;
182 end Delete_Node_Sans_Free;
188 function First (HT : Hash_Table_Type'Class) return Count_Type is
192 if HT.Length = 0 then
196 Indx := HT.Buckets'First;
198 if HT.Buckets (Indx) /= 0 then
199 return HT.Buckets (Indx);
211 (HT : in out Hash_Table_Type'Class;
214 N : Nodes_Type renames HT.Nodes;
217 -- This subprogram "deallocates" a node by relinking the node off of the
218 -- active list and onto the free list. Previously it would flag index
219 -- value 0 as an error. The precondition was weakened, so that index
220 -- value 0 is now allowed, and this value is interpreted to mean "do
221 -- nothing". This makes its behavior analogous to the behavior of
222 -- Ada.Unchecked_Deallocation, and allows callers to avoid having to add
223 -- special-case checks at the point of call.
229 pragma Assert (X <= HT.Capacity);
231 -- pragma Assert (N (X).Prev >= 0); -- node is active
232 -- Find a way to mark a node as active vs. inactive; we could
233 -- use a special value in Color_Type for this. ???
235 -- The hash table actually contains two data structures: a list for
236 -- the "active" nodes that contain elements that have been inserted
237 -- onto the container, and another for the "inactive" nodes of the free
240 -- We desire that merely declaring an object should have only minimal
241 -- cost; specially, we want to avoid having to initialize the free
242 -- store (to fill in the links), especially if the capacity is large.
244 -- The head of the free list is indicated by Container.Free. If its
245 -- value is non-negative, then the free store has been initialized
246 -- in the "normal" way: Container.Free points to the head of the list
247 -- of free (inactive) nodes, and the value 0 means the free list is
248 -- empty. Each node on the free list has been initialized to point
249 -- to the next free node (via its Parent component), and the value 0
250 -- means that this is the last free node.
252 -- If Container.Free is negative, then the links on the free store
253 -- have not been initialized. In this case the link values are
254 -- implied: the free store comprises the components of the node array
255 -- started with the absolute value of Container.Free, and continuing
256 -- until the end of the array (Nodes'Last).
259 -- It might be possible to perform an optimization here. Suppose that
260 -- the free store can be represented as having two parts: one
261 -- comprising the non-contiguous inactive nodes linked together
262 -- in the normal way, and the other comprising the contiguous
263 -- inactive nodes (that are not linked together, at the end of the
264 -- nodes array). This would allow us to never have to initialize
265 -- the free store, except in a lazy way as nodes become inactive.
267 -- When an element is deleted from the list container, its node
268 -- becomes inactive, and so we set its Next component to value of
269 -- the node's index (in the nodes array), to indicate that it is
270 -- now inactive. This provides a useful way to detect a dangling
271 -- cursor reference. ???
273 Set_Next (N (X), Next => X); -- Node is deallocated (not on active list)
276 -- The free store has previously been initialized. All we need to
277 -- do here is link the newly-free'd node onto the free list.
279 Set_Next (N (X), HT.Free);
282 elsif X + 1 = abs HT.Free then
283 -- The free store has not been initialized, and the node becoming
284 -- inactive immediately precedes the start of the free store. All
285 -- we need to do is move the start of the free store back by one.
287 HT.Free := HT.Free + 1;
290 -- The free store has not been initialized, and the node becoming
291 -- inactive does not immediately precede the free store. Here we
292 -- first initialize the free store (meaning the links are given
293 -- values in the traditional way), and then link the newly-free'd
294 -- node onto the head of the free store.
297 -- See the comments above for an optimization opportunity. If
298 -- the next link for a node on the free store is negative, then
299 -- this means the remaining nodes on the free store are
300 -- physically contiguous, starting as the absolute value of
303 HT.Free := abs HT.Free;
305 if HT.Free > HT.Capacity then
309 for I in HT.Free .. HT.Capacity - 1 loop
310 Set_Next (Node => N (I), Next => I + 1);
313 Set_Next (Node => N (HT.Capacity), Next => 0);
316 Set_Next (Node => N (X), Next => HT.Free);
321 ----------------------
322 -- Generic_Allocate --
323 ----------------------
325 procedure Generic_Allocate
326 (HT : in out Hash_Table_Type'Class;
327 Node : out Count_Type)
329 N : Nodes_Type renames HT.Nodes;
335 -- We always perform the assignment first, before we
336 -- change container state, in order to defend against
337 -- exceptions duration assignment.
339 Set_Element (N (Node));
340 HT.Free := Next (N (Node));
343 -- A negative free store value means that the links of the nodes
344 -- in the free store have not been initialized. In this case, the
345 -- nodes are physically contiguous in the array, starting at the
346 -- index that is the absolute value of the Container.Free, and
347 -- continuing until the end of the array (Nodes'Last).
351 -- As above, we perform this assignment first, before modifying
352 -- any container state.
354 Set_Element (N (Node));
355 HT.Free := HT.Free - 1;
357 end Generic_Allocate;
363 function Generic_Equal
364 (L, R : Hash_Table_Type'Class) return Boolean
366 BL : Natural renames L'Unrestricted_Access.Busy;
367 LL : Natural renames L'Unrestricted_Access.Lock;
369 BR : Natural renames R'Unrestricted_Access.Busy;
370 LR : Natural renames R'Unrestricted_Access.Lock;
380 if L'Address = R'Address then
384 if L.Length /= R.Length then
392 -- Find the first node of hash table L
394 L_Index := L.Buckets'First;
396 L_Node := L.Buckets (L_Index);
397 exit when L_Node /= 0;
398 L_Index := L_Index + 1;
401 -- Per AI05-0022, the container implementation is required to detect
402 -- element tampering by a generic actual subprogram.
410 -- For each node of hash table L, search for an equivalent node in hash
415 if not Find (HT => R, Key => L.Nodes (L_Node)) then
422 L_Node := Next (L.Nodes (L_Node));
426 -- We have exhausted the nodes in this bucket
433 -- Find the next bucket
436 L_Index := L_Index + 1;
437 L_Node := L.Buckets (L_Index);
438 exit when L_Node /= 0;
462 -----------------------
463 -- Generic_Iteration --
464 -----------------------
466 procedure Generic_Iteration (HT : Hash_Table_Type'Class) is
470 if HT.Length = 0 then
474 for Indx in HT.Buckets'Range loop
475 Node := HT.Buckets (Indx);
478 Node := Next (HT.Nodes (Node));
481 end Generic_Iteration;
487 procedure Generic_Read
488 (Stream : not null access Root_Stream_Type'Class;
489 HT : out Hash_Table_Type'Class)
496 Count_Type'Base'Read (Stream, N);
499 raise Program_Error with "stream appears to be corrupt";
506 if N > HT.Capacity then
507 raise Capacity_Error with "too many elements in stream";
512 Node : constant Count_Type := New_Node (Stream);
513 Indx : constant Hash_Type := Checked_Index (HT, Node);
514 B : Count_Type renames HT.Buckets (Indx);
516 Set_Next (HT.Nodes (Node), Next => B);
520 HT.Length := HT.Length + 1;
528 procedure Generic_Write
529 (Stream : not null access Root_Stream_Type'Class;
530 HT : Hash_Table_Type'Class)
532 procedure Write (Node : Count_Type);
533 pragma Inline (Write);
535 procedure Write is new Generic_Iteration (Write);
541 procedure Write (Node : Count_Type) is
543 Write (Stream, HT.Nodes (Node));
547 Count_Type'Base'Write (Stream, HT.Length);
556 (Buckets : Buckets_Type;
557 Node : Node_Type) return Hash_Type is
559 return Buckets'First + Hash_Node (Node) mod Buckets'Length;
563 (HT : Hash_Table_Type'Class;
564 Node : Node_Type) return Hash_Type is
566 return Index (HT.Buckets, Node);
574 (HT : Hash_Table_Type'Class;
575 Node : Count_Type) return Count_Type
581 Result := Next (HT.Nodes (Node));
583 if Result /= 0 then -- another node in same bucket
587 -- This was the last node in the bucket, so move to the next
588 -- bucket, and start searching for next node from there.
590 First := Checked_Index (HT'Unrestricted_Access.all, Node) + 1;
591 for Indx in First .. HT.Buckets'Last loop
592 Result := HT.Buckets (Indx);
594 if Result /= 0 then -- bucket is not empty
602 end Ada.Containers.Hash_Tables.Generic_Bounded_Operations;