File : a-crbtgk.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT LIBRARY COMPONENTS --
4 -- --
5 -- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_KEYS --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2004-2015, 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 package body Ada.Containers.Red_Black_Trees.Generic_Keys is
31
32 pragma Warnings (Off, "variable ""Busy*"" is not referenced");
33 pragma Warnings (Off, "variable ""Lock*"" is not referenced");
34 -- See comment in Ada.Containers.Helpers
35
36 package Ops renames Tree_Operations;
37
38 -------------
39 -- Ceiling --
40 -------------
41
42 -- AKA Lower_Bound
43
44 function Ceiling (Tree : Tree_Type; Key : Key_Type) return Node_Access is
45 -- Per AI05-0022, the container implementation is required to detect
46 -- element tampering by a generic actual subprogram.
47
48 Lock : With_Lock (Tree.TC'Unrestricted_Access);
49
50 Y : Node_Access;
51 X : Node_Access;
52
53 begin
54 -- If the container is empty, return a result immediately, so that we do
55 -- not manipulate the tamper bits unnecessarily.
56
57 if Tree.Root = null then
58 return null;
59 end if;
60
61 X := Tree.Root;
62 while X /= null loop
63 if Is_Greater_Key_Node (Key, X) then
64 X := Ops.Right (X);
65 else
66 Y := X;
67 X := Ops.Left (X);
68 end if;
69 end loop;
70
71 return Y;
72 end Ceiling;
73
74 ----------
75 -- Find --
76 ----------
77
78 function Find (Tree : Tree_Type; Key : Key_Type) return Node_Access is
79 -- Per AI05-0022, the container implementation is required to detect
80 -- element tampering by a generic actual subprogram.
81
82 Lock : With_Lock (Tree.TC'Unrestricted_Access);
83
84 Y : Node_Access;
85 X : Node_Access;
86
87 begin
88 -- If the container is empty, return a result immediately, so that we do
89 -- not manipulate the tamper bits unnecessarily.
90
91 if Tree.Root = null then
92 return null;
93 end if;
94
95 X := Tree.Root;
96 while X /= null loop
97 if Is_Greater_Key_Node (Key, X) then
98 X := Ops.Right (X);
99 else
100 Y := X;
101 X := Ops.Left (X);
102 end if;
103 end loop;
104
105 if Y = null or else Is_Less_Key_Node (Key, Y) then
106 return null;
107 else
108 return Y;
109 end if;
110 end Find;
111
112 -----------
113 -- Floor --
114 -----------
115
116 function Floor (Tree : Tree_Type; Key : Key_Type) return Node_Access is
117 -- Per AI05-0022, the container implementation is required to detect
118 -- element tampering by a generic actual subprogram.
119
120 Lock : With_Lock (Tree.TC'Unrestricted_Access);
121
122 Y : Node_Access;
123 X : Node_Access;
124
125 begin
126 -- If the container is empty, return a result immediately, so that we do
127 -- not manipulate the tamper bits unnecessarily.
128
129 if Tree.Root = null then
130 return null;
131 end if;
132
133 X := Tree.Root;
134 while X /= null loop
135 if Is_Less_Key_Node (Key, X) then
136 X := Ops.Left (X);
137 else
138 Y := X;
139 X := Ops.Right (X);
140 end if;
141 end loop;
142
143 return Y;
144 end Floor;
145
146 --------------------------------
147 -- Generic_Conditional_Insert --
148 --------------------------------
149
150 procedure Generic_Conditional_Insert
151 (Tree : in out Tree_Type;
152 Key : Key_Type;
153 Node : out Node_Access;
154 Inserted : out Boolean)
155 is
156 X : Node_Access;
157 Y : Node_Access;
158
159 Compare : Boolean;
160
161 begin
162 -- This is a "conditional" insertion, meaning that the insertion request
163 -- can "fail" in the sense that no new node is created. If the Key is
164 -- equivalent to an existing node, then we return the existing node and
165 -- Inserted is set to False. Otherwise, we allocate a new node (via
166 -- Insert_Post) and Inserted is set to True.
167
168 -- Note that we are testing for equivalence here, not equality. Key must
169 -- be strictly less than its next neighbor, and strictly greater than
170 -- its previous neighbor, in order for the conditional insertion to
171 -- succeed.
172
173 -- Handle insertion into an empty container as a special case, so that
174 -- we do not manipulate the tamper bits unnecessarily.
175
176 if Tree.Root = null then
177 Insert_Post (Tree, null, True, Node);
178 Inserted := True;
179 return;
180 end if;
181
182 -- We search the tree to find the nearest neighbor of Key, which is
183 -- either the smallest node greater than Key (Inserted is True), or the
184 -- largest node less or equivalent to Key (Inserted is False).
185
186 declare
187 Lock : With_Lock (Tree.TC'Unrestricted_Access);
188 begin
189 X := Tree.Root;
190 Y := null;
191 Inserted := True;
192 while X /= null loop
193 Y := X;
194 Inserted := Is_Less_Key_Node (Key, X);
195 X := (if Inserted then Ops.Left (X) else Ops.Right (X));
196 end loop;
197 end;
198
199 if Inserted then
200
201 -- Key is less than Y. If Y is the first node in the tree, then there
202 -- are no other nodes that we need to search for, and we insert a new
203 -- node into the tree.
204
205 if Y = Tree.First then
206 Insert_Post (Tree, Y, True, Node);
207 return;
208 end if;
209
210 -- Y is the next nearest-neighbor of Key. We know that Key is not
211 -- equivalent to Y (because Key is strictly less than Y), so we move
212 -- to the previous node, the nearest-neighbor just smaller or
213 -- equivalent to Key.
214
215 Node := Ops.Previous (Y);
216
217 else
218 -- Y is the previous nearest-neighbor of Key. We know that Key is not
219 -- less than Y, which means either that Key is equivalent to Y, or
220 -- greater than Y.
221
222 Node := Y;
223 end if;
224
225 -- Key is equivalent to or greater than Node. We must resolve which is
226 -- the case, to determine whether the conditional insertion succeeds.
227
228 declare
229 Lock : With_Lock (Tree.TC'Unrestricted_Access);
230 begin
231 Compare := Is_Greater_Key_Node (Key, Node);
232 end;
233
234 if Compare then
235
236 -- Key is strictly greater than Node, which means that Key is not
237 -- equivalent to Node. In this case, the insertion succeeds, and we
238 -- insert a new node into the tree.
239
240 Insert_Post (Tree, Y, Inserted, Node);
241 Inserted := True;
242 return;
243 end if;
244
245 -- Key is equivalent to Node. This is a conditional insertion, so we do
246 -- not insert a new node in this case. We return the existing node and
247 -- report that no insertion has occurred.
248
249 Inserted := False;
250 end Generic_Conditional_Insert;
251
252 ------------------------------------------
253 -- Generic_Conditional_Insert_With_Hint --
254 ------------------------------------------
255
256 procedure Generic_Conditional_Insert_With_Hint
257 (Tree : in out Tree_Type;
258 Position : Node_Access;
259 Key : Key_Type;
260 Node : out Node_Access;
261 Inserted : out Boolean)
262 is
263 Test : Node_Access;
264 Compare : Boolean;
265
266 begin
267 -- The purpose of a hint is to avoid a search from the root of
268 -- tree. If we have it hint it means we only need to traverse the
269 -- subtree rooted at the hint to find the nearest neighbor. Note
270 -- that finding the neighbor means merely walking the tree; this
271 -- is not a search and the only comparisons that occur are with
272 -- the hint and its neighbor.
273
274 -- Handle insertion into an empty container as a special case, so that
275 -- we do not manipulate the tamper bits unnecessarily.
276
277 if Tree.Root = null then
278 Insert_Post (Tree, null, True, Node);
279 Inserted := True;
280 return;
281 end if;
282
283 -- If Position is null, this is interpreted to mean that Key is large
284 -- relative to the nodes in the tree. If Key is greater than the last
285 -- node in the tree, then we're done; otherwise the hint was "wrong" and
286 -- we must search.
287
288 if Position = null then -- largest
289 declare
290 Lock : With_Lock (Tree.TC'Unrestricted_Access);
291 begin
292 Compare := Is_Greater_Key_Node (Key, Tree.Last);
293 end;
294
295 if Compare then
296 Insert_Post (Tree, Tree.Last, False, Node);
297 Inserted := True;
298 else
299 Conditional_Insert_Sans_Hint (Tree, Key, Node, Inserted);
300 end if;
301
302 return;
303 end if;
304
305 pragma Assert (Tree.Length > 0);
306
307 -- A hint can either name the node that immediately follows Key,
308 -- or immediately precedes Key. We first test whether Key is
309 -- less than the hint, and if so we compare Key to the node that
310 -- precedes the hint. If Key is both less than the hint and
311 -- greater than the hint's preceding neighbor, then we're done;
312 -- otherwise we must search.
313
314 -- Note also that a hint can either be an anterior node or a leaf
315 -- node. A new node is always inserted at the bottom of the tree
316 -- (at least prior to rebalancing), becoming the new left or
317 -- right child of leaf node (which prior to the insertion must
318 -- necessarily be null, since this is a leaf). If the hint names
319 -- an anterior node then its neighbor must be a leaf, and so
320 -- (here) we insert after the neighbor. If the hint names a leaf
321 -- then its neighbor must be anterior and so we insert before the
322 -- hint.
323
324 declare
325 Lock : With_Lock (Tree.TC'Unrestricted_Access);
326 begin
327 Compare := Is_Less_Key_Node (Key, Position);
328 end;
329
330 if Compare then
331 Test := Ops.Previous (Position); -- "before"
332
333 if Test = null then -- new first node
334 Insert_Post (Tree, Tree.First, True, Node);
335
336 Inserted := True;
337 return;
338 end if;
339
340 declare
341 Lock : With_Lock (Tree.TC'Unrestricted_Access);
342 begin
343 Compare := Is_Greater_Key_Node (Key, Test);
344 end;
345
346 if Compare then
347 if Ops.Right (Test) = null then
348 Insert_Post (Tree, Test, False, Node);
349 else
350 Insert_Post (Tree, Position, True, Node);
351 end if;
352
353 Inserted := True;
354
355 else
356 Conditional_Insert_Sans_Hint (Tree, Key, Node, Inserted);
357 end if;
358
359 return;
360 end if;
361
362 -- We know that Key isn't less than the hint so we try again, this time
363 -- to see if it's greater than the hint. If so we compare Key to the
364 -- node that follows the hint. If Key is both greater than the hint and
365 -- less than the hint's next neighbor, then we're done; otherwise we
366 -- must search.
367
368 declare
369 Lock : With_Lock (Tree.TC'Unrestricted_Access);
370 begin
371 Compare := Is_Greater_Key_Node (Key, Position);
372 end;
373
374 if Compare then
375 Test := Ops.Next (Position); -- "after"
376
377 if Test = null then -- new last node
378 Insert_Post (Tree, Tree.Last, False, Node);
379
380 Inserted := True;
381 return;
382 end if;
383
384 declare
385 Lock : With_Lock (Tree.TC'Unrestricted_Access);
386 begin
387 Compare := Is_Less_Key_Node (Key, Test);
388 end;
389
390 if Compare then
391 if Ops.Right (Position) = null then
392 Insert_Post (Tree, Position, False, Node);
393 else
394 Insert_Post (Tree, Test, True, Node);
395 end if;
396
397 Inserted := True;
398
399 else
400 Conditional_Insert_Sans_Hint (Tree, Key, Node, Inserted);
401 end if;
402
403 return;
404 end if;
405
406 -- We know that Key is neither less than the hint nor greater than the
407 -- hint, and that's the definition of equivalence. There's nothing else
408 -- we need to do, since a search would just reach the same conclusion.
409
410 Node := Position;
411 Inserted := False;
412 end Generic_Conditional_Insert_With_Hint;
413
414 -------------------------
415 -- Generic_Insert_Post --
416 -------------------------
417
418 procedure Generic_Insert_Post
419 (Tree : in out Tree_Type;
420 Y : Node_Access;
421 Before : Boolean;
422 Z : out Node_Access)
423 is
424 begin
425 if Checks and then Tree.Length = Count_Type'Last then
426 raise Constraint_Error with "too many elements";
427 end if;
428
429 TC_Check (Tree.TC);
430
431 Z := New_Node;
432 pragma Assert (Z /= null);
433 pragma Assert (Ops.Color (Z) = Red);
434
435 if Y = null then
436 pragma Assert (Tree.Length = 0);
437 pragma Assert (Tree.Root = null);
438 pragma Assert (Tree.First = null);
439 pragma Assert (Tree.Last = null);
440
441 Tree.Root := Z;
442 Tree.First := Z;
443 Tree.Last := Z;
444
445 elsif Before then
446 pragma Assert (Ops.Left (Y) = null);
447
448 Ops.Set_Left (Y, Z);
449
450 if Y = Tree.First then
451 Tree.First := Z;
452 end if;
453
454 else
455 pragma Assert (Ops.Right (Y) = null);
456
457 Ops.Set_Right (Y, Z);
458
459 if Y = Tree.Last then
460 Tree.Last := Z;
461 end if;
462 end if;
463
464 Ops.Set_Parent (Z, Y);
465 Ops.Rebalance_For_Insert (Tree, Z);
466 Tree.Length := Tree.Length + 1;
467 end Generic_Insert_Post;
468
469 -----------------------
470 -- Generic_Iteration --
471 -----------------------
472
473 procedure Generic_Iteration
474 (Tree : Tree_Type;
475 Key : Key_Type)
476 is
477 procedure Iterate (Node : Node_Access);
478
479 -------------
480 -- Iterate --
481 -------------
482
483 procedure Iterate (Node : Node_Access) is
484 N : Node_Access;
485 begin
486 N := Node;
487 while N /= null loop
488 if Is_Less_Key_Node (Key, N) then
489 N := Ops.Left (N);
490 elsif Is_Greater_Key_Node (Key, N) then
491 N := Ops.Right (N);
492 else
493 Iterate (Ops.Left (N));
494 Process (N);
495 N := Ops.Right (N);
496 end if;
497 end loop;
498 end Iterate;
499
500 -- Start of processing for Generic_Iteration
501
502 begin
503 Iterate (Tree.Root);
504 end Generic_Iteration;
505
506 -------------------------------
507 -- Generic_Reverse_Iteration --
508 -------------------------------
509
510 procedure Generic_Reverse_Iteration
511 (Tree : Tree_Type;
512 Key : Key_Type)
513 is
514 procedure Iterate (Node : Node_Access);
515
516 -------------
517 -- Iterate --
518 -------------
519
520 procedure Iterate (Node : Node_Access) is
521 N : Node_Access;
522 begin
523 N := Node;
524 while N /= null loop
525 if Is_Less_Key_Node (Key, N) then
526 N := Ops.Left (N);
527 elsif Is_Greater_Key_Node (Key, N) then
528 N := Ops.Right (N);
529 else
530 Iterate (Ops.Right (N));
531 Process (N);
532 N := Ops.Left (N);
533 end if;
534 end loop;
535 end Iterate;
536
537 -- Start of processing for Generic_Reverse_Iteration
538
539 begin
540 Iterate (Tree.Root);
541 end Generic_Reverse_Iteration;
542
543 ----------------------------------
544 -- Generic_Unconditional_Insert --
545 ----------------------------------
546
547 procedure Generic_Unconditional_Insert
548 (Tree : in out Tree_Type;
549 Key : Key_Type;
550 Node : out Node_Access)
551 is
552 Y : Node_Access;
553 X : Node_Access;
554
555 Before : Boolean;
556
557 begin
558 Y := null;
559 Before := False;
560
561 X := Tree.Root;
562 while X /= null loop
563 Y := X;
564 Before := Is_Less_Key_Node (Key, X);
565 X := (if Before then Ops.Left (X) else Ops.Right (X));
566 end loop;
567
568 Insert_Post (Tree, Y, Before, Node);
569 end Generic_Unconditional_Insert;
570
571 --------------------------------------------
572 -- Generic_Unconditional_Insert_With_Hint --
573 --------------------------------------------
574
575 procedure Generic_Unconditional_Insert_With_Hint
576 (Tree : in out Tree_Type;
577 Hint : Node_Access;
578 Key : Key_Type;
579 Node : out Node_Access)
580 is
581 begin
582 -- There are fewer constraints for an unconditional insertion
583 -- than for a conditional insertion, since we allow duplicate
584 -- keys. So instead of having to check (say) whether Key is
585 -- (strictly) greater than the hint's previous neighbor, here we
586 -- allow Key to be equal to or greater than the previous node.
587
588 -- There is the issue of what to do if Key is equivalent to the
589 -- hint. Does the new node get inserted before or after the hint?
590 -- We decide that it gets inserted after the hint, reasoning that
591 -- this is consistent with behavior for non-hint insertion, which
592 -- inserts a new node after existing nodes with equivalent keys.
593
594 -- First we check whether the hint is null, which is interpreted
595 -- to mean that Key is large relative to existing nodes.
596 -- Following our rule above, if Key is equal to or greater than
597 -- the last node, then we insert the new node immediately after
598 -- last. (We don't have an operation for testing whether a key is
599 -- "equal to or greater than" a node, so we must say instead "not
600 -- less than", which is equivalent.)
601
602 if Hint = null then -- largest
603 if Tree.Last = null then
604 Insert_Post (Tree, null, False, Node);
605 elsif Is_Less_Key_Node (Key, Tree.Last) then
606 Unconditional_Insert_Sans_Hint (Tree, Key, Node);
607 else
608 Insert_Post (Tree, Tree.Last, False, Node);
609 end if;
610
611 return;
612 end if;
613
614 pragma Assert (Tree.Length > 0);
615
616 -- We decide here whether to insert the new node prior to the
617 -- hint. Key could be equivalent to the hint, so in theory we
618 -- could write the following test as "not greater than" (same as
619 -- "less than or equal to"). If Key were equivalent to the hint,
620 -- that would mean that the new node gets inserted before an
621 -- equivalent node. That wouldn't break any container invariants,
622 -- but our rule above says that new nodes always get inserted
623 -- after equivalent nodes. So here we test whether Key is both
624 -- less than the hint and equal to or greater than the hint's
625 -- previous neighbor, and if so insert it before the hint.
626
627 if Is_Less_Key_Node (Key, Hint) then
628 declare
629 Before : constant Node_Access := Ops.Previous (Hint);
630 begin
631 if Before = null then
632 Insert_Post (Tree, Hint, True, Node);
633 elsif Is_Less_Key_Node (Key, Before) then
634 Unconditional_Insert_Sans_Hint (Tree, Key, Node);
635 elsif Ops.Right (Before) = null then
636 Insert_Post (Tree, Before, False, Node);
637 else
638 Insert_Post (Tree, Hint, True, Node);
639 end if;
640 end;
641
642 return;
643 end if;
644
645 -- We know that Key isn't less than the hint, so it must be equal
646 -- or greater. So we just test whether Key is less than or equal
647 -- to (same as "not greater than") the hint's next neighbor, and
648 -- if so insert it after the hint.
649
650 declare
651 After : constant Node_Access := Ops.Next (Hint);
652 begin
653 if After = null then
654 Insert_Post (Tree, Hint, False, Node);
655 elsif Is_Greater_Key_Node (Key, After) then
656 Unconditional_Insert_Sans_Hint (Tree, Key, Node);
657 elsif Ops.Right (Hint) = null then
658 Insert_Post (Tree, Hint, False, Node);
659 else
660 Insert_Post (Tree, After, True, Node);
661 end if;
662 end;
663 end Generic_Unconditional_Insert_With_Hint;
664
665 -----------------
666 -- Upper_Bound --
667 -----------------
668
669 function Upper_Bound
670 (Tree : Tree_Type;
671 Key : Key_Type) return Node_Access
672 is
673 Y : Node_Access;
674 X : Node_Access;
675
676 begin
677 X := Tree.Root;
678 while X /= null loop
679 if Is_Less_Key_Node (Key, X) then
680 Y := X;
681 X := Ops.Left (X);
682 else
683 X := Ops.Right (X);
684 end if;
685 end loop;
686
687 return Y;
688 end Upper_Bound;
689
690 end Ada.Containers.Red_Black_Trees.Generic_Keys;