File : a-chtgbo.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT LIBRARY COMPONENTS --
4 -- --
5 -- ADA.CONTAINERS.HASH_TABLES.GENERIC_BOUNDED_OPERATIONS --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2004-2016, Free Software Foundation, Inc. --
10 -- --
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. --
17 -- --
18 -- --
19 -- --
20 -- --
21 -- --
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/>. --
26 -- --
27 -- This unit was originally developed by Matthew J Heaney. --
28 ------------------------------------------------------------------------------
29
30 with System; use type System.Address;
31
32 package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is
33
34 pragma Warnings (Off, "variable ""Busy*"" is not referenced");
35 pragma Warnings (Off, "variable ""Lock*"" is not referenced");
36 -- See comment in Ada.Containers.Helpers
37
38 -------------------
39 -- Checked_Index --
40 -------------------
41
42 function Checked_Index
43 (Hash_Table : aliased in out Hash_Table_Type'Class;
44 Node : Count_Type) return Hash_Type
45 is
46 Lock : With_Lock (Hash_Table.TC'Unrestricted_Access);
47 begin
48 return Index (Hash_Table, Hash_Table.Nodes (Node));
49 end Checked_Index;
50
51 -----------
52 -- Clear --
53 -----------
54
55 procedure Clear (HT : in out Hash_Table_Type'Class) is
56 begin
57 TC_Check (HT.TC);
58
59 HT.Length := 0;
60 -- HT.Busy := 0;
61 -- HT.Lock := 0;
62 HT.Free := -1;
63 HT.Buckets := (others => 0); -- optimize this somehow ???
64 end Clear;
65
66 --------------------------
67 -- Delete_Node_At_Index --
68 --------------------------
69
70 procedure Delete_Node_At_Index
71 (HT : in out Hash_Table_Type'Class;
72 Indx : Hash_Type;
73 X : Count_Type)
74 is
75 Prev : Count_Type;
76 Curr : Count_Type;
77
78 begin
79 Prev := HT.Buckets (Indx);
80
81 if Checks and then Prev = 0 then
82 raise Program_Error with
83 "attempt to delete node from empty hash bucket";
84 end if;
85
86 if Prev = X then
87 HT.Buckets (Indx) := Next (HT.Nodes (Prev));
88 HT.Length := HT.Length - 1;
89 return;
90 end if;
91
92 if Checks and then HT.Length = 1 then
93 raise Program_Error with
94 "attempt to delete node not in its proper hash bucket";
95 end if;
96
97 loop
98 Curr := Next (HT.Nodes (Prev));
99
100 if Checks and then Curr = 0 then
101 raise Program_Error with
102 "attempt to delete node not in its proper hash bucket";
103 end if;
104
105 Prev := Curr;
106 end loop;
107 end Delete_Node_At_Index;
108
109 ---------------------------
110 -- Delete_Node_Sans_Free --
111 ---------------------------
112
113 procedure Delete_Node_Sans_Free
114 (HT : in out Hash_Table_Type'Class;
115 X : Count_Type)
116 is
117 pragma Assert (X /= 0);
118
119 Indx : Hash_Type;
120 Prev : Count_Type;
121 Curr : Count_Type;
122
123 begin
124 if Checks and then HT.Length = 0 then
125 raise Program_Error with
126 "attempt to delete node from empty hashed container";
127 end if;
128
129 Indx := Checked_Index (HT, X);
130 Prev := HT.Buckets (Indx);
131
132 if Checks and then Prev = 0 then
133 raise Program_Error with
134 "attempt to delete node from empty hash bucket";
135 end if;
136
137 if Prev = X then
138 HT.Buckets (Indx) := Next (HT.Nodes (Prev));
139 HT.Length := HT.Length - 1;
140 return;
141 end if;
142
143 if Checks and then HT.Length = 1 then
144 raise Program_Error with
145 "attempt to delete node not in its proper hash bucket";
146 end if;
147
148 loop
149 Curr := Next (HT.Nodes (Prev));
150
151 if Checks and then Curr = 0 then
152 raise Program_Error with
153 "attempt to delete node not in its proper hash bucket";
154 end if;
155
156 if Curr = X then
157 Set_Next (HT.Nodes (Prev), Next => Next (HT.Nodes (Curr)));
158 HT.Length := HT.Length - 1;
159 return;
160 end if;
161
162 Prev := Curr;
163 end loop;
164 end Delete_Node_Sans_Free;
165
166 -----------
167 -- First --
168 -----------
169
170 function First (HT : Hash_Table_Type'Class) return Count_Type is
171 Indx : Hash_Type;
172
173 begin
174 if HT.Length = 0 then
175 return 0;
176 end if;
177
178 Indx := HT.Buckets'First;
179 loop
180 if HT.Buckets (Indx) /= 0 then
181 return HT.Buckets (Indx);
182 end if;
183
184 Indx := Indx + 1;
185 end loop;
186 end First;
187
188 ----------
189 -- Free --
190 ----------
191
192 procedure Free
193 (HT : in out Hash_Table_Type'Class;
194 X : Count_Type)
195 is
196 N : Nodes_Type renames HT.Nodes;
197
198 begin
199 -- This subprogram "deallocates" a node by relinking the node off of the
200 -- active list and onto the free list. Previously it would flag index
201 -- value 0 as an error. The precondition was weakened, so that index
202 -- value 0 is now allowed, and this value is interpreted to mean "do
203 -- nothing". This makes its behavior analogous to the behavior of
204 -- Ada.Unchecked_Deallocation, and allows callers to avoid having to add
205 -- special-case checks at the point of call.
206
207 if X = 0 then
208 return;
209 end if;
210
211 pragma Assert (X <= HT.Capacity);
212
213 -- pragma Assert (N (X).Prev >= 0); -- node is active
214 -- Find a way to mark a node as active vs. inactive; we could
215 -- use a special value in Color_Type for this. ???
216
217 -- The hash table actually contains two data structures: a list for
218 -- the "active" nodes that contain elements that have been inserted
219 -- onto the container, and another for the "inactive" nodes of the free
220 -- store.
221 --
222 -- We desire that merely declaring an object should have only minimal
223 -- cost; specially, we want to avoid having to initialize the free
224 -- store (to fill in the links), especially if the capacity is large.
225 --
226 -- The head of the free list is indicated by Container.Free. If its
227 -- value is non-negative, then the free store has been initialized
228 -- in the "normal" way: Container.Free points to the head of the list
229 -- of free (inactive) nodes, and the value 0 means the free list is
230 -- empty. Each node on the free list has been initialized to point
231 -- to the next free node (via its Parent component), and the value 0
232 -- means that this is the last free node.
233 --
234 -- If Container.Free is negative, then the links on the free store
235 -- have not been initialized. In this case the link values are
236 -- implied: the free store comprises the components of the node array
237 -- started with the absolute value of Container.Free, and continuing
238 -- until the end of the array (Nodes'Last).
239 --
240 -- ???
241 -- It might be possible to perform an optimization here. Suppose that
242 -- the free store can be represented as having two parts: one
243 -- comprising the non-contiguous inactive nodes linked together
244 -- in the normal way, and the other comprising the contiguous
245 -- inactive nodes (that are not linked together, at the end of the
246 -- nodes array). This would allow us to never have to initialize
247 -- the free store, except in a lazy way as nodes become inactive.
248
249 -- When an element is deleted from the list container, its node
250 -- becomes inactive, and so we set its Next component to value of
251 -- the node's index (in the nodes array), to indicate that it is
252 -- now inactive. This provides a useful way to detect a dangling
253 -- cursor reference. ???
254
255 Set_Next (N (X), Next => X); -- Node is deallocated (not on active list)
256
257 if HT.Free >= 0 then
258 -- The free store has previously been initialized. All we need to
259 -- do here is link the newly-free'd node onto the free list.
260
261 Set_Next (N (X), HT.Free);
262 HT.Free := X;
263
264 elsif X + 1 = abs HT.Free then
265 -- The free store has not been initialized, and the node becoming
266 -- inactive immediately precedes the start of the free store. All
267 -- we need to do is move the start of the free store back by one.
268
269 HT.Free := HT.Free + 1;
270
271 else
272 -- The free store has not been initialized, and the node becoming
273 -- inactive does not immediately precede the free store. Here we
274 -- first initialize the free store (meaning the links are given
275 -- values in the traditional way), and then link the newly-free'd
276 -- node onto the head of the free store.
277
278 -- ???
279 -- See the comments above for an optimization opportunity. If
280 -- the next link for a node on the free store is negative, then
281 -- this means the remaining nodes on the free store are
282 -- physically contiguous, starting as the absolute value of
283 -- that index value.
284
285 HT.Free := abs HT.Free;
286
287 if HT.Free > HT.Capacity then
288 HT.Free := 0;
289
290 else
291 for I in HT.Free .. HT.Capacity - 1 loop
292 Set_Next (Node => N (I), Next => I + 1);
293 end loop;
294
295 Set_Next (Node => N (HT.Capacity), Next => 0);
296 end if;
297
298 Set_Next (Node => N (X), Next => HT.Free);
299 HT.Free := X;
300 end if;
301 end Free;
302
303 ----------------------
304 -- Generic_Allocate --
305 ----------------------
306
307 procedure Generic_Allocate
308 (HT : in out Hash_Table_Type'Class;
309 Node : out Count_Type)
310 is
311 N : Nodes_Type renames HT.Nodes;
312
313 begin
314 if HT.Free >= 0 then
315 Node := HT.Free;
316
317 -- We always perform the assignment first, before we
318 -- change container state, in order to defend against
319 -- exceptions duration assignment.
320
321 Set_Element (N (Node));
322 HT.Free := Next (N (Node));
323
324 else
325 -- A negative free store value means that the links of the nodes
326 -- in the free store have not been initialized. In this case, the
327 -- nodes are physically contiguous in the array, starting at the
328 -- index that is the absolute value of the Container.Free, and
329 -- continuing until the end of the array (Nodes'Last).
330
331 Node := abs HT.Free;
332
333 -- As above, we perform this assignment first, before modifying
334 -- any container state.
335
336 Set_Element (N (Node));
337 HT.Free := HT.Free - 1;
338 end if;
339 end Generic_Allocate;
340
341 -------------------
342 -- Generic_Equal --
343 -------------------
344
345 function Generic_Equal
346 (L, R : Hash_Table_Type'Class) return Boolean
347 is
348 -- Per AI05-0022, the container implementation is required to detect
349 -- element tampering by a generic actual subprogram.
350
351 Lock_L : With_Lock (L.TC'Unrestricted_Access);
352 Lock_R : With_Lock (R.TC'Unrestricted_Access);
353
354 L_Index : Hash_Type;
355 L_Node : Count_Type;
356
357 N : Count_Type;
358
359 begin
360 if L'Address = R'Address then
361 return True;
362 end if;
363
364 if L.Length /= R.Length then
365 return False;
366 end if;
367
368 if L.Length = 0 then
369 return True;
370 end if;
371
372 -- Find the first node of hash table L
373
374 L_Index := L.Buckets'First;
375 loop
376 L_Node := L.Buckets (L_Index);
377 exit when L_Node /= 0;
378 L_Index := L_Index + 1;
379 end loop;
380
381 -- For each node of hash table L, search for an equivalent node in hash
382 -- table R.
383
384 N := L.Length;
385 loop
386 if not Find (HT => R, Key => L.Nodes (L_Node)) then
387 return False;
388 end if;
389
390 N := N - 1;
391
392 L_Node := Next (L.Nodes (L_Node));
393
394 if L_Node = 0 then
395
396 -- We have exhausted the nodes in this bucket
397
398 if N = 0 then
399 return True;
400 end if;
401
402 -- Find the next bucket
403
404 loop
405 L_Index := L_Index + 1;
406 L_Node := L.Buckets (L_Index);
407 exit when L_Node /= 0;
408 end loop;
409 end if;
410 end loop;
411 end Generic_Equal;
412
413 -----------------------
414 -- Generic_Iteration --
415 -----------------------
416
417 procedure Generic_Iteration (HT : Hash_Table_Type'Class) is
418 Node : Count_Type;
419
420 begin
421 if HT.Length = 0 then
422 return;
423 end if;
424
425 for Indx in HT.Buckets'Range loop
426 Node := HT.Buckets (Indx);
427 while Node /= 0 loop
428 Process (Node);
429 Node := Next (HT.Nodes (Node));
430 end loop;
431 end loop;
432 end Generic_Iteration;
433
434 ------------------
435 -- Generic_Read --
436 ------------------
437
438 procedure Generic_Read
439 (Stream : not null access Root_Stream_Type'Class;
440 HT : out Hash_Table_Type'Class)
441 is
442 N : Count_Type'Base;
443
444 begin
445 Clear (HT);
446
447 Count_Type'Base'Read (Stream, N);
448
449 if Checks and then N < 0 then
450 raise Program_Error with "stream appears to be corrupt";
451 end if;
452
453 if N = 0 then
454 return;
455 end if;
456
457 if Checks and then N > HT.Capacity then
458 raise Capacity_Error with "too many elements in stream";
459 end if;
460
461 for J in 1 .. N loop
462 declare
463 Node : constant Count_Type := New_Node (Stream);
464 Indx : constant Hash_Type := Checked_Index (HT, Node);
465 B : Count_Type renames HT.Buckets (Indx);
466 begin
467 Set_Next (HT.Nodes (Node), Next => B);
468 B := Node;
469 end;
470
471 HT.Length := HT.Length + 1;
472 end loop;
473 end Generic_Read;
474
475 -------------------
476 -- Generic_Write --
477 -------------------
478
479 procedure Generic_Write
480 (Stream : not null access Root_Stream_Type'Class;
481 HT : Hash_Table_Type'Class)
482 is
483 procedure Write (Node : Count_Type);
484 pragma Inline (Write);
485
486 procedure Write is new Generic_Iteration (Write);
487
488 -----------
489 -- Write --
490 -----------
491
492 procedure Write (Node : Count_Type) is
493 begin
494 Write (Stream, HT.Nodes (Node));
495 end Write;
496
497 begin
498 Count_Type'Base'Write (Stream, HT.Length);
499 Write (HT);
500 end Generic_Write;
501
502 -----------
503 -- Index --
504 -----------
505
506 function Index
507 (Buckets : Buckets_Type;
508 Node : Node_Type) return Hash_Type is
509 begin
510 return Buckets'First + Hash_Node (Node) mod Buckets'Length;
511 end Index;
512
513 function Index
514 (HT : Hash_Table_Type'Class;
515 Node : Node_Type) return Hash_Type is
516 begin
517 return Index (HT.Buckets, Node);
518 end Index;
519
520 ----------
521 -- Next --
522 ----------
523
524 function Next
525 (HT : Hash_Table_Type'Class;
526 Node : Count_Type) return Count_Type
527 is
528 Result : Count_Type;
529 First : Hash_Type;
530
531 begin
532 Result := Next (HT.Nodes (Node));
533
534 if Result /= 0 then -- another node in same bucket
535 return Result;
536 end if;
537
538 -- This was the last node in the bucket, so move to the next
539 -- bucket, and start searching for next node from there.
540
541 First := Checked_Index (HT'Unrestricted_Access.all, Node) + 1;
542 for Indx in First .. HT.Buckets'Last loop
543 Result := HT.Buckets (Indx);
544
545 if Result /= 0 then -- bucket is not empty
546 return Result;
547 end if;
548 end loop;
549
550 return 0;
551 end Next;
552
553 end Ada.Containers.Hash_Tables.Generic_Bounded_Operations;