URL https://opencores.org/ocsvn/openrisc/openrisc/trunk
Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [a-crbtgo.adb] - Blame information for rev 729

Go to most recent revision | Details | Compare with Previous | View Log

------------------------------------------------------------------------------
--                                                                          --
--                         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    --
-- <http://www.gnu.org/licenses/>.                                          --
--                                                                          --
-- 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;
Browse

Tools

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [a-crbtgo.adb] - Blame information for rev 729

Line No.	Rev	Author	Line
1	706	jeremybenn	`------------------------------------------------------------------------------`
2			`-- --`
3			`-- GNAT LIBRARY COMPONENTS --`
4			`-- --`
5			`-- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_OPERATIONS --`
6			`-- --`
7			`-- B o d y --`
8			`-- --`
9			`-- Copyright (C) 2004-2009, 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			`-- 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. --`
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			`-- 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)`
35			`-- ISBN: 0262031418`
36
37			`with System; use type System.Address;`
38
39			`package body Ada.Containers.Red_Black_Trees.Generic_Operations is`
40