aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.2.1/gcc/ada/a-crbtgo.adb
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.2.1/gcc/ada/a-crbtgo.adb')
-rw-r--r--gcc-4.2.1/gcc/ada/a-crbtgo.adb1155
1 files changed, 1155 insertions, 0 deletions
diff --git a/gcc-4.2.1/gcc/ada/a-crbtgo.adb b/gcc-4.2.1/gcc/ada/a-crbtgo.adb
new file mode 100644
index 000000000..b0b7ca09b
--- /dev/null
+++ b/gcc-4.2.1/gcc/ada/a-crbtgo.adb
@@ -0,0 +1,1155 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- A D A . C O N T A I N E R S . R E D _ B L A C K _ T R E E S . --
+-- G E N E R I C _ O P E R A T I O N S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
+-- --
+-- 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 2, 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. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
+-- Boston, MA 02110-1301, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- This unit was originally developed by Matthew J Heaney. --
+------------------------------------------------------------------------------
+
+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);
+
+-- ---------------------
+-- -- 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
+ if Left (W) /= null then
+ Set_Color (Left (W), Black);
+ end if;
+
+ 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
+ if Right (W) /= null then
+ Set_Color (Right (W), Black);
+ end if;
+
+ 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;
+
+-- 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;
+ 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 : 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 : 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;
+
+ -- Why is this code commented out ???
+
+-- if Right (X) /= Y then
+-- return Y;
+-- else
+-- return X;
+-- end if;
+
+ 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;
+
+ -- Why is this code commented out ???
+
+-- if Left (X) /= Y then
+-- return Y;
+-- else
+-- return X;
+-- end if;
+
+ 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;