1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- ADA.CONTAINERS.HASH_TABLES.GENERIC_BOUNDED_OPERATIONS --
9 -- Copyright (C) 2004-2013, 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_Sans_Free --
86 ---------------------------
88 procedure Delete_Node_Sans_Free
89 (HT
: in out Hash_Table_Type
'Class;
92 pragma Assert
(X
/= 0);
100 raise Program_Error
with
101 "attempt to delete node from empty hashed container";
104 Indx
:= Checked_Index
(HT
, X
);
105 Prev
:= HT
.Buckets
(Indx
);
108 raise Program_Error
with
109 "attempt to delete node from empty hash bucket";
113 HT
.Buckets
(Indx
) := Next
(HT
.Nodes
(Prev
));
114 HT
.Length
:= HT
.Length
- 1;
118 if HT
.Length
= 1 then
119 raise Program_Error
with
120 "attempt to delete node not in its proper hash bucket";
124 Curr
:= Next
(HT
.Nodes
(Prev
));
127 raise Program_Error
with
128 "attempt to delete node not in its proper hash bucket";
132 Set_Next
(HT
.Nodes
(Prev
), Next
=> Next
(HT
.Nodes
(Curr
)));
133 HT
.Length
:= HT
.Length
- 1;
139 end Delete_Node_Sans_Free
;
145 function First
(HT
: Hash_Table_Type
'Class) return Count_Type
is
149 if HT
.Length
= 0 then
153 Indx
:= HT
.Buckets
'First;
155 if HT
.Buckets
(Indx
) /= 0 then
156 return HT
.Buckets
(Indx
);
168 (HT
: in out Hash_Table_Type
'Class;
171 N
: Nodes_Type
renames HT
.Nodes
;
174 -- This subprogram "deallocates" a node by relinking the node off of the
175 -- active list and onto the free list. Previously it would flag index
176 -- value 0 as an error. The precondition was weakened, so that index
177 -- value 0 is now allowed, and this value is interpreted to mean "do
178 -- nothing". This makes its behavior analogous to the behavior of
179 -- Ada.Unchecked_Deallocation, and allows callers to avoid having to add
180 -- special-case checks at the point of call.
186 pragma Assert
(X
<= HT
.Capacity
);
188 -- pragma Assert (N (X).Prev >= 0); -- node is active
189 -- Find a way to mark a node as active vs. inactive; we could
190 -- use a special value in Color_Type for this. ???
192 -- The hash table actually contains two data structures: a list for
193 -- the "active" nodes that contain elements that have been inserted
194 -- onto the container, and another for the "inactive" nodes of the free
197 -- We desire that merely declaring an object should have only minimal
198 -- cost; specially, we want to avoid having to initialize the free
199 -- store (to fill in the links), especially if the capacity is large.
201 -- The head of the free list is indicated by Container.Free. If its
202 -- value is non-negative, then the free store has been initialized
203 -- in the "normal" way: Container.Free points to the head of the list
204 -- of free (inactive) nodes, and the value 0 means the free list is
205 -- empty. Each node on the free list has been initialized to point
206 -- to the next free node (via its Parent component), and the value 0
207 -- means that this is the last free node.
209 -- If Container.Free is negative, then the links on the free store
210 -- have not been initialized. In this case the link values are
211 -- implied: the free store comprises the components of the node array
212 -- started with the absolute value of Container.Free, and continuing
213 -- until the end of the array (Nodes'Last).
216 -- It might be possible to perform an optimization here. Suppose that
217 -- the free store can be represented as having two parts: one
218 -- comprising the non-contiguous inactive nodes linked together
219 -- in the normal way, and the other comprising the contiguous
220 -- inactive nodes (that are not linked together, at the end of the
221 -- nodes array). This would allow us to never have to initialize
222 -- the free store, except in a lazy way as nodes become inactive.
224 -- When an element is deleted from the list container, its node
225 -- becomes inactive, and so we set its Next component to value of
226 -- the node's index (in the nodes array), to indicate that it is
227 -- now inactive. This provides a useful way to detect a dangling
228 -- cursor reference. ???
230 Set_Next
(N
(X
), Next
=> X
); -- Node is deallocated (not on active list)
233 -- The free store has previously been initialized. All we need to
234 -- do here is link the newly-free'd node onto the free list.
236 Set_Next
(N
(X
), HT
.Free
);
239 elsif X
+ 1 = abs HT
.Free
then
240 -- The free store has not been initialized, and the node becoming
241 -- inactive immediately precedes the start of the free store. All
242 -- we need to do is move the start of the free store back by one.
244 HT
.Free
:= HT
.Free
+ 1;
247 -- The free store has not been initialized, and the node becoming
248 -- inactive does not immediately precede the free store. Here we
249 -- first initialize the free store (meaning the links are given
250 -- values in the traditional way), and then link the newly-free'd
251 -- node onto the head of the free store.
254 -- See the comments above for an optimization opportunity. If
255 -- the next link for a node on the free store is negative, then
256 -- this means the remaining nodes on the free store are
257 -- physically contiguous, starting as the absolute value of
260 HT
.Free
:= abs HT
.Free
;
262 if HT
.Free
> HT
.Capacity
then
266 for I
in HT
.Free
.. HT
.Capacity
- 1 loop
267 Set_Next
(Node
=> N
(I
), Next
=> I
+ 1);
270 Set_Next
(Node
=> N
(HT
.Capacity
), Next
=> 0);
273 Set_Next
(Node
=> N
(X
), Next
=> HT
.Free
);
278 ----------------------
279 -- Generic_Allocate --
280 ----------------------
282 procedure Generic_Allocate
283 (HT
: in out Hash_Table_Type
'Class;
284 Node
: out Count_Type
)
286 N
: Nodes_Type
renames HT
.Nodes
;
292 -- We always perform the assignment first, before we
293 -- change container state, in order to defend against
294 -- exceptions duration assignment.
296 Set_Element
(N
(Node
));
297 HT
.Free
:= Next
(N
(Node
));
300 -- A negative free store value means that the links of the nodes
301 -- in the free store have not been initialized. In this case, the
302 -- nodes are physically contiguous in the array, starting at the
303 -- index that is the absolute value of the Container.Free, and
304 -- continuing until the end of the array (Nodes'Last).
308 -- As above, we perform this assignment first, before modifying
309 -- any container state.
311 Set_Element
(N
(Node
));
312 HT
.Free
:= HT
.Free
- 1;
314 end Generic_Allocate
;
320 function Generic_Equal
321 (L
, R
: Hash_Table_Type
'Class) return Boolean
323 BL
: Natural renames L
'Unrestricted_Access.Busy
;
324 LL
: Natural renames L
'Unrestricted_Access.Lock
;
326 BR
: Natural renames R
'Unrestricted_Access.Busy
;
327 LR
: Natural renames R
'Unrestricted_Access.Lock
;
337 if L
'Address = R
'Address then
341 if L
.Length
/= R
.Length
then
349 -- Find the first node of hash table L
351 L_Index
:= L
.Buckets
'First;
353 L_Node
:= L
.Buckets
(L_Index
);
354 exit when L_Node
/= 0;
355 L_Index
:= L_Index
+ 1;
358 -- Per AI05-0022, the container implementation is required to detect
359 -- element tampering by a generic actual subprogram.
367 -- For each node of hash table L, search for an equivalent node in hash
372 if not Find
(HT
=> R
, Key
=> L
.Nodes
(L_Node
)) then
379 L_Node
:= Next
(L
.Nodes
(L_Node
));
383 -- We have exhausted the nodes in this bucket
390 -- Find the next bucket
393 L_Index
:= L_Index
+ 1;
394 L_Node
:= L
.Buckets
(L_Index
);
395 exit when L_Node
/= 0;
419 -----------------------
420 -- Generic_Iteration --
421 -----------------------
423 procedure Generic_Iteration
(HT
: Hash_Table_Type
'Class) is
427 if HT
.Length
= 0 then
431 for Indx
in HT
.Buckets
'Range loop
432 Node
:= HT
.Buckets
(Indx
);
435 Node
:= Next
(HT
.Nodes
(Node
));
438 end Generic_Iteration
;
444 procedure Generic_Read
445 (Stream
: not null access Root_Stream_Type
'Class;
446 HT
: out Hash_Table_Type
'Class)
453 Count_Type
'Base'Read (Stream, N);
456 raise Program_Error with "stream appears to be corrupt";
463 if N > HT.Capacity then
464 raise Capacity_Error with "too many elements in stream";
469 Node : constant Count_Type := New_Node (Stream);
470 Indx : constant Hash_Type := Checked_Index (HT, Node);
471 B : Count_Type renames HT.Buckets (Indx);
473 Set_Next (HT.Nodes (Node), Next => B);
477 HT.Length := HT.Length + 1;
485 procedure Generic_Write
486 (Stream : not null access Root_Stream_Type'Class;
487 HT : Hash_Table_Type'Class)
489 procedure Write (Node : Count_Type);
490 pragma Inline (Write);
492 procedure Write is new Generic_Iteration (Write);
498 procedure Write (Node : Count_Type) is
500 Write (Stream, HT.Nodes (Node));
504 Count_Type'Base'Write
(Stream
, HT
.Length
);
513 (Buckets
: Buckets_Type
;
514 Node
: Node_Type
) return Hash_Type
is
516 return Buckets
'First + Hash_Node
(Node
) mod Buckets
'Length;
520 (HT
: Hash_Table_Type
'Class;
521 Node
: Node_Type
) return Hash_Type
is
523 return Index
(HT
.Buckets
, Node
);
531 (HT
: Hash_Table_Type
'Class;
532 Node
: Count_Type
) return Count_Type
538 Result
:= Next
(HT
.Nodes
(Node
));
540 if Result
/= 0 then -- another node in same bucket
544 -- This was the last node in the bucket, so move to the next
545 -- bucket, and start searching for next node from there.
547 First
:= Checked_Index
(HT
'Unrestricted_Access.all, Node
) + 1;
548 for Indx
in First
.. HT
.Buckets
'Last loop
549 Result
:= HT
.Buckets
(Indx
);
551 if Result
/= 0 then -- bucket is not empty
559 end Ada
.Containers
.Hash_Tables
.Generic_Bounded_Operations
;