Subversion Repositories openrisc

------------------------------------------------------------------------------

--                                                                          --

--                         GNAT LIBRARY COMPONENTS                          --

--                                                                          --

--         ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_BOUNDED_OPERATIONS        --

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

--          Copyright (C) 2004-2011, 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_Bounded_Operations is

   -----------------------

   -- Local Subprograms --

   -----------------------

   procedure Delete_Fixup (Tree : in out Tree_Type'Class; Node : Count_Type);

   procedure Delete_Swap (Tree : in out Tree_Type'Class; Z, Y : Count_Type);

   procedure Left_Rotate  (Tree : in out Tree_Type'Class; X : Count_Type);

   procedure Right_Rotate (Tree : in out Tree_Type'Class; Y : Count_Type);

   ----------------

   -- Clear_Tree --

   ----------------

   procedure Clear_Tree (Tree : in out Tree_Type'Class) is

   begin

      if Tree.Busy > 0 then

         raise Program_Error with

           "attempt to tamper with cursors (container is busy)";

      end if;

      --  The lock status (which monitors "element tampering") always implies

      --  that the busy status (which monitors "cursor tampering") is set too;

      --  this is a representation invariant. Thus if the busy bit is not set,

      --  then the lock bit must not be set either.

      pragma Assert (Tree.Lock = 0);

      Tree.First  := 0;

      Tree.Last   := 0;

      Tree.Root   := 0;

      Tree.Length := 0;

      Tree.Free   := -1;

   end Clear_Tree;

   ------------------

   -- Delete_Fixup --

   ------------------

   procedure Delete_Fixup

     (Tree : in out Tree_Type'Class;

      Node : Count_Type)

   is

      --  CLR p. 274

      X : Count_Type;

      W : Count_Type;

      N : Nodes_Type renames Tree.Nodes;

   begin

      X := Node;

      while X /= Tree.Root

        and then Color (N (X)) = Black

      loop

         if X = Left (N (Parent (N (X)))) then

            W :=  Right (N (Parent (N (X))));

            if Color (N (W)) = Red then

               Set_Color (N (W), Black);

               Set_Color (N (Parent (N (X))), Red);

               Left_Rotate (Tree, Parent (N (X)));

               W := Right (N (Parent (N (X))));

            end if;

            if (Left (N (W))  = 0 or else Color (N (Left (N (W)))) = Black)

              and then

               (Right (N (W)) = 0 or else Color (N (Right (N (W)))) = Black)

            then

               Set_Color (N (W), Red);

               X := Parent (N (X));

            else

               if Right (N (W)) = 0

                 or else Color (N (Right (N (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 (N (W)) /= 0);

                  Set_Color (N (Left (N (W))), Black);

                  Set_Color (N (W), Red);

                  Right_Rotate (Tree, W);

                  W := Right (N (Parent (N (X))));

               end if;

               Set_Color (N (W), Color (N (Parent (N (X)))));

               Set_Color (N (Parent (N (X))), Black);

               Set_Color (N (Right (N (W))), Black);

               Left_Rotate  (Tree, Parent (N (X)));

               X := Tree.Root;

            end if;

         else

            pragma Assert (X = Right (N (Parent (N (X)))));

            W :=  Left (N (Parent (N (X))));

            if Color (N (W)) = Red then

               Set_Color (N (W), Black);

               Set_Color (N (Parent (N (X))), Red);

               Right_Rotate (Tree, Parent (N (X)));

               W := Left (N (Parent (N (X))));

            end if;

            if (Left (N (W))  = 0 or else Color (N (Left (N (W)))) = Black)

                 and then

               (Right (N (W)) = 0 or else Color (N (Right (N (W)))) = Black)

            then

               Set_Color (N (W), Red);

               X := Parent (N (X));

            else

               if Left (N (W)) = 0

                 or else Color (N (Left (N (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 (N (W)) /= 0);

                  Set_Color (N (Right (N (W))), Black);

                  Set_Color (N (W), Red);

                  Left_Rotate (Tree, W);

                  W := Left (N (Parent (N (X))));

               end if;

               Set_Color (N (W), Color (N (Parent (N (X)))));

               Set_Color (N (Parent (N (X))), Black);

               Set_Color (N (Left (N (W))), Black);

               Right_Rotate (Tree, Parent (N (X)));

               X := Tree.Root;

            end if;

         end if;

      end loop;

      Set_Color (N (X), Black);

   end Delete_Fixup;

   ---------------------------

   -- Delete_Node_Sans_Free --

   ---------------------------

   procedure Delete_Node_Sans_Free

     (Tree : in out Tree_Type'Class;

      Node : Count_Type)

   is

      --  CLR p. 273

      X, Y : Count_Type;

      Z : constant Count_Type := Node;

      pragma Assert (Z /= 0);

      N : Nodes_Type renames Tree.Nodes;

   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  /= 0);

      pragma Assert (Tree.First /= 0);

      pragma Assert (Tree.Last  /= 0);

      pragma Assert (Parent (N (Tree.Root)) = 0);

      pragma Assert ((Tree.Length > 1)

                        or else (Tree.First = Tree.Last

                                   and then Tree.First = Tree.Root));

      pragma Assert ((Left (N (Node)) = 0)

                        or else (Parent (N (Left (N (Node)))) = Node));

      pragma Assert ((Right (N (Node)) = 0)

                        or else (Parent (N (Right (N (Node)))) = Node));

      pragma Assert (((Parent (N (Node)) = 0) and then (Tree.Root = Node))

                        or else ((Parent (N (Node)) /= 0) and then

                                  ((Left (N (Parent (N (Node)))) = Node)

                                      or else

                                   (Right (N (Parent (N (Node)))) = Node))));

      if Left (N (Z)) = 0 then

         if Right (N (Z)) = 0 then

            if Z = Tree.First then

               Tree.First := Parent (N (Z));

            end if;

            if Z = Tree.Last then

               Tree.Last := Parent (N (Z));

            end if;

            if Color (N (Z)) = Black then

               Delete_Fixup (Tree, Z);

            end if;

            pragma Assert (Left (N (Z)) = 0);

            pragma Assert (Right (N (Z)) = 0);

            if Z = Tree.Root then

               pragma Assert (Tree.Length = 1);

               pragma Assert (Parent (N (Z)) = 0);

               Tree.Root := 0;

            elsif Z = Left (N (Parent (N (Z)))) then

               Set_Left (N (Parent (N (Z))), 0);

            else

               pragma Assert (Z = Right (N (Parent (N (Z)))));

               Set_Right (N (Parent (N (Z))), 0);

            end if;

         else

            pragma Assert (Z /= Tree.Last);

            X := Right (N (Z));

            if Z = Tree.First then

               Tree.First := Min (Tree, X);

            end if;

            if Z = Tree.Root then

               Tree.Root := X;

            elsif Z = Left (N (Parent (N (Z)))) then

               Set_Left (N (Parent (N (Z))), X);

            else

               pragma Assert (Z = Right (N (Parent (N (Z)))));

               Set_Right (N (Parent (N (Z))), X);

            end if;

            Set_Parent (N (X), Parent (N (Z)));

            if Color (N (Z)) = Black then

               Delete_Fixup (Tree, X);

            end if;

         end if;

      elsif Right (N (Z)) = 0 then

         pragma Assert (Z /= Tree.First);

         X := Left (N (Z));

         if Z = Tree.Last then

            Tree.Last := Max (Tree, X);

         end if;

         if Z = Tree.Root then

            Tree.Root := X;

         elsif Z = Left (N (Parent (N (Z)))) then

            Set_Left (N (Parent (N (Z))), X);

         else

            pragma Assert (Z = Right (N (Parent (N (Z)))));

            Set_Right (N (Parent (N (Z))), X);

         end if;

         Set_Parent (N (X), Parent (N (Z)));

         if Color (N (Z)) = Black then

            Delete_Fixup (Tree, X);

         end if;

      else

         pragma Assert (Z /= Tree.First);

         pragma Assert (Z /= Tree.Last);

         Y := Next (Tree, Z);

         pragma Assert (Left (N (Y)) = 0);

         X := Right (N (Y));

         if X = 0 then

            if Y = Left (N (Parent (N (Y)))) then

               pragma Assert (Parent (N (Y)) /= Z);

               Delete_Swap (Tree, Z, Y);

               Set_Left (N (Parent (N (Z))), Z);

            else

               pragma Assert (Y = Right (N (Parent (N (Y)))));

               pragma Assert (Parent (N (Y)) = Z);

               Set_Parent (N (Y), Parent (N (Z)));

               if Z = Tree.Root then

                  Tree.Root := Y;

               elsif Z = Left (N (Parent (N (Z)))) then

                  Set_Left (N (Parent (N (Z))), Y);

               else

                  pragma Assert (Z = Right (N (Parent (N (Z)))));

                  Set_Right (N (Parent (N (Z))), Y);

               end if;

               Set_Left   (N (Y), Left (N (Z)));

               Set_Parent (N (Left (N (Y))), Y);

               Set_Right  (N (Y), Z);

               Set_Parent (N (Z), Y);

               Set_Left   (N (Z), 0);

               Set_Right  (N (Z), 0);

               declare

                  Y_Color : constant Color_Type := Color (N (Y));

               begin

                  Set_Color (N (Y), Color (N (Z)));

                  Set_Color (N (Z), Y_Color);

               end;

            end if;

            if Color (N (Z)) = Black then

               Delete_Fixup (Tree, Z);

            end if;

            pragma Assert (Left (N (Z)) = 0);

            pragma Assert (Right (N (Z)) = 0);

            if Z = Right (N (Parent (N (Z)))) then

               Set_Right (N (Parent (N (Z))), 0);

            else

               pragma Assert (Z = Left (N (Parent (N (Z)))));

               Set_Left (N (Parent (N (Z))), 0);

            end if;

         else

            if Y = Left (N (Parent (N (Y)))) then

               pragma Assert (Parent (N (Y)) /= Z);

               Delete_Swap (Tree, Z, Y);

               Set_Left (N (Parent (N (Z))), X);

               Set_Parent (N (X), Parent (N (Z)));

            else

               pragma Assert (Y = Right (N (Parent (N (Y)))));

               pragma Assert (Parent (N (Y)) = Z);

               Set_Parent (N (Y), Parent (N (Z)));

               if Z = Tree.Root then

                  Tree.Root := Y;

               elsif Z = Left (N (Parent (N (Z)))) then

                  Set_Left (N (Parent (N (Z))), Y);

               else

                  pragma Assert (Z = Right (N (Parent (N (Z)))));

                  Set_Right (N (Parent (N (Z))), Y);

               end if;

               Set_Left (N (Y), Left (N (Z)));

               Set_Parent (N (Left (N (Y))), Y);

               declare

                  Y_Color : constant Color_Type := Color (N (Y));

               begin

                  Set_Color (N (Y), Color (N (Z)));

                  Set_Color (N (Z), Y_Color);

               end;

            end if;

            if Color (N (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'Class;

      Z, Y : Count_Type)

   is

      N : Nodes_Type renames Tree.Nodes;

      pragma Assert (Z /= Y);

      pragma Assert (Parent (N (Y)) /= Z);

      Y_Parent : constant Count_Type := Parent (N (Y));

      Y_Color  : constant Color_Type := Color (N (Y));

   begin

      Set_Parent (N (Y), Parent (N (Z)));

      Set_Left   (N (Y), Left   (N (Z)));

      Set_Right  (N (Y), Right  (N (Z)));

      Set_Color  (N (Y), Color  (N (Z)));

      if Tree.Root = Z then

         Tree.Root := Y;

      elsif Right (N (Parent (N (Y)))) = Z then

         Set_Right (N (Parent (N (Y))), Y);

      else

         pragma Assert (Left (N (Parent (N (Y)))) = Z);

         Set_Left (N (Parent (N (Y))), Y);

      end if;

      if Right (N (Y)) /= 0 then

         Set_Parent (N (Right (N (Y))), Y);

      end if;

      if Left (N (Y)) /= 0 then

         Set_Parent (N (Left (N (Y))), Y);

      end if;

      Set_Parent (N (Z), Y_Parent);

      Set_Color  (N (Z), Y_Color);

      Set_Left   (N (Z), 0);

      Set_Right  (N (Z), 0);

   end Delete_Swap;

   ----------

   -- Free --

   ----------

   procedure Free (Tree : in out Tree_Type'Class; X : Count_Type) is

      pragma Assert (X > 0);

      pragma Assert (X <= Tree.Capacity);

      N : Nodes_Type renames Tree.Nodes;

      --  pragma Assert (N (X).Prev >= 0);  -- node is active

      --  Find a way to mark a node as active vs. inactive; we could

      --  use a special value in Color_Type for this.  ???

   begin

      --  The set container actually contains two data structures: a list for

      --  the "active" nodes that contain elements that have been inserted

      --  onto the tree, and another for the "inactive" nodes of the free

      --  store.

      --

      --  We desire that merely declaring an object should have only minimal

      --  cost; specially, we want to avoid having to initialize the free

      --  store (to fill in the links), especially if the capacity is large.

      --

      --  The head of the free list is indicated by Container.Free. If its

      --  value is non-negative, then the free store has been initialized

      --  in the "normal" way: Container.Free points to the head of the list

      --  of free (inactive) nodes, and the value 0 means the free list is

      --  empty. Each node on the free list has been initialized to point

      --  to the next free node (via its Parent component), and the value 0

      --  means that this is the last free node.

      --

      --  If Container.Free is negative, then the links on the free store

      --  have not been initialized. In this case the link values are

      --  implied: the free store comprises the components of the node array

      --  started with the absolute value of Container.Free, and continuing

      --  until the end of the array (Nodes'Last).

      --

      --  ???

      --  It might be possible to perform an optimization here. Suppose that

      --  the free store can be represented as having two parts: one

      --  comprising the non-contiguous inactive nodes linked together

      --  in the normal way, and the other comprising the contiguous

      --  inactive nodes (that are not linked together, at the end of the

      --  nodes array). This would allow us to never have to initialize

      --  the free store, except in a lazy way as nodes become inactive.

      --  When an element is deleted from the list container, its node

      --  becomes inactive, and so we set its Prev component to a negative

      --  value, to indicate that it is now inactive. This provides a useful

      --  way to detect a dangling cursor reference.

      --  The comment above is incorrect; we need some other way to

      --  indicate a node is inactive, for example by using a special

      --  Color_Type value.  ???

      --  N (X).Prev := -1;  -- Node is deallocated (not on active list)

      if Tree.Free >= 0 then

         --  The free store has previously been initialized. All we need to

         --  do here is link the newly-free'd node onto the free list.

         Set_Parent (N (X), Tree.Free);

         Tree.Free := X;

      elsif X + 1 = abs Tree.Free then

         --  The free store has not been initialized, and the node becoming

         --  inactive immediately precedes the start of the free store. All

         --  we need to do is move the start of the free store back by one.

         Tree.Free := Tree.Free + 1;

      else

         --  The free store has not been initialized, and the node becoming

         --  inactive does not immediately precede the free store. Here we

         --  first initialize the free store (meaning the links are given

         --  values in the traditional way), and then link the newly-free'd

         --  node onto the head of the free store.

         --  ???

         --  See the comments above for an optimization opportunity. If the

         --  next link for a node on the free store is negative, then this

         --  means the remaining nodes on the free store are physically

         --  contiguous, starting as the absolute value of that index value.

         Tree.Free := abs Tree.Free;

         if Tree.Free > Tree.Capacity then

            Tree.Free := 0;

         else

            for I in Tree.Free .. Tree.Capacity - 1 loop

               Set_Parent (N (I), I + 1);

            end loop;

            Set_Parent (N (Tree.Capacity), 0);

         end if;

         Set_Parent (N (X), Tree.Free);

         Tree.Free := X;

      end if;

   end Free;

   -----------------------

   -- Generic_Allocate --

   -----------------------

   procedure Generic_Allocate

     (Tree : in out Tree_Type'Class;

      Node : out Count_Type)

   is

      N : Nodes_Type renames Tree.Nodes;

   begin

      if Tree.Free >= 0 then

         Node := Tree.Free;

         --  We always perform the assignment first, before we

         --  change container state, in order to defend against

         --  exceptions duration assignment.

         Set_Element (N (Node));

         Tree.Free := Parent (N (Node));

      else

         --  A negative free store value means that the links of the nodes

         --  in the free store have not been initialized. In this case, the

         --  nodes are physically contiguous in the array, starting at the

         --  index that is the absolute value of the Container.Free, and

         --  continuing until the end of the array (Nodes'Last).

         Node := abs Tree.Free;

         --  As above, we perform this assignment first, before modifying

         --  any container state.

         Set_Element (N (Node));

         Tree.Free := Tree.Free - 1;

      end if;

      --  When a node is allocated from the free store, its pointer components

      --  (the links to other nodes in the tree) must also be initialized (to

      --  0, the equivalent of null). This simplifies the post-allocation

      --  handling of nodes inserted into terminal positions.

      Set_Parent (N (Node), Parent => 0);

      Set_Left   (N (Node), Left   => 0);

      Set_Right  (N (Node), Right  => 0);

   end Generic_Allocate;

   -------------------

   -- Generic_Equal --

   -------------------

   function Generic_Equal (Left, Right : Tree_Type'Class) return Boolean is

      L_Node : Count_Type;

      R_Node : Count_Type;

   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 /= 0 loop

         if not Is_Equal (Left.Nodes (L_Node), Right.Nodes (R_Node)) then

            return False;

         end if;

         L_Node := Next (Left, L_Node);

         R_Node := Next (Right, R_Node);

      end loop;

      return True;

   end Generic_Equal;

   -----------------------

   -- Generic_Iteration --

   -----------------------

   procedure Generic_Iteration (Tree : Tree_Type'Class) is

      procedure Iterate (P : Count_Type);

      -------------

      -- Iterate --

      -------------

      procedure Iterate (P : Count_Type) is

         X : Count_Type := P;

      begin

         while X /= 0 loop

            Iterate (Left (Tree.Nodes (X)));

            Process (X);

            X := Right (Tree.Nodes (X));

         end loop;

      end Iterate;

   --  Start of processing for Generic_Iteration

   begin

      Iterate (Tree.Root);

   end Generic_Iteration;

   ------------------

   -- Generic_Read --

   ------------------

   procedure Generic_Read

     (Stream : not null access Root_Stream_Type'Class;

      Tree   : in out Tree_Type'Class)

   is

      Len : Count_Type'Base;

      Node, Last_Node : Count_Type;

      N : Nodes_Type renames Tree.Nodes;