1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_BOUNDED_OPERATIONS --
9 -- Copyright (C) 2004-2011, 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 -- The references below to "CLR" refer to the following book, from which
31 -- several of the algorithms here were adapted:
32 -- Introduction to Algorithms
33 -- by Thomas H. Cormen, Charles E. Leiserson, Ronald L. Rivest
34 -- Publisher: The MIT Press (June 18, 1990)
37 with System; use type System.Address;
39 package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is
41 -----------------------
42 -- Local Subprograms --
43 -----------------------
45 procedure Delete_Fixup (Tree : in out Tree_Type'Class; Node : Count_Type);
46 procedure Delete_Swap (Tree : in out Tree_Type'Class; Z, Y : Count_Type);
48 procedure Left_Rotate (Tree : in out Tree_Type'Class; X : Count_Type);
49 procedure Right_Rotate (Tree : in out Tree_Type'Class; Y : Count_Type);
55 procedure Clear_Tree (Tree : in out Tree_Type'Class) is
58 raise Program_Error with
59 "attempt to tamper with cursors (container is busy)";
62 -- The lock status (which monitors "element tampering") always implies
63 -- that the busy status (which monitors "cursor tampering") is set too;
64 -- this is a representation invariant. Thus if the busy bit is not set,
65 -- then the lock bit must not be set either.
67 pragma Assert (Tree.Lock = 0);
80 procedure Delete_Fixup
81 (Tree : in out Tree_Type'Class;
88 N : Nodes_Type renames Tree.Nodes;
93 and then Color (N (X)) = Black
95 if X = Left (N (Parent (N (X)))) then
96 W := Right (N (Parent (N (X))));
98 if Color (N (W)) = Red then
99 Set_Color (N (W), Black);
100 Set_Color (N (Parent (N (X))), Red);
101 Left_Rotate (Tree, Parent (N (X)));
102 W := Right (N (Parent (N (X))));
105 if (Left (N (W)) = 0 or else Color (N (Left (N (W)))) = Black)
107 (Right (N (W)) = 0 or else Color (N (Right (N (W)))) = Black)
109 Set_Color (N (W), Red);
114 or else Color (N (Right (N (W)))) = Black
116 -- As a condition for setting the color of the left child to
117 -- black, the left child access value must be non-null. A
118 -- truth table analysis shows that if we arrive here, that
119 -- condition holds, so there's no need for an explicit test.
120 -- The assertion is here to document what we know is true.
122 pragma Assert (Left (N (W)) /= 0);
123 Set_Color (N (Left (N (W))), Black);
125 Set_Color (N (W), Red);
126 Right_Rotate (Tree, W);
127 W := Right (N (Parent (N (X))));
130 Set_Color (N (W), Color (N (Parent (N (X)))));
131 Set_Color (N (Parent (N (X))), Black);
132 Set_Color (N (Right (N (W))), Black);
133 Left_Rotate (Tree, Parent (N (X)));
138 pragma Assert (X = Right (N (Parent (N (X)))));
140 W := Left (N (Parent (N (X))));
142 if Color (N (W)) = Red then
143 Set_Color (N (W), Black);
144 Set_Color (N (Parent (N (X))), Red);
145 Right_Rotate (Tree, Parent (N (X)));
146 W := Left (N (Parent (N (X))));
149 if (Left (N (W)) = 0 or else Color (N (Left (N (W)))) = Black)
151 (Right (N (W)) = 0 or else Color (N (Right (N (W)))) = Black)
153 Set_Color (N (W), Red);
158 or else Color (N (Left (N (W)))) = Black
160 -- As a condition for setting the color of the right child
161 -- to black, the right child access value must be non-null.
162 -- A truth table analysis shows that if we arrive here, that
163 -- condition holds, so there's no need for an explicit test.
164 -- The assertion is here to document what we know is true.
166 pragma Assert (Right (N (W)) /= 0);
167 Set_Color (N (Right (N (W))), Black);
169 Set_Color (N (W), Red);
170 Left_Rotate (Tree, W);
171 W := Left (N (Parent (N (X))));
174 Set_Color (N (W), Color (N (Parent (N (X)))));
175 Set_Color (N (Parent (N (X))), Black);
176 Set_Color (N (Left (N (W))), Black);
177 Right_Rotate (Tree, Parent (N (X)));
183 Set_Color (N (X), Black);
186 ---------------------------
187 -- Delete_Node_Sans_Free --
188 ---------------------------
190 procedure Delete_Node_Sans_Free
191 (Tree : in out Tree_Type'Class;
198 Z : constant Count_Type := Node;
199 pragma Assert (Z /= 0);
201 N : Nodes_Type renames Tree.Nodes;
204 if Tree.Busy > 0 then
205 raise Program_Error with
206 "attempt to tamper with cursors (container is busy)";
209 pragma Assert (Tree.Length > 0);
210 pragma Assert (Tree.Root /= 0);
211 pragma Assert (Tree.First /= 0);
212 pragma Assert (Tree.Last /= 0);
213 pragma Assert (Parent (N (Tree.Root)) = 0);
215 pragma Assert ((Tree.Length > 1)
216 or else (Tree.First = Tree.Last
217 and then Tree.First = Tree.Root));
219 pragma Assert ((Left (N (Node)) = 0)
220 or else (Parent (N (Left (N (Node)))) = Node));
222 pragma Assert ((Right (N (Node)) = 0)
223 or else (Parent (N (Right (N (Node)))) = Node));
225 pragma Assert (((Parent (N (Node)) = 0) and then (Tree.Root = Node))
226 or else ((Parent (N (Node)) /= 0) and then
227 ((Left (N (Parent (N (Node)))) = Node)
229 (Right (N (Parent (N (Node)))) = Node))));
231 if Left (N (Z)) = 0 then
232 if Right (N (Z)) = 0 then
233 if Z = Tree.First then
234 Tree.First := Parent (N (Z));
237 if Z = Tree.Last then
238 Tree.Last := Parent (N (Z));
241 if Color (N (Z)) = Black then
242 Delete_Fixup (Tree, Z);
245 pragma Assert (Left (N (Z)) = 0);
246 pragma Assert (Right (N (Z)) = 0);
248 if Z = Tree.Root then
249 pragma Assert (Tree.Length = 1);
250 pragma Assert (Parent (N (Z)) = 0);
252 elsif Z = Left (N (Parent (N (Z)))) then
253 Set_Left (N (Parent (N (Z))), 0);
255 pragma Assert (Z = Right (N (Parent (N (Z)))));
256 Set_Right (N (Parent (N (Z))), 0);
260 pragma Assert (Z /= Tree.Last);
264 if Z = Tree.First then
265 Tree.First := Min (Tree, X);
268 if Z = Tree.Root then
270 elsif Z = Left (N (Parent (N (Z)))) then
271 Set_Left (N (Parent (N (Z))), X);
273 pragma Assert (Z = Right (N (Parent (N (Z)))));
274 Set_Right (N (Parent (N (Z))), X);
277 Set_Parent (N (X), Parent (N (Z)));
279 if Color (N (Z)) = Black then
280 Delete_Fixup (Tree, X);
284 elsif Right (N (Z)) = 0 then
285 pragma Assert (Z /= Tree.First);
289 if Z = Tree.Last then
290 Tree.Last := Max (Tree, X);
293 if Z = Tree.Root then
295 elsif Z = Left (N (Parent (N (Z)))) then
296 Set_Left (N (Parent (N (Z))), X);
298 pragma Assert (Z = Right (N (Parent (N (Z)))));
299 Set_Right (N (Parent (N (Z))), X);
302 Set_Parent (N (X), Parent (N (Z)));
304 if Color (N (Z)) = Black then
305 Delete_Fixup (Tree, X);
309 pragma Assert (Z /= Tree.First);
310 pragma Assert (Z /= Tree.Last);
313 pragma Assert (Left (N (Y)) = 0);
318 if Y = Left (N (Parent (N (Y)))) then
319 pragma Assert (Parent (N (Y)) /= Z);
320 Delete_Swap (Tree, Z, Y);
321 Set_Left (N (Parent (N (Z))), Z);
324 pragma Assert (Y = Right (N (Parent (N (Y)))));
325 pragma Assert (Parent (N (Y)) = Z);
326 Set_Parent (N (Y), Parent (N (Z)));
328 if Z = Tree.Root then
330 elsif Z = Left (N (Parent (N (Z)))) then
331 Set_Left (N (Parent (N (Z))), Y);
333 pragma Assert (Z = Right (N (Parent (N (Z)))));
334 Set_Right (N (Parent (N (Z))), Y);
337 Set_Left (N (Y), Left (N (Z)));
338 Set_Parent (N (Left (N (Y))), Y);
339 Set_Right (N (Y), Z);
341 Set_Parent (N (Z), Y);
343 Set_Right (N (Z), 0);
346 Y_Color : constant Color_Type := Color (N (Y));
348 Set_Color (N (Y), Color (N (Z)));
349 Set_Color (N (Z), Y_Color);
353 if Color (N (Z)) = Black then
354 Delete_Fixup (Tree, Z);
357 pragma Assert (Left (N (Z)) = 0);
358 pragma Assert (Right (N (Z)) = 0);
360 if Z = Right (N (Parent (N (Z)))) then
361 Set_Right (N (Parent (N (Z))), 0);
363 pragma Assert (Z = Left (N (Parent (N (Z)))));
364 Set_Left (N (Parent (N (Z))), 0);
368 if Y = Left (N (Parent (N (Y)))) then
369 pragma Assert (Parent (N (Y)) /= Z);
371 Delete_Swap (Tree, Z, Y);
373 Set_Left (N (Parent (N (Z))), X);
374 Set_Parent (N (X), Parent (N (Z)));
377 pragma Assert (Y = Right (N (Parent (N (Y)))));
378 pragma Assert (Parent (N (Y)) = Z);
380 Set_Parent (N (Y), Parent (N (Z)));
382 if Z = Tree.Root then
384 elsif Z = Left (N (Parent (N (Z)))) then
385 Set_Left (N (Parent (N (Z))), Y);
387 pragma Assert (Z = Right (N (Parent (N (Z)))));
388 Set_Right (N (Parent (N (Z))), Y);
391 Set_Left (N (Y), Left (N (Z)));
392 Set_Parent (N (Left (N (Y))), Y);
395 Y_Color : constant Color_Type := Color (N (Y));
397 Set_Color (N (Y), Color (N (Z)));
398 Set_Color (N (Z), Y_Color);
402 if Color (N (Z)) = Black then
403 Delete_Fixup (Tree, X);
408 Tree.Length := Tree.Length - 1;
409 end Delete_Node_Sans_Free;
415 procedure Delete_Swap
416 (Tree : in out Tree_Type'Class;
419 N : Nodes_Type renames Tree.Nodes;
421 pragma Assert (Z /= Y);
422 pragma Assert (Parent (N (Y)) /= Z);
424 Y_Parent : constant Count_Type := Parent (N (Y));
425 Y_Color : constant Color_Type := Color (N (Y));
428 Set_Parent (N (Y), Parent (N (Z)));
429 Set_Left (N (Y), Left (N (Z)));
430 Set_Right (N (Y), Right (N (Z)));
431 Set_Color (N (Y), Color (N (Z)));
433 if Tree.Root = Z then
435 elsif Right (N (Parent (N (Y)))) = Z then
436 Set_Right (N (Parent (N (Y))), Y);
438 pragma Assert (Left (N (Parent (N (Y)))) = Z);
439 Set_Left (N (Parent (N (Y))), Y);
442 if Right (N (Y)) /= 0 then
443 Set_Parent (N (Right (N (Y))), Y);
446 if Left (N (Y)) /= 0 then
447 Set_Parent (N (Left (N (Y))), Y);
450 Set_Parent (N (Z), Y_Parent);
451 Set_Color (N (Z), Y_Color);
453 Set_Right (N (Z), 0);
460 procedure Free (Tree : in out Tree_Type'Class; X : Count_Type) is
461 pragma Assert (X > 0);
462 pragma Assert (X <= Tree.Capacity);
464 N : Nodes_Type renames Tree.Nodes;
465 -- pragma Assert (N (X).Prev >= 0); -- node is active
466 -- Find a way to mark a node as active vs. inactive; we could
467 -- use a special value in Color_Type for this. ???
470 -- The set container actually contains two data structures: a list for
471 -- the "active" nodes that contain elements that have been inserted
472 -- onto the tree, and another for the "inactive" nodes of the free
475 -- We desire that merely declaring an object should have only minimal
476 -- cost; specially, we want to avoid having to initialize the free
477 -- store (to fill in the links), especially if the capacity is large.
479 -- The head of the free list is indicated by Container.Free. If its
480 -- value is non-negative, then the free store has been initialized
481 -- in the "normal" way: Container.Free points to the head of the list
482 -- of free (inactive) nodes, and the value 0 means the free list is
483 -- empty. Each node on the free list has been initialized to point
484 -- to the next free node (via its Parent component), and the value 0
485 -- means that this is the last free node.
487 -- If Container.Free is negative, then the links on the free store
488 -- have not been initialized. In this case the link values are
489 -- implied: the free store comprises the components of the node array
490 -- started with the absolute value of Container.Free, and continuing
491 -- until the end of the array (Nodes'Last).
494 -- It might be possible to perform an optimization here. Suppose that
495 -- the free store can be represented as having two parts: one
496 -- comprising the non-contiguous inactive nodes linked together
497 -- in the normal way, and the other comprising the contiguous
498 -- inactive nodes (that are not linked together, at the end of the
499 -- nodes array). This would allow us to never have to initialize
500 -- the free store, except in a lazy way as nodes become inactive.
502 -- When an element is deleted from the list container, its node
503 -- becomes inactive, and so we set its Prev component to a negative
504 -- value, to indicate that it is now inactive. This provides a useful
505 -- way to detect a dangling cursor reference.
507 -- The comment above is incorrect; we need some other way to
508 -- indicate a node is inactive, for example by using a special
509 -- Color_Type value. ???
510 -- N (X).Prev := -1; -- Node is deallocated (not on active list)
512 if Tree.Free >= 0 then
513 -- The free store has previously been initialized. All we need to
514 -- do here is link the newly-free'd node onto the free list.
516 Set_Parent (N (X), Tree.Free);
519 elsif X + 1 = abs Tree.Free then
520 -- The free store has not been initialized, and the node becoming
521 -- inactive immediately precedes the start of the free store. All
522 -- we need to do is move the start of the free store back by one.
524 Tree.Free := Tree.Free + 1;
527 -- The free store has not been initialized, and the node becoming
528 -- inactive does not immediately precede the free store. Here we
529 -- first initialize the free store (meaning the links are given
530 -- values in the traditional way), and then link the newly-free'd
531 -- node onto the head of the free store.
534 -- See the comments above for an optimization opportunity. If the
535 -- next link for a node on the free store is negative, then this
536 -- means the remaining nodes on the free store are physically
537 -- contiguous, starting as the absolute value of that index value.
539 Tree.Free := abs Tree.Free;
541 if Tree.Free > Tree.Capacity then
545 for I in Tree.Free .. Tree.Capacity - 1 loop
546 Set_Parent (N (I), I + 1);
549 Set_Parent (N (Tree.Capacity), 0);
552 Set_Parent (N (X), Tree.Free);
557 -----------------------
558 -- Generic_Allocate --
559 -----------------------
561 procedure Generic_Allocate
562 (Tree : in out Tree_Type'Class;
563 Node : out Count_Type)
565 N : Nodes_Type renames Tree.Nodes;
568 if Tree.Free >= 0 then
571 -- We always perform the assignment first, before we
572 -- change container state, in order to defend against
573 -- exceptions duration assignment.
575 Set_Element (N (Node));
576 Tree.Free := Parent (N (Node));
579 -- A negative free store value means that the links of the nodes
580 -- in the free store have not been initialized. In this case, the
581 -- nodes are physically contiguous in the array, starting at the
582 -- index that is the absolute value of the Container.Free, and
583 -- continuing until the end of the array (Nodes'Last).
585 Node := abs Tree.Free;
587 -- As above, we perform this assignment first, before modifying
588 -- any container state.
590 Set_Element (N (Node));
591 Tree.Free := Tree.Free - 1;
594 -- When a node is allocated from the free store, its pointer components
595 -- (the links to other nodes in the tree) must also be initialized (to
596 -- 0, the equivalent of null). This simplifies the post-allocation
597 -- handling of nodes inserted into terminal positions.
599 Set_Parent (N (Node), Parent => 0);
600 Set_Left (N (Node), Left => 0);
601 Set_Right (N (Node), Right => 0);
602 end Generic_Allocate;
608 function Generic_Equal (Left, Right : Tree_Type'Class) return Boolean is
613 if Left'Address = Right'Address then
617 if Left.Length /= Right.Length then
621 L_Node := Left.First;
622 R_Node := Right.First;
623 while L_Node /= 0 loop
624 if not Is_Equal (Left.Nodes (L_Node), Right.Nodes (R_Node)) then
628 L_Node := Next (Left, L_Node);
629 R_Node := Next (Right, R_Node);
635 -----------------------
636 -- Generic_Iteration --
637 -----------------------
639 procedure Generic_Iteration (Tree : Tree_Type'Class) is
640 procedure Iterate (P : Count_Type);
646 procedure Iterate (P : Count_Type) is
650 Iterate (Left (Tree.Nodes (X)));
652 X := Right (Tree.Nodes (X));
656 -- Start of processing for Generic_Iteration
660 end Generic_Iteration;
666 procedure Generic_Read
667 (Stream : not null access Root_Stream_Type'Class;
668 Tree : in out Tree_Type'Class)
670 Len : Count_Type'Base;
672 Node, Last_Node : Count_Type;
674 N : Nodes_Type renames Tree.Nodes;
678 Count_Type'Base'Read (Stream, Len);
681 raise Program_Error with "bad container length (corrupt stream)";
688 if Len > Tree.Capacity then
689 raise Constraint_Error with "length exceeds capacity";
692 -- Use Unconditional_Insert_With_Hint here instead ???
694 Allocate (Tree, Node);
695 pragma Assert (Node /= 0);
697 Set_Color (N (Node), Black);
704 for J in Count_Type range 2 .. Len loop
706 pragma Assert (Last_Node = Tree.Last);
708 Allocate (Tree, Node);
709 pragma Assert (Node /= 0);
711 Set_Color (N (Node), Red);
712 Set_Right (N (Last_Node), Right => Node);
714 Set_Parent (N (Node), Parent => Last_Node);
716 Rebalance_For_Insert (Tree, Node);
717 Tree.Length := Tree.Length + 1;
721 -------------------------------
722 -- Generic_Reverse_Iteration --
723 -------------------------------
725 procedure Generic_Reverse_Iteration (Tree : Tree_Type'Class) is
726 procedure Iterate (P : Count_Type);
732 procedure Iterate (P : Count_Type) is
736 Iterate (Right (Tree.Nodes (X)));
738 X := Left (Tree.Nodes (X));
742 -- Start of processing for Generic_Reverse_Iteration
746 end Generic_Reverse_Iteration;
752 procedure Generic_Write
753 (Stream : not null access Root_Stream_Type'Class;
754 Tree : Tree_Type'Class)
756 procedure Process (Node : Count_Type);
757 pragma Inline (Process);
759 procedure Iterate is new Generic_Iteration (Process);
765 procedure Process (Node : Count_Type) is
767 Write_Node (Stream, Tree.Nodes (Node));
770 -- Start of processing for Generic_Write
773 Count_Type'Base'Write (Stream, Tree.Length);
781 procedure Left_Rotate (Tree : in out Tree_Type'Class; X : Count_Type) is
784 N : Nodes_Type renames Tree.Nodes;
786 Y : constant Count_Type := Right (N (X));
787 pragma Assert (Y /= 0);
790 Set_Right (N (X), Left (N (Y)));
792 if Left (N (Y)) /= 0 then
793 Set_Parent (N (Left (N (Y))), X);
796 Set_Parent (N (Y), Parent (N (X)));
798 if X = Tree.Root then
800 elsif X = Left (N (Parent (N (X)))) then
801 Set_Left (N (Parent (N (X))), Y);
803 pragma Assert (X = Right (N (Parent (N (X)))));
804 Set_Right (N (Parent (N (X))), Y);
808 Set_Parent (N (X), Y);
816 (Tree : Tree_Type'Class;
817 Node : Count_Type) return Count_Type
821 X : Count_Type := Node;
826 Y := Right (Tree.Nodes (X));
841 (Tree : Tree_Type'Class;
842 Node : Count_Type) return Count_Type
846 X : Count_Type := Node;
851 Y := Left (Tree.Nodes (X));
866 (Tree : Tree_Type'Class;
867 Node : Count_Type) return Count_Type
876 if Right (Tree.Nodes (Node)) /= 0 then
877 return Min (Tree, Right (Tree.Nodes (Node)));
881 X : Count_Type := Node;
882 Y : Count_Type := Parent (Tree.Nodes (Node));
886 and then X = Right (Tree.Nodes (Y))
889 Y := Parent (Tree.Nodes (Y));
901 (Tree : Tree_Type'Class;
902 Node : Count_Type) return Count_Type
909 if Left (Tree.Nodes (Node)) /= 0 then
910 return Max (Tree, Left (Tree.Nodes (Node)));
914 X : Count_Type := Node;
915 Y : Count_Type := Parent (Tree.Nodes (Node));
919 and then X = Left (Tree.Nodes (Y))
922 Y := Parent (Tree.Nodes (Y));
929 --------------------------
930 -- Rebalance_For_Insert --
931 --------------------------
933 procedure Rebalance_For_Insert
934 (Tree : in out Tree_Type'Class;
939 N : Nodes_Type renames Tree.Nodes;
941 X : Count_Type := Node;
942 pragma Assert (X /= 0);
943 pragma Assert (Color (N (X)) = Red);
948 while X /= Tree.Root and then Color (N (Parent (N (X)))) = Red loop
949 if Parent (N (X)) = Left (N (Parent (N (Parent (N (X)))))) then
950 Y := Right (N (Parent (N (Parent (N (X))))));
952 if Y /= 0 and then Color (N (Y)) = Red then
953 Set_Color (N (Parent (N (X))), Black);
954 Set_Color (N (Y), Black);
955 Set_Color (N (Parent (N (Parent (N (X))))), Red);
956 X := Parent (N (Parent (N (X))));
959 if X = Right (N (Parent (N (X)))) then
961 Left_Rotate (Tree, X);
964 Set_Color (N (Parent (N (X))), Black);
965 Set_Color (N (Parent (N (Parent (N (X))))), Red);
966 Right_Rotate (Tree, Parent (N (Parent (N (X)))));
970 pragma Assert (Parent (N (X)) =
971 Right (N (Parent (N (Parent (N (X)))))));
973 Y := Left (N (Parent (N (Parent (N (X))))));
975 if Y /= 0 and then Color (N (Y)) = Red then
976 Set_Color (N (Parent (N (X))), Black);
977 Set_Color (N (Y), Black);
978 Set_Color (N (Parent (N (Parent (N (X))))), Red);
979 X := Parent (N (Parent (N (X))));
982 if X = Left (N (Parent (N (X)))) then
984 Right_Rotate (Tree, X);
987 Set_Color (N (Parent (N (X))), Black);
988 Set_Color (N (Parent (N (Parent (N (X))))), Red);
989 Left_Rotate (Tree, Parent (N (Parent (N (X)))));
994 Set_Color (N (Tree.Root), Black);
995 end Rebalance_For_Insert;
1001 procedure Right_Rotate (Tree : in out Tree_Type'Class; Y : Count_Type) is
1002 N : Nodes_Type renames Tree.Nodes;
1004 X : constant Count_Type := Left (N (Y));
1005 pragma Assert (X /= 0);
1008 Set_Left (N (Y), Right (N (X)));
1010 if Right (N (X)) /= 0 then
1011 Set_Parent (N (Right (N (X))), Y);
1014 Set_Parent (N (X), Parent (N (Y)));
1016 if Y = Tree.Root then
1018 elsif Y = Left (N (Parent (N (Y)))) then
1019 Set_Left (N (Parent (N (Y))), X);
1021 pragma Assert (Y = Right (N (Parent (N (Y)))));
1022 Set_Right (N (Parent (N (Y))), X);
1025 Set_Right (N (X), Y);
1026 Set_Parent (N (Y), X);
1033 function Vet (Tree : Tree_Type'Class; Index : Count_Type) return Boolean is
1034 Nodes : Nodes_Type renames Tree.Nodes;
1035 Node : Node_Type renames Nodes (Index);
1038 if Parent (Node) = Index
1039 or else Left (Node) = Index
1040 or else Right (Node) = Index
1046 or else Tree.Root = 0
1047 or else Tree.First = 0
1048 or else Tree.Last = 0
1053 if Parent (Nodes (Tree.Root)) /= 0 then
1057 if Left (Nodes (Tree.First)) /= 0 then
1061 if Right (Nodes (Tree.Last)) /= 0 then
1065 if Tree.Length = 1 then
1066 if Tree.First /= Tree.Last
1067 or else Tree.First /= Tree.Root
1072 if Index /= Tree.First then
1076 if Parent (Node) /= 0
1077 or else Left (Node) /= 0
1078 or else Right (Node) /= 0
1086 if Tree.First = Tree.Last then
1090 if Tree.Length = 2 then
1091 if Tree.First /= Tree.Root
1092 and then Tree.Last /= Tree.Root
1097 if Tree.First /= Index
1098 and then Tree.Last /= Index
1105 and then Parent (Nodes (Left (Node))) /= Index
1110 if Right (Node) /= 0
1111 and then Parent (Nodes (Right (Node))) /= Index
1116 if Parent (Node) = 0 then
1117 if Tree.Root /= Index then
1121 elsif Left (Nodes (Parent (Node))) /= Index
1122 and then Right (Nodes (Parent (Node))) /= Index
1130 end Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations;