2010-10-25 Pascal Obry <obry@adacore.com>

	
	* adaint.c (__gnat_file_time_name_attr): Use GetFileAttributesEx to get
	the timestamp. A bit faster than opening/closing the file.
	(__gnat_stat_to_attr): Remove kludge for Windows.
	(__gnat_file_exists_attr): Likewise.
	The timestamp is now retreived using GetFileAttributesEx as faster.

2010-10-25  Javier Miranda  <miranda@adacore.com>

	* sem_ch3.adb (Derive_Interface_Subprogram): New subprogram.
	(Derive_Subprograms): For abstract private types transfer to the full
	view entities of uncovered interface primitives. Required because if
	the interface primitives are left in the private part of the package
	they will be decorated as hidden when the analysis of the enclosing
	package completes (and hence the interface primitive is not visible
	for dispatching calls).

2010-10-25  Matthew Heaney  <heaney@adacore.com>

	* Makefile.rtl, impunit.adb: Added bounded set and bounded map
	containers.
	* a-crbltr.ads: Added declaration of generic package for bounded tree
	types.
	* a-rbtgbo.ads, a-rbtgbo.adb, a-rbtgbk.ads, a-rbtgbk.adb, a-btgbso.ads,
	a-btgbso.adb, a-cborse.ads, a-cborse.adb, a-cborma.ads, a-cborma.adb:
	New.

2010-10-25  Thomas Quinot  <quinot@adacore.com>

	* sem_util.adb: Minor reformatting.
	* usage.adb: Fix usage line for -gnatwh.

2010-10-25  Thomas Quinot  <quinot@adacore.com>

	* sem_ch12.adb (Analyze_Package_Instantiation): For an
	instantiation in an RCI spec, omit package body if instantiation comes
	from source, even as a nested
	package.
	* exp_dist.adb (Add_Calling_Stubs_To_Declarations,
	*_Support.Add_Receiving_Stubs_To_Declarations): Handle the case of
	nested packages, package instantiations and subprogram instantiations.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@165920 138bc75d-0d04-0410-961f-82ee72b054a4

1 files changed, 1118 insertions, 0 deletions

