111
|
1 ------------------------------------------------------------------------------
|
|
2 -- --
|
|
3 -- GNAT LIBRARY COMPONENTS --
|
|
4 -- --
|
|
5 -- ADA.CONTAINERS.HASH_TABLES.GENERIC_BOUNDED_OPERATIONS --
|
|
6 -- --
|
|
7 -- B o d y --
|
|
8 -- --
|
131
|
9 -- Copyright (C) 2004-2018, Free Software Foundation, Inc. --
|
111
|
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 -- 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. --
|
|
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;
|