diff options
Diffstat (limited to 'gcc/ada/a-crbtgo.adb')
| -rw-r--r-- | gcc/ada/a-crbtgo.adb | 879 |
1 files changed, 879 insertions, 0 deletions
diff --git a/gcc/ada/a-crbtgo.adb b/gcc/ada/a-crbtgo.adb new file mode 100644 index 00000000000..9f9b7125c6f --- /dev/null +++ b/gcc/ada/a-crbtgo.adb @@ -0,0 +1,879 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_OPERATIONS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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. -- +------------------------------------------------------------------------------ + +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_Node then + return 0; + end if; + + if Color (Node) = Red then + declare + L : constant Node_Access := Left (Node); + begin + pragma Assert (L = Null_Node or else Color (L) = Black); + null; + end; + + declare + R : constant Node_Access := Right (Node); + begin + pragma Assert (R = Null_Node 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_Node then + pragma Assert (Tree.First = Null_Node); + pragma Assert (Tree.Last = Null_Node); + pragma Assert (Tree.Length = 0); + null; + + else + pragma Assert (Color (Root) = Black); + pragma Assert (Tree.Length > 0); + pragma Assert (Tree.Root /= Null_Node); + pragma Assert (Tree.First /= Null_Node); + pragma Assert (Tree.Last /= Null_Node); + pragma Assert (Parent (Tree.Root) = Null_Node); + pragma Assert ((Tree.Length > 1) + or else (Tree.First = Tree.Last + and Tree.First = Tree.Root)); + pragma Assert (Left (Tree.First) = Null_Node); + pragma Assert (Right (Tree.Last) = Null_Node); + + 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_Node or else Color (Left (W)) = Black) + and then + (Right (W) = Null_Node or else Color (Right (W)) = Black) + then + Set_Color (W, Red); + X := Parent (X); + + else + if Right (W) = Null_Node + or else Color (Right (W)) = Black + then + if Left (W) /= Null_Node 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_Node or else Color (Left (W)) = Black) + and then + (Right (W) = Null_Node or else Color (Right (W)) = Black) + then + Set_Color (W, Red); + X := Parent (X); + + else + if Left (W) = Null_Node or else Color (Left (W)) = Black then + if Right (W) /= Null_Node 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_Node); + + begin + pragma Assert (Tree.Length > 0); + pragma Assert (Tree.Root /= Null_Node); + pragma Assert (Tree.First /= Null_Node); + pragma Assert (Tree.Last /= Null_Node); + pragma Assert (Parent (Tree.Root) = Null_Node); + pragma Assert ((Tree.Length > 1) + or else (Tree.First = Tree.Last + and then Tree.First = Tree.Root)); + pragma Assert ((Left (Node) = Null_Node) + or else (Parent (Left (Node)) = Node)); + pragma Assert ((Right (Node) = Null_Node) + or else (Parent (Right (Node)) = Node)); + pragma Assert (((Parent (Node) = Null_Node) and then (Tree.Root = Node)) + or else ((Parent (Node) /= Null_Node) and then + ((Left (Parent (Node)) = Node) + or else (Right (Parent (Node)) = Node)))); + + if Left (Z) = Null_Node then + if Right (Z) = Null_Node 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_Node); + pragma Assert (Right (Z) = Null_Node); + + if Z = Tree.Root then + pragma Assert (Tree.Length = 1); + pragma Assert (Parent (Z) = Null_Node); + Tree.Root := Null_Node; + elsif Z = Left (Parent (Z)) then + Set_Left (Parent (Z), Null_Node); + else + pragma Assert (Z = Right (Parent (Z))); + Set_Right (Parent (Z), Null_Node); + 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_Node 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_Node); + + X := Right (Y); + + if X = Null_Node 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_Node); + Set_Right (Z, Null_Node); + + 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_Node); + pragma Assert (Right (Z) = Null_Node); + + if Z = Right (Parent (Z)) then + Set_Right (Parent (Z), Null_Node); + else + pragma Assert (Z = Left (Parent (Z))); + Set_Left (Parent (Z), Null_Node); + 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_Node then + Set_Parent (Right (Y), Y); + end if; + + if Left (Y) /= Null_Node then + Set_Parent (Left (Y), Y); + end if; + + Set_Parent (Z, Y_Parent); + Set_Color (Z, Y_Color); + Set_Left (Z, Null_Node); + Set_Right (Z, Null_Node); + end Delete_Swap; + + ------------------- + -- Generic_Equal -- + ------------------- + + function Generic_Equal (Left, Right : Tree_Type) return Boolean is + L_Node : Node_Access; + R_Node : Node_Access; + + begin + if Left.Length /= Right.Length then + return False; + end if; + + L_Node := Left.First; + R_Node := Right.First; + while L_Node /= Null_Node 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_Node 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_Read -- + ------------------ + + procedure Generic_Read (Tree : in out Tree_Type; N : Count_Type) is + + pragma Assert (Tree.Length = 0); + -- Clear and back node reinit was done by caller + + Node, Last_Node : Node_Access; + + begin + if N = 0 then + return; + end if; + + Node := New_Node; + pragma Assert (Node /= Null_Node); + 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 := New_Node; + pragma Assert (Node /= Null_Node); + 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_Node 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; + + ----------------- + -- 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_Node); + + begin + Set_Right (X, Left (Y)); + + if Left (Y) /= Null_Node 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_Node 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_Node then + return X; + end if; + + X := Y; + end loop; + end Min; + + ---------- + -- Move -- + ---------- + + procedure Move (Target, Source : in out Tree_Type) is + begin + if Target.Length > 0 then + raise Constraint_Error; + end if; + + Target := Source; + Source := (First => Null_Node, + Last => Null_Node, + Root => Null_Node, + Length => 0); + end Move; + + ---------- + -- Next -- + ---------- + + function Next (Node : Node_Access) return Node_Access is + begin + -- CLR p249 ??? + + if Node = Null_Node then + return Null_Node; + end if; + + if Right (Node) /= Null_Node then + return Min (Right (Node)); + end if; + + declare + X : Node_Access := Node; + Y : Node_Access := Parent (Node); + + begin + while Y /= Null_Node + 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_Node then + return Null_Node; + end if; + + if Left (Node) /= Null_Node then + return Max (Left (Node)); + end if; + + declare + X : Node_Access := Node; + Y : Node_Access := Parent (Node); + + begin + while Y /= Null_Node + 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_Node); + 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_Node 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_Node 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_Node); + + begin + Set_Left (Y, Right (X)); + + if Right (X) /= Null_Node 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; + +end Ada.Containers.Red_Black_Trees.Generic_Operations; |