From b9de1157289455b0ca26daff519d4a0ddcd1fa13 Mon Sep 17 00:00:00 2001 From: Dan Albert Date: Wed, 24 Feb 2016 13:48:45 -0800 Subject: Update 4.8.1 to 4.8.3. My previous drop was the wrong version. The platform mingw is currently using 4.8.3, not 4.8.1 (not sure how I got that wrong). From ftp://ftp.gnu.org/gnu/gcc/gcc-4.8.3/gcc-4.8.3.tar.bz2. Bug: http://b/26523949 Change-Id: Id85f1bdcbbaf78c7d0b5a69e74c798a08f341c35 --- gcc-4.8.3/gcc/ada/a-crbtgo.adb | 1155 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 1155 insertions(+) create mode 100644 gcc-4.8.3/gcc/ada/a-crbtgo.adb (limited to 'gcc-4.8.3/gcc/ada/a-crbtgo.adb') diff --git a/gcc-4.8.3/gcc/ada/a-crbtgo.adb b/gcc-4.8.3/gcc/ada/a-crbtgo.adb new file mode 100644 index 000000000..c8ddcff02 --- /dev/null +++ b/gcc-4.8.3/gcc/ada/a-crbtgo.adb @@ -0,0 +1,1155 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_OPERATIONS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +-- The references below to "CLR" refer to the following book, from which +-- several of the algorithms here were adapted: +-- Introduction to Algorithms +-- by Thomas H. Cormen, Charles E. Leiserson, Ronald L. Rivest +-- Publisher: The MIT Press (June 18, 1990) +-- ISBN: 0262031418 + +with System; use type System.Address; + +package body Ada.Containers.Red_Black_Trees.Generic_Operations is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Delete_Fixup (Tree : in out Tree_Type; Node : Node_Access); + + procedure Delete_Swap (Tree : in out Tree_Type; Z, Y : Node_Access); + + procedure Left_Rotate (Tree : in out Tree_Type; X : Node_Access); + procedure Right_Rotate (Tree : in out Tree_Type; Y : Node_Access); + +-- Why is all the following code commented out ??? + +-- --------------------- +-- -- Check_Invariant -- +-- --------------------- + +-- procedure Check_Invariant (Tree : Tree_Type) is +-- Root : constant Node_Access := Tree.Root; +-- +-- function Check (Node : Node_Access) return Natural; +-- +-- ----------- +-- -- Check -- +-- ----------- +-- +-- function Check (Node : Node_Access) return Natural is +-- begin +-- if Node = null then +-- return 0; +-- end if; +-- +-- if Color (Node) = Red then +-- declare +-- L : constant Node_Access := Left (Node); +-- begin +-- pragma Assert (L = null or else Color (L) = Black); +-- null; +-- end; +-- +-- declare +-- R : constant Node_Access := Right (Node); +-- begin +-- pragma Assert (R = null or else Color (R) = Black); +-- null; +-- end; +-- +-- declare +-- NL : constant Natural := Check (Left (Node)); +-- NR : constant Natural := Check (Right (Node)); +-- begin +-- pragma Assert (NL = NR); +-- return NL; +-- end; +-- end if; +-- +-- declare +-- NL : constant Natural := Check (Left (Node)); +-- NR : constant Natural := Check (Right (Node)); +-- begin +-- pragma Assert (NL = NR); +-- return NL + 1; +-- end; +-- end Check; +-- +-- -- Start of processing for Check_Invariant +-- +-- begin +-- if Root = null then +-- pragma Assert (Tree.First = null); +-- pragma Assert (Tree.Last = null); +-- pragma Assert (Tree.Length = 0); +-- null; +-- +-- else +-- pragma Assert (Color (Root) = Black); +-- pragma Assert (Tree.Length > 0); +-- pragma Assert (Tree.Root /= null); +-- pragma Assert (Tree.First /= null); +-- pragma Assert (Tree.Last /= null); +-- pragma Assert (Parent (Tree.Root) = null); +-- pragma Assert ((Tree.Length > 1) +-- or else (Tree.First = Tree.Last +-- and Tree.First = Tree.Root)); +-- pragma Assert (Left (Tree.First) = null); +-- pragma Assert (Right (Tree.Last) = null); +-- +-- declare +-- L : constant Node_Access := Left (Root); +-- R : constant Node_Access := Right (Root); +-- NL : constant Natural := Check (L); +-- NR : constant Natural := Check (R); +-- begin +-- pragma Assert (NL = NR); +-- null; +-- end; +-- end if; +-- end Check_Invariant; + + ------------------ + -- Delete_Fixup -- + ------------------ + + procedure Delete_Fixup (Tree : in out Tree_Type; Node : Node_Access) is + + -- CLR p274 + + X : Node_Access := Node; + W : Node_Access; + + begin + while X /= Tree.Root + and then Color (X) = Black + loop + if X = Left (Parent (X)) then + W := Right (Parent (X)); + + if Color (W) = Red then + Set_Color (W, Black); + Set_Color (Parent (X), Red); + Left_Rotate (Tree, Parent (X)); + W := Right (Parent (X)); + end if; + + if (Left (W) = null or else Color (Left (W)) = Black) + and then + (Right (W) = null or else Color (Right (W)) = Black) + then + Set_Color (W, Red); + X := Parent (X); + + else + if Right (W) = null + or else Color (Right (W)) = Black + then + -- As a condition for setting the color of the left child to + -- black, the left child access value must be non-null. A + -- truth table analysis shows that if we arrive here, that + -- condition holds, so there's no need for an explicit test. + -- The assertion is here to document what we know is true. + + pragma Assert (Left (W) /= null); + Set_Color (Left (W), Black); + + Set_Color (W, Red); + Right_Rotate (Tree, W); + W := Right (Parent (X)); + end if; + + Set_Color (W, Color (Parent (X))); + Set_Color (Parent (X), Black); + Set_Color (Right (W), Black); + Left_Rotate (Tree, Parent (X)); + X := Tree.Root; + end if; + + else + pragma Assert (X = Right (Parent (X))); + + W := Left (Parent (X)); + + if Color (W) = Red then + Set_Color (W, Black); + Set_Color (Parent (X), Red); + Right_Rotate (Tree, Parent (X)); + W := Left (Parent (X)); + end if; + + if (Left (W) = null or else Color (Left (W)) = Black) + and then + (Right (W) = null or else Color (Right (W)) = Black) + then + Set_Color (W, Red); + X := Parent (X); + + else + if Left (W) = null or else Color (Left (W)) = Black then + + -- As a condition for setting the color of the right child + -- to black, the right child access value must be non-null. + -- A truth table analysis shows that if we arrive here, that + -- condition holds, so there's no need for an explicit test. + -- The assertion is here to document what we know is true. + + pragma Assert (Right (W) /= null); + Set_Color (Right (W), Black); + + Set_Color (W, Red); + Left_Rotate (Tree, W); + W := Left (Parent (X)); + end if; + + Set_Color (W, Color (Parent (X))); + Set_Color (Parent (X), Black); + Set_Color (Left (W), Black); + Right_Rotate (Tree, Parent (X)); + X := Tree.Root; + end if; + end if; + end loop; + + Set_Color (X, Black); + end Delete_Fixup; + + --------------------------- + -- Delete_Node_Sans_Free -- + --------------------------- + + procedure Delete_Node_Sans_Free + (Tree : in out Tree_Type; + Node : Node_Access) + is + -- CLR p273 + + X, Y : Node_Access; + + Z : constant Node_Access := Node; + pragma Assert (Z /= null); + + begin + if Tree.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (container is busy)"; + end if; + + -- Why are these all commented out ??? + +-- pragma Assert (Tree.Length > 0); +-- pragma Assert (Tree.Root /= null); +-- pragma Assert (Tree.First /= null); +-- pragma Assert (Tree.Last /= null); +-- pragma Assert (Parent (Tree.Root) = null); +-- pragma Assert ((Tree.Length > 1) +-- or else (Tree.First = Tree.Last +-- and then Tree.First = Tree.Root)); +-- pragma Assert ((Left (Node) = null) +-- or else (Parent (Left (Node)) = Node)); +-- pragma Assert ((Right (Node) = null) +-- or else (Parent (Right (Node)) = Node)); +-- pragma Assert (((Parent (Node) = null) and then (Tree.Root = Node)) +-- or else ((Parent (Node) /= null) and then +-- ((Left (Parent (Node)) = Node) +-- or else (Right (Parent (Node)) = Node)))); + + if Left (Z) = null then + if Right (Z) = null then + if Z = Tree.First then + Tree.First := Parent (Z); + end if; + + if Z = Tree.Last then + Tree.Last := Parent (Z); + end if; + + if Color (Z) = Black then + Delete_Fixup (Tree, Z); + end if; + + pragma Assert (Left (Z) = null); + pragma Assert (Right (Z) = null); + + if Z = Tree.Root then + pragma Assert (Tree.Length = 1); + pragma Assert (Parent (Z) = null); + Tree.Root := null; + elsif Z = Left (Parent (Z)) then + Set_Left (Parent (Z), null); + else + pragma Assert (Z = Right (Parent (Z))); + Set_Right (Parent (Z), null); + end if; + + else + pragma Assert (Z /= Tree.Last); + + X := Right (Z); + + if Z = Tree.First then + Tree.First := Min (X); + end if; + + if Z = Tree.Root then + Tree.Root := X; + elsif Z = Left (Parent (Z)) then + Set_Left (Parent (Z), X); + else + pragma Assert (Z = Right (Parent (Z))); + Set_Right (Parent (Z), X); + end if; + + Set_Parent (X, Parent (Z)); + + if Color (Z) = Black then + Delete_Fixup (Tree, X); + end if; + end if; + + elsif Right (Z) = null then + pragma Assert (Z /= Tree.First); + + X := Left (Z); + + if Z = Tree.Last then + Tree.Last := Max (X); + end if; + + if Z = Tree.Root then + Tree.Root := X; + elsif Z = Left (Parent (Z)) then + Set_Left (Parent (Z), X); + else + pragma Assert (Z = Right (Parent (Z))); + Set_Right (Parent (Z), X); + end if; + + Set_Parent (X, Parent (Z)); + + if Color (Z) = Black then + Delete_Fixup (Tree, X); + end if; + + else + pragma Assert (Z /= Tree.First); + pragma Assert (Z /= Tree.Last); + + Y := Next (Z); + pragma Assert (Left (Y) = null); + + X := Right (Y); + + if X = null then + if Y = Left (Parent (Y)) then + pragma Assert (Parent (Y) /= Z); + Delete_Swap (Tree, Z, Y); + Set_Left (Parent (Z), Z); + + else + pragma Assert (Y = Right (Parent (Y))); + pragma Assert (Parent (Y) = Z); + Set_Parent (Y, Parent (Z)); + + if Z = Tree.Root then + Tree.Root := Y; + elsif Z = Left (Parent (Z)) then + Set_Left (Parent (Z), Y); + else + pragma Assert (Z = Right (Parent (Z))); + Set_Right (Parent (Z), Y); + end if; + + Set_Left (Y, Left (Z)); + Set_Parent (Left (Y), Y); + Set_Right (Y, Z); + Set_Parent (Z, Y); + Set_Left (Z, null); + Set_Right (Z, null); + + declare + Y_Color : constant Color_Type := Color (Y); + begin + Set_Color (Y, Color (Z)); + Set_Color (Z, Y_Color); + end; + end if; + + if Color (Z) = Black then + Delete_Fixup (Tree, Z); + end if; + + pragma Assert (Left (Z) = null); + pragma Assert (Right (Z) = null); + + if Z = Right (Parent (Z)) then + Set_Right (Parent (Z), null); + else + pragma Assert (Z = Left (Parent (Z))); + Set_Left (Parent (Z), null); + end if; + + else + if Y = Left (Parent (Y)) then + pragma Assert (Parent (Y) /= Z); + + Delete_Swap (Tree, Z, Y); + + Set_Left (Parent (Z), X); + Set_Parent (X, Parent (Z)); + + else + pragma Assert (Y = Right (Parent (Y))); + pragma Assert (Parent (Y) = Z); + + Set_Parent (Y, Parent (Z)); + + if Z = Tree.Root then + Tree.Root := Y; + elsif Z = Left (Parent (Z)) then + Set_Left (Parent (Z), Y); + else + pragma Assert (Z = Right (Parent (Z))); + Set_Right (Parent (Z), Y); + end if; + + Set_Left (Y, Left (Z)); + Set_Parent (Left (Y), Y); + + declare + Y_Color : constant Color_Type := Color (Y); + begin + Set_Color (Y, Color (Z)); + Set_Color (Z, Y_Color); + end; + end if; + + if Color (Z) = Black then + Delete_Fixup (Tree, X); + end if; + end if; + end if; + + Tree.Length := Tree.Length - 1; + end Delete_Node_Sans_Free; + + ----------------- + -- Delete_Swap -- + ----------------- + + procedure Delete_Swap + (Tree : in out Tree_Type; + Z, Y : Node_Access) + is + pragma Assert (Z /= Y); + pragma Assert (Parent (Y) /= Z); + + Y_Parent : constant Node_Access := Parent (Y); + Y_Color : constant Color_Type := Color (Y); + + begin + Set_Parent (Y, Parent (Z)); + Set_Left (Y, Left (Z)); + Set_Right (Y, Right (Z)); + Set_Color (Y, Color (Z)); + + if Tree.Root = Z then + Tree.Root := Y; + elsif Right (Parent (Y)) = Z then + Set_Right (Parent (Y), Y); + else + pragma Assert (Left (Parent (Y)) = Z); + Set_Left (Parent (Y), Y); + end if; + + if Right (Y) /= null then + Set_Parent (Right (Y), Y); + end if; + + if Left (Y) /= null then + Set_Parent (Left (Y), Y); + end if; + + Set_Parent (Z, Y_Parent); + Set_Color (Z, Y_Color); + Set_Left (Z, null); + Set_Right (Z, null); + end Delete_Swap; + + -------------------- + -- Generic_Adjust -- + -------------------- + + procedure Generic_Adjust (Tree : in out Tree_Type) is + N : constant Count_Type := Tree.Length; + Root : constant Node_Access := Tree.Root; + + begin + if N = 0 then + pragma Assert (Root = null); + pragma Assert (Tree.Busy = 0); + pragma Assert (Tree.Lock = 0); + return; + end if; + + Tree.Root := null; + Tree.First := null; + Tree.Last := null; + Tree.Length := 0; + + Tree.Root := Copy_Tree (Root); + Tree.First := Min (Tree.Root); + Tree.Last := Max (Tree.Root); + Tree.Length := N; + end Generic_Adjust; + + ------------------- + -- Generic_Clear -- + ------------------- + + procedure Generic_Clear (Tree : in out Tree_Type) is + Root : Node_Access := Tree.Root; + begin + if Tree.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (container is busy)"; + end if; + + Tree := (First => null, + Last => null, + Root => null, + Length => 0, + Busy => 0, + Lock => 0); + + Delete_Tree (Root); + end Generic_Clear; + + ----------------------- + -- Generic_Copy_Tree -- + ----------------------- + + function Generic_Copy_Tree (Source_Root : Node_Access) return Node_Access is + Target_Root : Node_Access := Copy_Node (Source_Root); + P, X : Node_Access; + + begin + if Right (Source_Root) /= null then + Set_Right + (Node => Target_Root, + Right => Generic_Copy_Tree (Right (Source_Root))); + + Set_Parent + (Node => Right (Target_Root), + Parent => Target_Root); + end if; + + P := Target_Root; + + X := Left (Source_Root); + while X /= null loop + declare + Y : constant Node_Access := Copy_Node (X); + begin + Set_Left (Node => P, Left => Y); + Set_Parent (Node => Y, Parent => P); + + if Right (X) /= null then + Set_Right + (Node => Y, + Right => Generic_Copy_Tree (Right (X))); + + Set_Parent + (Node => Right (Y), + Parent => Y); + end if; + + P := Y; + X := Left (X); + end; + end loop; + + return Target_Root; + exception + when others => + Delete_Tree (Target_Root); + raise; + end Generic_Copy_Tree; + + ------------------------- + -- Generic_Delete_Tree -- + ------------------------- + + procedure Generic_Delete_Tree (X : in out Node_Access) is + Y : Node_Access; + pragma Warnings (Off, Y); + begin + while X /= null loop + Y := Right (X); + Generic_Delete_Tree (Y); + Y := Left (X); + Free (X); + X := Y; + end loop; + end Generic_Delete_Tree; + + ------------------- + -- Generic_Equal -- + ------------------- + + function Generic_Equal (Left, Right : Tree_Type) return Boolean is + L_Node : Node_Access; + R_Node : Node_Access; + + begin + if Left'Address = Right'Address then + return True; + end if; + + if Left.Length /= Right.Length then + return False; + end if; + + L_Node := Left.First; + R_Node := Right.First; + while L_Node /= null loop + if not Is_Equal (L_Node, R_Node) then + return False; + end if; + + L_Node := Next (L_Node); + R_Node := Next (R_Node); + end loop; + + return True; + end Generic_Equal; + + ----------------------- + -- Generic_Iteration -- + ----------------------- + + procedure Generic_Iteration (Tree : Tree_Type) is + procedure Iterate (P : Node_Access); + + ------------- + -- Iterate -- + ------------- + + procedure Iterate (P : Node_Access) is + X : Node_Access := P; + begin + while X /= null loop + Iterate (Left (X)); + Process (X); + X := Right (X); + end loop; + end Iterate; + + -- Start of processing for Generic_Iteration + + begin + Iterate (Tree.Root); + end Generic_Iteration; + + ------------------ + -- Generic_Move -- + ------------------ + + procedure Generic_Move (Target, Source : in out Tree_Type) is + begin + if Target'Address = Source'Address then + return; + end if; + + if Source.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (container is busy)"; + end if; + + Clear (Target); + + Target := Source; + + Source := (First => null, + Last => null, + Root => null, + Length => 0, + Busy => 0, + Lock => 0); + end Generic_Move; + + ------------------ + -- Generic_Read -- + ------------------ + + procedure Generic_Read + (Stream : not null access Root_Stream_Type'Class; + Tree : in out Tree_Type) + is + N : Count_Type'Base; + + Node, Last_Node : Node_Access; + + begin + Clear (Tree); + + Count_Type'Base'Read (Stream, N); + pragma Assert (N >= 0); + + if N = 0 then + return; + end if; + + Node := Read_Node (Stream); + pragma Assert (Node /= null); + pragma Assert (Color (Node) = Red); + + Set_Color (Node, Black); + + Tree.Root := Node; + Tree.First := Node; + Tree.Last := Node; + + Tree.Length := 1; + + for J in Count_Type range 2 .. N loop + Last_Node := Node; + pragma Assert (Last_Node = Tree.Last); + + Node := Read_Node (Stream); + pragma Assert (Node /= null); + pragma Assert (Color (Node) = Red); + + Set_Right (Node => Last_Node, Right => Node); + Tree.Last := Node; + Set_Parent (Node => Node, Parent => Last_Node); + Rebalance_For_Insert (Tree, Node); + Tree.Length := Tree.Length + 1; + end loop; + end Generic_Read; + + ------------------------------- + -- Generic_Reverse_Iteration -- + ------------------------------- + + procedure Generic_Reverse_Iteration (Tree : Tree_Type) + is + procedure Iterate (P : Node_Access); + + ------------- + -- Iterate -- + ------------- + + procedure Iterate (P : Node_Access) is + X : Node_Access := P; + begin + while X /= null loop + Iterate (Right (X)); + Process (X); + X := Left (X); + end loop; + end Iterate; + + -- Start of processing for Generic_Reverse_Iteration + + begin + Iterate (Tree.Root); + end Generic_Reverse_Iteration; + + ------------------- + -- Generic_Write -- + ------------------- + + procedure Generic_Write + (Stream : not null access Root_Stream_Type'Class; + Tree : Tree_Type) + is + procedure Process (Node : Node_Access); + pragma Inline (Process); + + procedure Iterate is + new Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + + procedure Process (Node : Node_Access) is + begin + Write_Node (Stream, Node); + end Process; + + -- Start of processing for Generic_Write + + begin + Count_Type'Base'Write (Stream, Tree.Length); + Iterate (Tree); + end Generic_Write; + + ----------------- + -- Left_Rotate -- + ----------------- + + procedure Left_Rotate (Tree : in out Tree_Type; X : Node_Access) is + + -- CLR p266 + + Y : constant Node_Access := Right (X); + pragma Assert (Y /= null); + + begin + Set_Right (X, Left (Y)); + + if Left (Y) /= null then + Set_Parent (Left (Y), X); + end if; + + Set_Parent (Y, Parent (X)); + + if X = Tree.Root then + Tree.Root := Y; + elsif X = Left (Parent (X)) then + Set_Left (Parent (X), Y); + else + pragma Assert (X = Right (Parent (X))); + Set_Right (Parent (X), Y); + end if; + + Set_Left (Y, X); + Set_Parent (X, Y); + end Left_Rotate; + + --------- + -- Max -- + --------- + + function Max (Node : Node_Access) return Node_Access is + + -- CLR p248 + + X : Node_Access := Node; + Y : Node_Access; + + begin + loop + Y := Right (X); + + if Y = null then + return X; + end if; + + X := Y; + end loop; + end Max; + + --------- + -- Min -- + --------- + + function Min (Node : Node_Access) return Node_Access is + + -- CLR p248 + + X : Node_Access := Node; + Y : Node_Access; + + begin + loop + Y := Left (X); + + if Y = null then + return X; + end if; + + X := Y; + end loop; + end Min; + + ---------- + -- Next -- + ---------- + + function Next (Node : Node_Access) return Node_Access is + begin + -- CLR p249 + + if Node = null then + return null; + end if; + + if Right (Node) /= null then + return Min (Right (Node)); + end if; + + declare + X : Node_Access := Node; + Y : Node_Access := Parent (Node); + + begin + while Y /= null + and then X = Right (Y) + loop + X := Y; + Y := Parent (Y); + end loop; + + return Y; + end; + end Next; + + -------------- + -- Previous -- + -------------- + + function Previous (Node : Node_Access) return Node_Access is + begin + if Node = null then + return null; + end if; + + if Left (Node) /= null then + return Max (Left (Node)); + end if; + + declare + X : Node_Access := Node; + Y : Node_Access := Parent (Node); + + begin + while Y /= null + and then X = Left (Y) + loop + X := Y; + Y := Parent (Y); + end loop; + + return Y; + end; + end Previous; + + -------------------------- + -- Rebalance_For_Insert -- + -------------------------- + + procedure Rebalance_For_Insert + (Tree : in out Tree_Type; + Node : Node_Access) + is + -- CLR p.268 + + X : Node_Access := Node; + pragma Assert (X /= null); + pragma Assert (Color (X) = Red); + + Y : Node_Access; + + begin + while X /= Tree.Root and then Color (Parent (X)) = Red loop + if Parent (X) = Left (Parent (Parent (X))) then + Y := Right (Parent (Parent (X))); + + if Y /= null and then Color (Y) = Red then + Set_Color (Parent (X), Black); + Set_Color (Y, Black); + Set_Color (Parent (Parent (X)), Red); + X := Parent (Parent (X)); + + else + if X = Right (Parent (X)) then + X := Parent (X); + Left_Rotate (Tree, X); + end if; + + Set_Color (Parent (X), Black); + Set_Color (Parent (Parent (X)), Red); + Right_Rotate (Tree, Parent (Parent (X))); + end if; + + else + pragma Assert (Parent (X) = Right (Parent (Parent (X)))); + + Y := Left (Parent (Parent (X))); + + if Y /= null and then Color (Y) = Red then + Set_Color (Parent (X), Black); + Set_Color (Y, Black); + Set_Color (Parent (Parent (X)), Red); + X := Parent (Parent (X)); + + else + if X = Left (Parent (X)) then + X := Parent (X); + Right_Rotate (Tree, X); + end if; + + Set_Color (Parent (X), Black); + Set_Color (Parent (Parent (X)), Red); + Left_Rotate (Tree, Parent (Parent (X))); + end if; + end if; + end loop; + + Set_Color (Tree.Root, Black); + end Rebalance_For_Insert; + + ------------------ + -- Right_Rotate -- + ------------------ + + procedure Right_Rotate (Tree : in out Tree_Type; Y : Node_Access) is + X : constant Node_Access := Left (Y); + pragma Assert (X /= null); + + begin + Set_Left (Y, Right (X)); + + if Right (X) /= null then + Set_Parent (Right (X), Y); + end if; + + Set_Parent (X, Parent (Y)); + + if Y = Tree.Root then + Tree.Root := X; + elsif Y = Left (Parent (Y)) then + Set_Left (Parent (Y), X); + else + pragma Assert (Y = Right (Parent (Y))); + Set_Right (Parent (Y), X); + end if; + + Set_Right (X, Y); + Set_Parent (Y, X); + end Right_Rotate; + + --------- + -- Vet -- + --------- + + function Vet (Tree : Tree_Type; Node : Node_Access) return Boolean is + begin + if Node = null then + return True; + end if; + + if Parent (Node) = Node + or else Left (Node) = Node + or else Right (Node) = Node + then + return False; + end if; + + if Tree.Length = 0 + or else Tree.Root = null + or else Tree.First = null + or else Tree.Last = null + then + return False; + end if; + + if Parent (Tree.Root) /= null then + return False; + end if; + + if Left (Tree.First) /= null then + return False; + end if; + + if Right (Tree.Last) /= null then + return False; + end if; + + if Tree.Length = 1 then + if Tree.First /= Tree.Last + or else Tree.First /= Tree.Root + then + return False; + end if; + + if Node /= Tree.First then + return False; + end if; + + if Parent (Node) /= null + or else Left (Node) /= null + or else Right (Node) /= null + then + return False; + end if; + + return True; + end if; + + if Tree.First = Tree.Last then + return False; + end if; + + if Tree.Length = 2 then + if Tree.First /= Tree.Root + and then Tree.Last /= Tree.Root + then + return False; + end if; + + if Tree.First /= Node + and then Tree.Last /= Node + then + return False; + end if; + end if; + + if Left (Node) /= null + and then Parent (Left (Node)) /= Node + then + return False; + end if; + + if Right (Node) /= null + and then Parent (Right (Node)) /= Node + then + return False; + end if; + + if Parent (Node) = null then + if Tree.Root /= Node then + return False; + end if; + + elsif Left (Parent (Node)) /= Node + and then Right (Parent (Node)) /= Node + then + return False; + end if; + + return True; + end Vet; + +end Ada.Containers.Red_Black_Trees.Generic_Operations; -- cgit v1.2.3