1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- ADA.CONTAINERS.HASH_TABLES.GENERIC_BOUNDED_OPERATIONS --
9 -- Copyright (C) 2004-2010, 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
, 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
, 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
, 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
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
, 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
;