diff --git a/gcc/ada/a-rbtgbo.adb b/gcc/ada/a-rbtgbo.adb
new file mode 100644
index 00000000000..88743b3ce5b
--- /dev/null
+++ b/gcc/ada/a-rbtgbo.adb
@@ -0,0 +1,1118 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT LIBRARY COMPONENTS                          --
+--                                                                          --
+--         ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_BOUNDED_OPERATIONS        --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--          Copyright (C) 2004-2010, 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;
+
+      Tree.First := 0;
+      Tree.Last := 0;
+      Tree.Root := 0;
+      Tree.Length := 0;
+      --  Tree.Busy
+      --  Tree.Lock
+      Tree.Free := -1;
+   end Clear_Tree;
+
+   ------------------
+   -- Delete_Fixup --
+   ------------------
+
+   procedure Delete_Fixup
+     (Tree : in out Tree_Type'Class;
+      Node : Count_Type)
+   is
+
+      --  CLR p274
+
+      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 p273
+
+      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), 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;
+   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;
+
+   begin
+      Clear_Tree (Tree);
+      Count_Type'Base'Read (Stream, Len);
+
+      if Len < 0 then
+         raise Program_Error with "bad container length (corrupt stream)";
+      end if;
+
+      if Len = 0 then
+         return;
+      end if;
+
+      if Len > Tree.Capacity then
+         raise Constraint_Error with "length exceeds capacity";
+      end if;
+
+      --  Use Unconditional_Insert_With_Hint here instead ???
+
+      Allocate (Tree, Node);
+      pragma Assert (Node /= 0);
+
+      Set_Color (N (Node), Black);
+
+      Tree.Root := Node;
+      Tree.First := Node;
+      Tree.Last := Node;
+      Tree.Length := 1;
+
+      for J in Count_Type range 2 .. Len loop
+         Last_Node := Node;
+         pragma Assert (Last_Node = Tree.Last);
+
+         Allocate (Tree, Node);
+         pragma Assert (Node /= 0);
+
+         Set_Color (N (Node), Red);
+         Set_Right (N (Last_Node), Right => Node);
+         Tree.Last := Node;
+         Set_Parent (N (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'Class) is
+      procedure Iterate (P : Count_Type);
+
+      -------------
+      -- Iterate --
+      -------------
+
+      procedure Iterate (P : Count_Type) is
+         X : Count_Type := P;
+      begin
+         while X /= 0 loop
+            Iterate (Right (Tree.Nodes (X)));
+            Process (X);
+            X := Left (Tree.Nodes (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'Class)
+   is
+      procedure Process (Node : Count_Type);
+      pragma Inline (Process);
+
+      procedure Iterate is
+         new Generic_Iteration (Process);
+
+      -------------
+      -- Process --
+      -------------
+
+      procedure Process (Node : Count_Type) is
+      begin
+         Write_Node (Stream, Tree.Nodes (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'Class; X : Count_Type) is
+      --  CLR p266
+
+      N : Nodes_Type renames Tree.Nodes;
+
+      Y : constant Count_Type := Right (N (X));
+      pragma Assert (Y /= 0);
+
+   begin
+      Set_Right (N (X), Left (N (Y)));
+
+      if Left (N (Y)) /= 0 then
+         Set_Parent (N (Left (N (Y))), X);
+      end if;
+
+      Set_Parent (N (Y), Parent (N (X)));
+
+      if X = Tree.Root then
+         Tree.Root := Y;
+      elsif X = Left (N (Parent (N (X)))) then
+         Set_Left (N (Parent (N (X))), Y);
+      else
+         pragma Assert (X = Right (N (Parent (N (X)))));
+         Set_Right (N (Parent (N (X))), Y);
+      end if;
+
+      Set_Left (N (Y), X);
+      Set_Parent (N (X), Y);
+   end Left_Rotate;
+
+   ---------
+   -- Max --
+   ---------
+
+   function Max
+     (Tree : Tree_Type'Class;
+      Node : Count_Type) return Count_Type
+   is
+      --  CLR p248
+
+      X : Count_Type := Node;
+      Y : Count_Type;
+
+   begin
+      loop
+         Y := Right (Tree.Nodes (X));
+
+         if Y = 0 then
+            return X;
+         end if;
+
+         X := Y;
+      end loop;
+   end Max;
+
+   ---------
+   -- Min --
+   ---------
+
+   function Min
+     (Tree : Tree_Type'Class;
+      Node : Count_Type) return Count_Type
+   is
+      --  CLR p248
+
+      X : Count_Type := Node;
+      Y : Count_Type;
+
+   begin
+      loop
+         Y := Left (Tree.Nodes (X));
+
+         if Y = 0 then
+            return X;
+         end if;
+
+         X := Y;
+      end loop;
+   end Min;
+
+   ----------
+   -- Next --
+   ----------
+
+   function Next
+     (Tree : Tree_Type'Class;
+      Node : Count_Type) return Count_Type
+   is
+   begin
+      --  CLR p249
+
+      if Node = 0 then
+         return 0;
+      end if;
+
+      if Right (Tree.Nodes (Node)) /= 0 then
+         return Min (Tree, Right (Tree.Nodes (Node)));
+      end if;
+
+      declare
+         X : Count_Type := Node;
+         Y : Count_Type := Parent (Tree.Nodes (Node));
+
+      begin
+         while Y /= 0
+           and then X = Right (Tree.Nodes (Y))
+         loop
+            X := Y;
+            Y := Parent (Tree.Nodes (Y));
+         end loop;
+
+         return Y;
+      end;
+   end Next;
+
+   --------------
+   -- Previous --
+   --------------
+
+   function Previous
+     (Tree : Tree_Type'Class;
+      Node : Count_Type) return Count_Type
+   is
+   begin
+      if Node = 0 then
+         return 0;
+      end if;
+
+      if Left (Tree.Nodes (Node)) /= 0 then
+         return Max (Tree, Left (Tree.Nodes (Node)));
+      end if;
+
+      declare
+         X : Count_Type := Node;
+         Y : Count_Type := Parent (Tree.Nodes (Node));
+
+      begin
+         while Y /= 0
+           and then X = Left (Tree.Nodes (Y))
+         loop
+            X := Y;
+            Y := Parent (Tree.Nodes (Y));
+         end loop;
+
+         return Y;
+      end;
+   end Previous;
+
+   --------------------------
+   -- Rebalance_For_Insert --
+   --------------------------
+
+   procedure Rebalance_For_Insert
+     (Tree : in out Tree_Type'Class;
+      Node : Count_Type)
+   is
+      --  CLR p.268
+
+      N : Nodes_Type renames Tree.Nodes;
+
+      X : Count_Type := Node;
+      pragma Assert (X /= 0);
+      pragma Assert (Color (N (X)) = Red);
+
+      Y : Count_Type;
+
+   begin
+      while X /= Tree.Root and then Color (N (Parent (N (X)))) = Red loop
+         if Parent (N (X)) = Left (N (Parent (N (Parent (N (X)))))) then
+            Y := Right (N (Parent (N (Parent (N (X))))));
+
+            if Y /= 0 and then Color (N (Y)) = Red then
+               Set_Color (N (Parent (N (X))), Black);
+               Set_Color (N (Y), Black);
+               Set_Color (N (Parent (N (Parent (N (X))))), Red);
+               X := Parent (N (Parent (N (X))));
+
+            else
+               if X = Right (N (Parent (N (X)))) then
+                  X := Parent (N (X));
+                  Left_Rotate (Tree, X);
+               end if;
+
+               Set_Color (N (Parent (N (X))), Black);
+               Set_Color (N (Parent (N (Parent (N (X))))), Red);
+               Right_Rotate (Tree, Parent (N (Parent (N (X)))));
+            end if;
+
+         else
+            pragma Assert (Parent (N (X)) =
+                             Right (N (Parent (N (Parent (N (X)))))));
+
+            Y := Left (N (Parent (N (Parent (N (X))))));
+
+            if Y /= 0 and then Color (N (Y)) = Red then
+               Set_Color (N (Parent (N (X))), Black);
+               Set_Color (N (Y), Black);
+               Set_Color (N (Parent (N (Parent (N (X))))), Red);
+               X := Parent (N (Parent (N (X))));
+
+            else
+               if X = Left (N (Parent (N (X)))) then
+                  X := Parent (N (X));
+                  Right_Rotate (Tree, X);
+               end if;
+
+               Set_Color (N (Parent (N (X))), Black);
+               Set_Color (N (Parent (N (Parent (N (X))))), Red);
+               Left_Rotate (Tree, Parent (N (Parent (N (X)))));
+            end if;
+         end if;
+      end loop;
+
+      Set_Color (N (Tree.Root), Black);
+   end Rebalance_For_Insert;
+
+   ------------------
+   -- Right_Rotate --
+   ------------------
+
+   procedure Right_Rotate (Tree : in out Tree_Type'Class; Y : Count_Type) is
+      N : Nodes_Type renames Tree.Nodes;
+
+      X : constant Count_Type := Left (N (Y));
+      pragma Assert (X /= 0);
+
+   begin
+      Set_Left (N (Y), Right (N (X)));
+
+      if Right (N (X)) /= 0 then
+         Set_Parent (N (Right (N (X))), Y);
+      end if;
+
+      Set_Parent (N (X), Parent (N (Y)));
+
+      if Y = Tree.Root then
+         Tree.Root := X;
+      elsif Y = Left (N (Parent (N (Y)))) then
+         Set_Left (N (Parent (N (Y))), X);
+      else
+         pragma Assert (Y = Right (N (Parent (N (Y)))));
+         Set_Right (N (Parent (N (Y))), X);
+      end if;
+
+      Set_Right (N (X), Y);
+      Set_Parent (N (Y), X);
+   end Right_Rotate;
+
+   ---------
+   -- Vet --
+   ---------
+
+   function Vet (Tree : Tree_Type'Class; Index : Count_Type) return Boolean is
+      Nodes : Nodes_Type renames Tree.Nodes;
+      Node  : Node_Type renames Nodes (Index);
+
+   begin
+      if Parent (Node) = Index
+        or else Left (Node) = Index
+        or else Right (Node) = Index
+      then
+         return False;
+      end if;
+
+      if Tree.Length = 0
+        or else Tree.Root = 0
+        or else Tree.First = 0
+        or else Tree.Last = 0
+      then
+         return False;
+      end if;
+
+      if Parent (Nodes (Tree.Root)) /= 0 then
+         return False;
+      end if;
+
+      if Left (Nodes (Tree.First)) /= 0 then
+         return False;
+      end if;
+
+      if Right (Nodes (Tree.Last)) /= 0 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 Index /= Tree.First then
+            return False;
+         end if;
+
+         if Parent (Node) /= 0
+           or else Left (Node) /= 0
+           or else Right (Node) /= 0
+         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 /= Index
+           and then Tree.Last /= Index
+         then
+            return False;
+         end if;
+      end if;
+
+      if Left (Node) /= 0
+        and then Parent (Nodes (Left (Node))) /= Index
+      then
+         return False;
+      end if;
+
+      if Right (Node) /= 0
+        and then Parent (Nodes (Right (Node))) /= Index
+      then
+         return False;
+      end if;
+
+      if Parent (Node) = 0 then
+         if Tree.Root /= Index then
+            return False;
+         end if;
+
+      elsif Left (Nodes (Parent (Node))) /= Index
+        and then Right (Nodes (Parent (Node))) /= Index
+      then
+         return False;
+      end if;
+
+      return True;
+   end Vet;
+
+end Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations;