gcc/ada/a-rbtgbo.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT LIBRARY COMPONENTS                          --
   4 --                                                                          --
   5 --         ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_BOUNDED_OPERATIONS        --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 2004-2011, 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_Bounded_Operations is
  40
  41    -----------------------
  42    -- Local Subprograms --
  43    -----------------------
  44
  45    procedure Delete_Fixup (Tree : in out Tree_Type'Class; Node : Count_Type);
  46    procedure Delete_Swap (Tree : in out Tree_Type'Class; Z, Y : Count_Type);
  47
  48    procedure Left_Rotate  (Tree : in out Tree_Type'Class; X : Count_Type);
  49    procedure Right_Rotate (Tree : in out Tree_Type'Class; Y : Count_Type);
  50
  51    ----------------
  52    -- Clear_Tree --
  53    ----------------
  54
  55    procedure Clear_Tree (Tree : in out Tree_Type'Class) is
  56    begin
  57       if Tree.Busy > 0 then
  58          raise Program_Error with
  59            "attempt to tamper with cursors (container is busy)";
  60       end if;
  61
  62       Tree.First := 0;
  63       Tree.Last := 0;
  64       Tree.Root := 0;
  65       Tree.Length := 0;
  66       --  Tree.Busy
  67       --  Tree.Lock
  68       Tree.Free := -1;
  69    end Clear_Tree;
  70
  71    ------------------
  72    -- Delete_Fixup --
  73    ------------------
  74
  75    procedure Delete_Fixup
  76      (Tree : in out Tree_Type'Class;
  77       Node : Count_Type)
  78    is
  79
  80       --  CLR p274
  81
  82       X : Count_Type;
  83       W : Count_Type;
  84       N : Nodes_Type renames Tree.Nodes;
  85
  86    begin
  87       X := Node;
  88       while X /= Tree.Root
  89         and then Color (N (X)) = Black
  90       loop
  91          if X = Left (N (Parent (N (X)))) then
  92             W :=  Right (N (Parent (N (X))));
  93
  94             if Color (N (W)) = Red then
  95                Set_Color (N (W), Black);
  96                Set_Color (N (Parent (N (X))), Red);
  97                Left_Rotate (Tree, Parent (N (X)));
  98                W := Right (N (Parent (N (X))));
  99             end if;
 100
 101             if (Left (N (W))  = 0 or else Color (N (Left (N (W)))) = Black)
 102               and then
 103                (Right (N (W)) = 0 or else Color (N (Right (N (W)))) = Black)
 104             then
 105                Set_Color (N (W), Red);
 106                X := Parent (N (X));
 107
 108             else
 109                if Right (N (W)) = 0
 110                  or else Color (N (Right (N (W)))) = Black
 111                then
 112                   --  As a condition for setting the color of the left child to
 113                   --  black, the left child access value must be non-null. A
 114                   --  truth table analysis shows that if we arrive here, that
 115                   --  condition holds, so there's no need for an explicit test.
 116                   --  The assertion is here to document what we know is true.
 117
 118                   pragma Assert (Left (N (W)) /= 0);
 119                   Set_Color (N (Left (N (W))), Black);
 120
 121                   Set_Color (N (W), Red);
 122                   Right_Rotate (Tree, W);
 123                   W := Right (N (Parent (N (X))));
 124                end if;
 125
 126                Set_Color (N (W), Color (N (Parent (N (X)))));
 127                Set_Color (N (Parent (N (X))), Black);
 128                Set_Color (N (Right (N (W))), Black);
 129                Left_Rotate  (Tree, Parent (N (X)));
 130                X := Tree.Root;
 131             end if;
 132
 133          else
 134             pragma Assert (X = Right (N (Parent (N (X)))));
 135
 136             W :=  Left (N (Parent (N (X))));
 137
 138             if Color (N (W)) = Red then
 139                Set_Color (N (W), Black);
 140                Set_Color (N (Parent (N (X))), Red);
 141                Right_Rotate (Tree, Parent (N (X)));
 142                W := Left (N (Parent (N (X))));
 143             end if;
 144
 145             if (Left (N (W))  = 0 or else Color (N (Left (N (W)))) = Black)
 146                   and then
 147                (Right (N (W)) = 0 or else Color (N (Right (N (W)))) = Black)
 148             then
 149                Set_Color (N (W), Red);
 150                X := Parent (N (X));
 151
 152             else
 153                if Left (N (W)) = 0
 154                  or else Color (N (Left (N (W)))) = Black
 155                then
 156                   --  As a condition for setting the color of the right child
 157                   --  to black, the right child access value must be non-null.
 158                   --  A truth table analysis shows that if we arrive here, that
 159                   --  condition holds, so there's no need for an explicit test.
 160                   --  The assertion is here to document what we know is true.
 161
 162                   pragma Assert (Right (N (W)) /= 0);
 163                   Set_Color (N (Right (N (W))), Black);
 164
 165                   Set_Color (N (W), Red);
 166                   Left_Rotate (Tree, W);
 167                   W := Left (N (Parent (N (X))));
 168                end if;
 169
 170                Set_Color (N (W), Color (N (Parent (N (X)))));
 171                Set_Color (N (Parent (N (X))), Black);
 172                Set_Color (N (Left (N (W))), Black);
 173                Right_Rotate (Tree, Parent (N (X)));
 174                X := Tree.Root;
 175             end if;
 176          end if;
 177       end loop;
 178
 179       Set_Color (N (X), Black);
 180    end Delete_Fixup;
 181
 182    ---------------------------
 183    -- Delete_Node_Sans_Free --
 184    ---------------------------
 185
 186    procedure Delete_Node_Sans_Free
 187      (Tree : in out Tree_Type'Class;
 188       Node : Count_Type)
 189    is
 190       --  CLR p273
 191
 192       X, Y : Count_Type;
 193
 194       Z : constant Count_Type := Node;
 195       pragma Assert (Z /= 0);
 196
 197       N : Nodes_Type renames Tree.Nodes;
 198
 199    begin
 200       if Tree.Busy > 0 then
 201          raise Program_Error with
 202            "attempt to tamper with cursors (container is busy)";
 203       end if;
 204
 205       pragma Assert (Tree.Length > 0);
 206       pragma Assert (Tree.Root /= 0);
 207       pragma Assert (Tree.First /= 0);
 208       pragma Assert (Tree.Last /= 0);
 209       pragma Assert (Parent (N (Tree.Root)) = 0);
 210
 211       pragma Assert ((Tree.Length > 1)
 212                         or else (Tree.First = Tree.Last
 213                                    and then Tree.First = Tree.Root));
 214
 215       pragma Assert ((Left (N (Node)) = 0)
 216                         or else (Parent (N (Left (N (Node)))) = Node));
 217
 218       pragma Assert ((Right (N (Node)) = 0)
 219                         or else (Parent (N (Right (N (Node)))) = Node));
 220
 221       pragma Assert (((Parent (N (Node)) = 0) and then (Tree.Root = Node))
 222                         or else ((Parent (N (Node)) /= 0) and then
 223                                   ((Left (N (Parent (N (Node)))) = Node)
 224                                       or else
 225                                    (Right (N (Parent (N (Node)))) = Node))));
 226
 227       if Left (N (Z)) = 0 then
 228          if Right (N (Z)) = 0 then
 229             if Z = Tree.First then
 230                Tree.First := Parent (N (Z));
 231             end if;
 232
 233             if Z = Tree.Last then
 234                Tree.Last := Parent (N (Z));
 235             end if;
 236
 237             if Color (N (Z)) = Black then
 238                Delete_Fixup (Tree, Z);
 239             end if;
 240
 241             pragma Assert (Left (N (Z)) = 0);
 242             pragma Assert (Right (N (Z)) = 0);
 243
 244             if Z = Tree.Root then
 245                pragma Assert (Tree.Length = 1);
 246                pragma Assert (Parent (N (Z)) = 0);
 247                Tree.Root := 0;
 248             elsif Z = Left (N (Parent (N (Z)))) then
 249                Set_Left (N (Parent (N (Z))), 0);
 250             else
 251                pragma Assert (Z = Right (N (Parent (N (Z)))));
 252                Set_Right (N (Parent (N (Z))), 0);
 253             end if;
 254
 255          else
 256             pragma Assert (Z /= Tree.Last);
 257
 258             X := Right (N (Z));
 259
 260             if Z = Tree.First then
 261                Tree.First := Min (Tree, X);
 262             end if;
 263
 264             if Z = Tree.Root then
 265                Tree.Root := X;
 266             elsif Z = Left (N (Parent (N (Z)))) then
 267                Set_Left (N (Parent (N (Z))), X);
 268             else
 269                pragma Assert (Z = Right (N (Parent (N (Z)))));
 270                Set_Right (N (Parent (N (Z))), X);
 271             end if;
 272
 273             Set_Parent (N (X), Parent (N (Z)));
 274
 275             if Color (N (Z)) = Black then
 276                Delete_Fixup (Tree, X);
 277             end if;
 278          end if;
 279
 280       elsif Right (N (Z)) = 0 then
 281          pragma Assert (Z /= Tree.First);
 282
 283          X := Left (N (Z));
 284
 285          if Z = Tree.Last then
 286             Tree.Last := Max (Tree, X);
 287          end if;
 288
 289          if Z = Tree.Root then
 290             Tree.Root := X;
 291          elsif Z = Left (N (Parent (N (Z)))) then
 292             Set_Left (N (Parent (N (Z))), X);
 293          else
 294             pragma Assert (Z = Right (N (Parent (N (Z)))));
 295             Set_Right (N (Parent (N (Z))), X);
 296          end if;
 297
 298          Set_Parent (N (X), Parent (N (Z)));
 299
 300          if Color (N (Z)) = Black then
 301             Delete_Fixup (Tree, X);
 302          end if;
 303
 304       else
 305          pragma Assert (Z /= Tree.First);
 306          pragma Assert (Z /= Tree.Last);
 307
 308          Y := Next (Tree, Z);
 309          pragma Assert (Left (N (Y)) = 0);
 310
 311          X := Right (N (Y));
 312
 313          if X = 0 then
 314             if Y = Left (N (Parent (N (Y)))) then
 315                pragma Assert (Parent (N (Y)) /= Z);
 316                Delete_Swap (Tree, Z, Y);
 317                Set_Left (N (Parent (N (Z))), Z);
 318
 319             else
 320                pragma Assert (Y = Right (N (Parent (N (Y)))));
 321                pragma Assert (Parent (N (Y)) = Z);
 322                Set_Parent (N (Y), Parent (N (Z)));
 323
 324                if Z = Tree.Root then
 325                   Tree.Root := Y;
 326                elsif Z = Left (N (Parent (N (Z)))) then
 327                   Set_Left (N (Parent (N (Z))), Y);
 328                else
 329                   pragma Assert (Z = Right (N (Parent (N (Z)))));
 330                   Set_Right (N (Parent (N (Z))), Y);
 331                end if;
 332
 333                Set_Left (N (Y), Left (N (Z)));
 334                Set_Parent (N (Left (N (Y))), Y);
 335                Set_Right (N (Y), Z);
 336                Set_Parent (N (Z), Y);
 337                Set_Left (N (Z), 0);
 338                Set_Right (N (Z), 0);
 339
 340                declare
 341                   Y_Color : constant Color_Type := Color (N (Y));
 342                begin
 343                   Set_Color (N (Y), Color (N (Z)));
 344                   Set_Color (N (Z), Y_Color);
 345                end;
 346             end if;
 347
 348             if Color (N (Z)) = Black then
 349                Delete_Fixup (Tree, Z);
 350             end if;
 351
 352             pragma Assert (Left (N (Z)) = 0);
 353             pragma Assert (Right (N (Z)) = 0);
 354
 355             if Z = Right (N (Parent (N (Z)))) then
 356                Set_Right (N (Parent (N (Z))), 0);
 357             else
 358                pragma Assert (Z = Left (N (Parent (N (Z)))));
 359                Set_Left (N (Parent (N (Z))), 0);
 360             end if;
 361
 362          else
 363             if Y = Left (N (Parent (N (Y)))) then
 364                pragma Assert (Parent (N (Y)) /= Z);
 365
 366                Delete_Swap (Tree, Z, Y);
 367
 368                Set_Left (N (Parent (N (Z))), X);
 369                Set_Parent (N (X), Parent (N (Z)));
 370
 371             else
 372                pragma Assert (Y = Right (N (Parent (N (Y)))));
 373                pragma Assert (Parent (N (Y)) = Z);
 374
 375                Set_Parent (N (Y), Parent (N (Z)));
 376
 377                if Z = Tree.Root then
 378                   Tree.Root := Y;
 379                elsif Z = Left (N (Parent (N (Z)))) then
 380                   Set_Left (N (Parent (N (Z))), Y);
 381                else
 382                   pragma Assert (Z = Right (N (Parent (N (Z)))));
 383                   Set_Right (N (Parent (N (Z))), Y);
 384                end if;
 385
 386                Set_Left (N (Y), Left (N (Z)));
 387                Set_Parent (N (Left (N (Y))), Y);
 388
 389                declare
 390                   Y_Color : constant Color_Type := Color (N (Y));
 391                begin
 392                   Set_Color (N (Y), Color (N (Z)));
 393                   Set_Color (N (Z), Y_Color);
 394                end;
 395             end if;
 396
 397             if Color (N (Z)) = Black then
 398                Delete_Fixup (Tree, X);
 399             end if;
 400          end if;
 401       end if;
 402
 403       Tree.Length := Tree.Length - 1;
 404    end Delete_Node_Sans_Free;
 405
 406    -----------------
 407    -- Delete_Swap --
 408    -----------------
 409
 410    procedure Delete_Swap
 411      (Tree : in out Tree_Type'Class;
 412       Z, Y : Count_Type)
 413    is
 414       N : Nodes_Type renames Tree.Nodes;
 415
 416       pragma Assert (Z /= Y);
 417       pragma Assert (Parent (N (Y)) /= Z);
 418
 419       Y_Parent : constant Count_Type := Parent (N (Y));
 420       Y_Color  : constant Color_Type  := Color (N (Y));
 421
 422    begin
 423       Set_Parent (N (Y), Parent (N (Z)));
 424       Set_Left (N (Y), Left (N (Z)));
 425       Set_Right (N (Y), Right (N (Z)));
 426       Set_Color (N (Y), Color (N (Z)));
 427
 428       if Tree.Root = Z then
 429          Tree.Root := Y;
 430       elsif Right (N (Parent (N (Y)))) = Z then
 431          Set_Right (N (Parent (N (Y))), Y);
 432       else
 433          pragma Assert (Left (N (Parent (N (Y)))) = Z);
 434          Set_Left (N (Parent (N (Y))), Y);
 435       end if;
 436
 437       if Right (N (Y)) /= 0 then
 438          Set_Parent (N (Right (N (Y))), Y);
 439       end if;
 440
 441       if Left (N (Y)) /= 0 then
 442          Set_Parent (N (Left (N (Y))), Y);
 443       end if;
 444
 445       Set_Parent (N (Z), Y_Parent);
 446       Set_Color (N (Z), Y_Color);
 447       Set_Left (N (Z), 0);
 448       Set_Right (N (Z), 0);
 449    end Delete_Swap;
 450
 451    ----------
 452    -- Free --
 453    ----------
 454
 455    procedure Free (Tree : in out Tree_Type'Class; X : Count_Type) is
 456       pragma Assert (X > 0);
 457       pragma Assert (X <= Tree.Capacity);
 458
 459       N : Nodes_Type renames Tree.Nodes;
 460       --  pragma Assert (N (X).Prev >= 0);  -- node is active
 461       --  Find a way to mark a node as active vs. inactive; we could
 462       --  use a special value in Color_Type for this.  ???
 463
 464    begin
 465       --  The set container actually contains two data structures: a list for
 466       --  the "active" nodes that contain elements that have been inserted
 467       --  onto the tree, and another for the "inactive" nodes of the free
 468       --  store.
 469       --
 470       --  We desire that merely declaring an object should have only minimal
 471       --  cost; specially, we want to avoid having to initialize the free
 472       --  store (to fill in the links), especially if the capacity is large.
 473       --
 474       --  The head of the free list is indicated by Container.Free. If its
 475       --  value is non-negative, then the free store has been initialized
 476       --  in the "normal" way: Container.Free points to the head of the list
 477       --  of free (inactive) nodes, and the value 0 means the free list is
 478       --  empty. Each node on the free list has been initialized to point
 479       --  to the next free node (via its Parent component), and the value 0
 480       --  means that this is the last free node.
 481       --
 482       --  If Container.Free is negative, then the links on the free store
 483       --  have not been initialized. In this case the link values are
 484       --  implied: the free store comprises the components of the node array
 485       --  started with the absolute value of Container.Free, and continuing
 486       --  until the end of the array (Nodes'Last).
 487       --
 488       --  ???
 489       --  It might be possible to perform an optimization here. Suppose that
 490       --  the free store can be represented as having two parts: one
 491       --  comprising the non-contiguous inactive nodes linked together
 492       --  in the normal way, and the other comprising the contiguous
 493       --  inactive nodes (that are not linked together, at the end of the
 494       --  nodes array). This would allow us to never have to initialize
 495       --  the free store, except in a lazy way as nodes become inactive.
 496
 497       --  When an element is deleted from the list container, its node
 498       --  becomes inactive, and so we set its Prev component to a negative
 499       --  value, to indicate that it is now inactive. This provides a useful
 500       --  way to detect a dangling cursor reference.
 501
 502       --  The comment above is incorrect; we need some other way to
 503       --  indicate a node is inactive, for example by using a special
 504       --  Color_Type value.  ???
 505       --  N (X).Prev := -1;  -- Node is deallocated (not on active list)
 506
 507       if Tree.Free >= 0 then
 508          --  The free store has previously been initialized. All we need to
 509          --  do here is link the newly-free'd node onto the free list.
 510
 511          Set_Parent (N (X), Tree.Free);
 512          Tree.Free := X;
 513
 514       elsif X + 1 = abs Tree.Free then
 515          --  The free store has not been initialized, and the node becoming
 516          --  inactive immediately precedes the start of the free store. All
 517          --  we need to do is move the start of the free store back by one.
 518
 519          Tree.Free := Tree.Free + 1;
 520
 521       else
 522          --  The free store has not been initialized, and the node becoming
 523          --  inactive does not immediately precede the free store. Here we
 524          --  first initialize the free store (meaning the links are given
 525          --  values in the traditional way), and then link the newly-free'd
 526          --  node onto the head of the free store.
 527
 528          --  ???
 529          --  See the comments above for an optimization opportunity. If
 530          --  the next link for a node on the free store is negative, then
 531          --  this means the remaining nodes on the free store are
 532          --  physically contiguous, starting as the absolute value of
 533          --  that index value.
 534
 535          Tree.Free := abs Tree.Free;
 536
 537          if Tree.Free > Tree.Capacity then
 538             Tree.Free := 0;
 539
 540          else
 541             for I in Tree.Free .. Tree.Capacity - 1 loop
 542                Set_Parent (N (I), I + 1);
 543             end loop;
 544
 545             Set_Parent (N (Tree.Capacity), 0);
 546          end if;
 547
 548          Set_Parent (N (X), Tree.Free);
 549          Tree.Free := X;
 550       end if;
 551    end Free;
 552
 553    -----------------------
 554    -- Generic_Allocate --
 555    -----------------------
 556
 557    procedure Generic_Allocate
 558      (Tree : in out Tree_Type'Class;
 559       Node : out Count_Type)
 560    is
 561       N : Nodes_Type renames Tree.Nodes;
 562
 563    begin
 564       if Tree.Free >= 0 then
 565          Node := Tree.Free;
 566
 567          --  We always perform the assignment first, before we
 568          --  change container state, in order to defend against
 569          --  exceptions duration assignment.
 570
 571          Set_Element (N (Node));
 572          Tree.Free := Parent (N (Node));
 573
 574       else
 575          --  A negative free store value means that the links of the nodes
 576          --  in the free store have not been initialized. In this case, the
 577          --  nodes are physically contiguous in the array, starting at the
 578          --  index that is the absolute value of the Container.Free, and
 579          --  continuing until the end of the array (Nodes'Last).
 580
 581          Node := abs Tree.Free;
 582
 583          --  As above, we perform this assignment first, before modifying
 584          --  any container state.
 585
 586          Set_Element (N (Node));
 587          Tree.Free := Tree.Free - 1;
 588       end if;
 589
 590       Set_Parent (N (Node), Parent => 0);
 591       Set_Left (N (Node), Left => 0);
 592       Set_Right (N (Node), Right => 0);
 593    end Generic_Allocate;
 594
 595    -------------------
 596    -- Generic_Equal --
 597    -------------------
 598
 599    function Generic_Equal (Left, Right : Tree_Type'Class) return Boolean is
 600       L_Node : Count_Type;
 601       R_Node : Count_Type;
 602
 603    begin
 604       if Left'Address = Right'Address then
 605          return True;
 606       end if;
 607
 608       if Left.Length /= Right.Length then
 609          return False;
 610       end if;
 611
 612       L_Node := Left.First;
 613       R_Node := Right.First;
 614       while L_Node /= 0 loop
 615          if not Is_Equal (Left.Nodes (L_Node), Right.Nodes (R_Node)) then
 616             return False;
 617          end if;
 618
 619          L_Node := Next (Left, L_Node);
 620          R_Node := Next (Right, R_Node);
 621       end loop;
 622
 623       return True;
 624    end Generic_Equal;
 625
 626    -----------------------
 627    -- Generic_Iteration --
 628    -----------------------
 629
 630    procedure Generic_Iteration (Tree : Tree_Type'Class) is
 631       procedure Iterate (P : Count_Type);
 632
 633       -------------
 634       -- Iterate --
 635       -------------
 636
 637       procedure Iterate (P : Count_Type) is
 638          X : Count_Type := P;
 639       begin
 640          while X /= 0 loop
 641             Iterate (Left (Tree.Nodes (X)));
 642             Process (X);
 643             X := Right (Tree.Nodes (X));
 644          end loop;
 645       end Iterate;
 646
 647    --  Start of processing for Generic_Iteration
 648
 649    begin
 650       Iterate (Tree.Root);
 651    end Generic_Iteration;
 652
 653    ------------------
 654    -- Generic_Read --
 655    ------------------
 656
 657    procedure Generic_Read
 658      (Stream : not null access Root_Stream_Type'Class;
 659       Tree   : in out Tree_Type'Class)
 660    is
 661       Len : Count_Type'Base;
 662
 663       Node, Last_Node : Count_Type;
 664
 665       N : Nodes_Type renames Tree.Nodes;
 666
 667    begin
 668       Clear_Tree (Tree);
 669       Count_Type'Base'Read (Stream, Len);
 670
 671       if Len < 0 then
 672          raise Program_Error with "bad container length (corrupt stream)";
 673       end if;
 674
 675       if Len = 0 then
 676          return;
 677       end if;
 678
 679       if Len > Tree.Capacity then
 680          raise Constraint_Error with "length exceeds capacity";
 681       end if;
 682
 683       --  Use Unconditional_Insert_With_Hint here instead ???
 684
 685       Allocate (Tree, Node);
 686       pragma Assert (Node /= 0);
 687
 688       Set_Color (N (Node), Black);
 689
 690       Tree.Root := Node;
 691       Tree.First := Node;
 692       Tree.Last := Node;
 693       Tree.Length := 1;
 694
 695       for J in Count_Type range 2 .. Len loop
 696          Last_Node := Node;
 697          pragma Assert (Last_Node = Tree.Last);
 698
 699          Allocate (Tree, Node);
 700          pragma Assert (Node /= 0);
 701
 702          Set_Color (N (Node), Red);
 703          Set_Right (N (Last_Node), Right => Node);
 704          Tree.Last := Node;
 705          Set_Parent (N (Node), Parent => Last_Node);
 706
 707          Rebalance_For_Insert (Tree, Node);
 708          Tree.Length := Tree.Length + 1;
 709       end loop;
 710    end Generic_Read;
 711
 712    -------------------------------
 713    -- Generic_Reverse_Iteration --
 714    -------------------------------
 715
 716    procedure Generic_Reverse_Iteration (Tree : Tree_Type'Class) is
 717       procedure Iterate (P : Count_Type);
 718
 719       -------------
 720       -- Iterate --
 721       -------------
 722
 723       procedure Iterate (P : Count_Type) is
 724          X : Count_Type := P;
 725       begin
 726          while X /= 0 loop
 727             Iterate (Right (Tree.Nodes (X)));
 728             Process (X);
 729             X := Left (Tree.Nodes (X));
 730          end loop;
 731       end Iterate;
 732
 733    --  Start of processing for Generic_Reverse_Iteration
 734
 735    begin
 736       Iterate (Tree.Root);
 737    end Generic_Reverse_Iteration;
 738
 739    -------------------
 740    -- Generic_Write --
 741    -------------------
 742
 743    procedure Generic_Write
 744      (Stream : not null access Root_Stream_Type'Class;
 745       Tree   : Tree_Type'Class)
 746    is
 747       procedure Process (Node : Count_Type);
 748       pragma Inline (Process);
 749
 750       procedure Iterate is
 751          new Generic_Iteration (Process);
 752
 753       -------------
 754       -- Process --
 755       -------------
 756
 757       procedure Process (Node : Count_Type) is
 758       begin
 759          Write_Node (Stream, Tree.Nodes (Node));
 760       end Process;
 761
 762    --  Start of processing for Generic_Write
 763
 764    begin
 765       Count_Type'Base'Write (Stream, Tree.Length);
 766       Iterate (Tree);
 767    end Generic_Write;
 768
 769    -----------------
 770    -- Left_Rotate --
 771    -----------------
 772
 773    procedure Left_Rotate (Tree : in out Tree_Type'Class; X : Count_Type) is
 774       --  CLR p266
 775
 776       N : Nodes_Type renames Tree.Nodes;
 777
 778       Y : constant Count_Type := Right (N (X));
 779       pragma Assert (Y /= 0);
 780
 781    begin
 782       Set_Right (N (X), Left (N (Y)));
 783
 784       if Left (N (Y)) /= 0 then
 785          Set_Parent (N (Left (N (Y))), X);
 786       end if;
 787
 788       Set_Parent (N (Y), Parent (N (X)));
 789
 790       if X = Tree.Root then
 791          Tree.Root := Y;
 792       elsif X = Left (N (Parent (N (X)))) then
 793          Set_Left (N (Parent (N (X))), Y);
 794       else
 795          pragma Assert (X = Right (N (Parent (N (X)))));
 796          Set_Right (N (Parent (N (X))), Y);
 797       end if;
 798
 799       Set_Left (N (Y), X);
 800       Set_Parent (N (X), Y);
 801    end Left_Rotate;
 802
 803    ---------
 804    -- Max --
 805    ---------
 806
 807    function Max
 808      (Tree : Tree_Type'Class;
 809       Node : Count_Type) return Count_Type
 810    is
 811       --  CLR p248
 812
 813       X : Count_Type := Node;
 814       Y : Count_Type;
 815
 816    begin
 817       loop
 818          Y := Right (Tree.Nodes (X));
 819
 820          if Y = 0 then
 821             return X;
 822          end if;
 823
 824          X := Y;
 825       end loop;
 826    end Max;
 827
 828    ---------
 829    -- Min --
 830    ---------
 831
 832    function Min
 833      (Tree : Tree_Type'Class;
 834       Node : Count_Type) return Count_Type
 835    is
 836       --  CLR p248
 837
 838       X : Count_Type := Node;
 839       Y : Count_Type;
 840
 841    begin
 842       loop
 843          Y := Left (Tree.Nodes (X));
 844
 845          if Y = 0 then
 846             return X;
 847          end if;
 848
 849          X := Y;
 850       end loop;
 851    end Min;
 852
 853    ----------
 854    -- Next --
 855    ----------
 856
 857    function Next
 858      (Tree : Tree_Type'Class;
 859       Node : Count_Type) return Count_Type
 860    is
 861    begin
 862       --  CLR p249
 863
 864       if Node = 0 then
 865          return 0;
 866       end if;
 867
 868       if Right (Tree.Nodes (Node)) /= 0 then
 869          return Min (Tree, Right (Tree.Nodes (Node)));
 870       end if;
 871
 872       declare
 873          X : Count_Type := Node;
 874          Y : Count_Type := Parent (Tree.Nodes (Node));
 875
 876       begin
 877          while Y /= 0
 878            and then X = Right (Tree.Nodes (Y))
 879          loop
 880             X := Y;
 881             Y := Parent (Tree.Nodes (Y));
 882          end loop;
 883
 884          return Y;
 885       end;
 886    end Next;
 887
 888    --------------
 889    -- Previous --
 890    --------------
 891
 892    function Previous
 893      (Tree : Tree_Type'Class;
 894       Node : Count_Type) return Count_Type
 895    is
 896    begin
 897       if Node = 0 then
 898          return 0;
 899       end if;
 900
 901       if Left (Tree.Nodes (Node)) /= 0 then
 902          return Max (Tree, Left (Tree.Nodes (Node)));
 903       end if;
 904
 905       declare
 906          X : Count_Type := Node;
 907          Y : Count_Type := Parent (Tree.Nodes (Node));
 908
 909       begin
 910          while Y /= 0
 911            and then X = Left (Tree.Nodes (Y))
 912          loop
 913             X := Y;
 914             Y := Parent (Tree.Nodes (Y));
 915          end loop;
 916
 917          return Y;
 918       end;
 919    end Previous;
 920
 921    --------------------------
 922    -- Rebalance_For_Insert --
 923    --------------------------
 924
 925    procedure Rebalance_For_Insert
 926      (Tree : in out Tree_Type'Class;
 927       Node : Count_Type)
 928    is
 929       --  CLR p.268
 930
 931       N : Nodes_Type renames Tree.Nodes;
 932
 933       X : Count_Type := Node;
 934       pragma Assert (X /= 0);
 935       pragma Assert (Color (N (X)) = Red);
 936
 937       Y : Count_Type;
 938
 939    begin
 940       while X /= Tree.Root and then Color (N (Parent (N (X)))) = Red loop
 941          if Parent (N (X)) = Left (N (Parent (N (Parent (N (X)))))) then
 942             Y := Right (N (Parent (N (Parent (N (X))))));
 943
 944             if Y /= 0 and then Color (N (Y)) = Red then
 945                Set_Color (N (Parent (N (X))), Black);
 946                Set_Color (N (Y), Black);
 947                Set_Color (N (Parent (N (Parent (N (X))))), Red);
 948                X := Parent (N (Parent (N (X))));
 949
 950             else
 951                if X = Right (N (Parent (N (X)))) then
 952                   X := Parent (N (X));
 953                   Left_Rotate (Tree, X);
 954                end if;
 955
 956                Set_Color (N (Parent (N (X))), Black);
 957                Set_Color (N (Parent (N (Parent (N (X))))), Red);
 958                Right_Rotate (Tree, Parent (N (Parent (N (X)))));
 959             end if;
 960
 961          else
 962             pragma Assert (Parent (N (X)) =
 963                              Right (N (Parent (N (Parent (N (X)))))));
 964
 965             Y := Left (N (Parent (N (Parent (N (X))))));
 966
 967             if Y /= 0 and then Color (N (Y)) = Red then
 968                Set_Color (N (Parent (N (X))), Black);
 969                Set_Color (N (Y), Black);
 970                Set_Color (N (Parent (N (Parent (N (X))))), Red);
 971                X := Parent (N (Parent (N (X))));
 972
 973             else
 974                if X = Left (N (Parent (N (X)))) then
 975                   X := Parent (N (X));
 976                   Right_Rotate (Tree, X);
 977                end if;
 978
 979                Set_Color (N (Parent (N (X))), Black);
 980                Set_Color (N (Parent (N (Parent (N (X))))), Red);
 981                Left_Rotate (Tree, Parent (N (Parent (N (X)))));
 982             end if;
 983          end if;
 984       end loop;
 985
 986       Set_Color (N (Tree.Root), Black);
 987    end Rebalance_For_Insert;
 988
 989    ------------------
 990    -- Right_Rotate --
 991    ------------------
 992
 993    procedure Right_Rotate (Tree : in out Tree_Type'Class; Y : Count_Type) is
 994       N : Nodes_Type renames Tree.Nodes;
 995
 996       X : constant Count_Type := Left (N (Y));
 997       pragma Assert (X /= 0);
 998
 999    begin
1000       Set_Left (N (Y), Right (N (X)));
1001
1002       if Right (N (X)) /= 0 then
1003          Set_Parent (N (Right (N (X))), Y);
1004       end if;
1005
1006       Set_Parent (N (X), Parent (N (Y)));
1007
1008       if Y = Tree.Root then
1009          Tree.Root := X;
1010       elsif Y = Left (N (Parent (N (Y)))) then
1011          Set_Left (N (Parent (N (Y))), X);
1012       else
1013          pragma Assert (Y = Right (N (Parent (N (Y)))));
1014          Set_Right (N (Parent (N (Y))), X);
1015       end if;
1016
1017       Set_Right (N (X), Y);
1018       Set_Parent (N (Y), X);
1019    end Right_Rotate;
1020
1021    ---------
1022    -- Vet --
1023    ---------
1024
1025    function Vet (Tree : Tree_Type'Class; Index : Count_Type) return Boolean is
1026       Nodes : Nodes_Type renames Tree.Nodes;
1027       Node  : Node_Type renames Nodes (Index);
1028
1029    begin
1030       if Parent (Node) = Index
1031         or else Left (Node) = Index
1032         or else Right (Node) = Index
1033       then
1034          return False;
1035       end if;
1036
1037       if Tree.Length = 0
1038         or else Tree.Root = 0
1039         or else Tree.First = 0
1040         or else Tree.Last = 0
1041       then
1042          return False;
1043       end if;
1044
1045       if Parent (Nodes (Tree.Root)) /= 0 then
1046          return False;
1047       end if;
1048
1049       if Left (Nodes (Tree.First)) /= 0 then
1050          return False;
1051       end if;
1052
1053       if Right (Nodes (Tree.Last)) /= 0 then
1054          return False;
1055       end if;
1056
1057       if Tree.Length = 1 then
1058          if Tree.First /= Tree.Last
1059            or else Tree.First /= Tree.Root
1060          then
1061             return False;
1062          end if;
1063
1064          if Index /= Tree.First then
1065             return False;
1066          end if;
1067
1068          if Parent (Node) /= 0
1069            or else Left (Node) /= 0
1070            or else Right (Node) /= 0
1071          then
1072             return False;
1073          end if;
1074
1075          return True;
1076       end if;
1077
1078       if Tree.First = Tree.Last then
1079          return False;
1080       end if;
1081
1082       if Tree.Length = 2 then
1083          if Tree.First /= Tree.Root
1084            and then Tree.Last /= Tree.Root
1085          then
1086             return False;
1087          end if;
1088
1089          if Tree.First /= Index
1090            and then Tree.Last /= Index
1091          then
1092             return False;
1093          end if;
1094       end if;
1095
1096       if Left (Node) /= 0
1097         and then Parent (Nodes (Left (Node))) /= Index
1098       then
1099          return False;
1100       end if;
1101
1102       if Right (Node) /= 0
1103         and then Parent (Nodes (Right (Node))) /= Index
1104       then
1105          return False;
1106       end if;
1107
1108       if Parent (Node) = 0 then
1109          if Tree.Root /= Index then
1110             return False;
1111          end if;
1112
1113       elsif Left (Nodes (Parent (Node))) /= Index
1114         and then Right (Nodes (Parent (Node))) /= Index
1115       then
1116          return False;
1117       end if;
1118
1119       return True;
1120    end Vet;
1121
1122 end Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations;