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-2010, 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), 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    end Generic_Allocate;
 590
 591    -------------------
 592    -- Generic_Equal --
 593    -------------------
 594
 595    function Generic_Equal (Left, Right : Tree_Type'Class) return Boolean is
 596       L_Node : Count_Type;
 597       R_Node : Count_Type;
 598
 599    begin
 600       if Left'Address = Right'Address then
 601          return True;
 602       end if;
 603
 604       if Left.Length /= Right.Length then
 605          return False;
 606       end if;
 607
 608       L_Node := Left.First;
 609       R_Node := Right.First;
 610       while L_Node /= 0 loop
 611          if not Is_Equal (Left.Nodes (L_Node), Right.Nodes (R_Node)) then
 612             return False;
 613          end if;
 614
 615          L_Node := Next (Left, L_Node);
 616          R_Node := Next (Right, R_Node);
 617       end loop;
 618
 619       return True;
 620    end Generic_Equal;
 621
 622    -----------------------
 623    -- Generic_Iteration --
 624    -----------------------
 625
 626    procedure Generic_Iteration (Tree : Tree_Type'Class) is
 627       procedure Iterate (P : Count_Type);
 628
 629       -------------
 630       -- Iterate --
 631       -------------
 632
 633       procedure Iterate (P : Count_Type) is
 634          X : Count_Type := P;
 635       begin
 636          while X /= 0 loop
 637             Iterate (Left (Tree.Nodes (X)));
 638             Process (X);
 639             X := Right (Tree.Nodes (X));
 640          end loop;
 641       end Iterate;
 642
 643    --  Start of processing for Generic_Iteration
 644
 645    begin
 646       Iterate (Tree.Root);
 647    end Generic_Iteration;
 648
 649    ------------------
 650    -- Generic_Read --
 651    ------------------
 652
 653    procedure Generic_Read
 654      (Stream : not null access Root_Stream_Type'Class;
 655       Tree   : in out Tree_Type'Class)
 656    is
 657       Len : Count_Type'Base;
 658
 659       Node, Last_Node : Count_Type;
 660
 661       N : Nodes_Type renames Tree.Nodes;
 662
 663    begin
 664       Clear_Tree (Tree);
 665       Count_Type'Base'Read (Stream, Len);
 666
 667       if Len < 0 then
 668          raise Program_Error with "bad container length (corrupt stream)";
 669       end if;
 670
 671       if Len = 0 then
 672          return;
 673       end if;
 674
 675       if Len > Tree.Capacity then
 676          raise Constraint_Error with "length exceeds capacity";
 677       end if;
 678
 679       --  Use Unconditional_Insert_With_Hint here instead ???
 680
 681       Allocate (Tree, Node);
 682       pragma Assert (Node /= 0);
 683
 684       Set_Color (N (Node), Black);
 685
 686       Tree.Root := Node;
 687       Tree.First := Node;
 688       Tree.Last := Node;
 689       Tree.Length := 1;
 690
 691       for J in Count_Type range 2 .. Len loop
 692          Last_Node := Node;
 693          pragma Assert (Last_Node = Tree.Last);
 694
 695          Allocate (Tree, Node);
 696          pragma Assert (Node /= 0);
 697
 698          Set_Color (N (Node), Red);
 699          Set_Right (N (Last_Node), Right => Node);
 700          Tree.Last := Node;
 701          Set_Parent (N (Node), Parent => Last_Node);
 702
 703          Rebalance_For_Insert (Tree, Node);
 704          Tree.Length := Tree.Length + 1;
 705       end loop;
 706    end Generic_Read;
 707
 708    -------------------------------
 709    -- Generic_Reverse_Iteration --
 710    -------------------------------
 711
 712    procedure Generic_Reverse_Iteration (Tree : Tree_Type'Class) is
 713       procedure Iterate (P : Count_Type);
 714
 715       -------------
 716       -- Iterate --
 717       -------------
 718
 719       procedure Iterate (P : Count_Type) is
 720          X : Count_Type := P;
 721       begin
 722          while X /= 0 loop
 723             Iterate (Right (Tree.Nodes (X)));
 724             Process (X);
 725             X := Left (Tree.Nodes (X));
 726          end loop;
 727       end Iterate;
 728
 729    --  Start of processing for Generic_Reverse_Iteration
 730
 731    begin
 732       Iterate (Tree.Root);
 733    end Generic_Reverse_Iteration;
 734
 735    -------------------
 736    -- Generic_Write --
 737    -------------------
 738
 739    procedure Generic_Write
 740      (Stream : not null access Root_Stream_Type'Class;
 741       Tree   : Tree_Type'Class)
 742    is
 743       procedure Process (Node : Count_Type);
 744       pragma Inline (Process);
 745
 746       procedure Iterate is
 747          new Generic_Iteration (Process);
 748
 749       -------------
 750       -- Process --
 751       -------------
 752
 753       procedure Process (Node : Count_Type) is
 754       begin
 755          Write_Node (Stream, Tree.Nodes (Node));
 756       end Process;
 757
 758    --  Start of processing for Generic_Write
 759
 760    begin
 761       Count_Type'Base'Write (Stream, Tree.Length);
 762       Iterate (Tree);
 763    end Generic_Write;
 764
 765    -----------------
 766    -- Left_Rotate --
 767    -----------------
 768
 769    procedure Left_Rotate (Tree : in out Tree_Type'Class; X : Count_Type) is
 770       --  CLR p266
 771
 772       N : Nodes_Type renames Tree.Nodes;
 773
 774       Y : constant Count_Type := Right (N (X));
 775       pragma Assert (Y /= 0);
 776
 777    begin
 778       Set_Right (N (X), Left (N (Y)));
 779
 780       if Left (N (Y)) /= 0 then
 781          Set_Parent (N (Left (N (Y))), X);
 782       end if;
 783
 784       Set_Parent (N (Y), Parent (N (X)));
 785
 786       if X = Tree.Root then
 787          Tree.Root := Y;
 788       elsif X = Left (N (Parent (N (X)))) then
 789          Set_Left (N (Parent (N (X))), Y);
 790       else
 791          pragma Assert (X = Right (N (Parent (N (X)))));
 792          Set_Right (N (Parent (N (X))), Y);
 793       end if;
 794
 795       Set_Left (N (Y), X);
 796       Set_Parent (N (X), Y);
 797    end Left_Rotate;
 798
 799    ---------
 800    -- Max --
 801    ---------
 802
 803    function Max
 804      (Tree : Tree_Type'Class;
 805       Node : Count_Type) return Count_Type
 806    is
 807       --  CLR p248
 808
 809       X : Count_Type := Node;
 810       Y : Count_Type;
 811
 812    begin
 813       loop
 814          Y := Right (Tree.Nodes (X));
 815
 816          if Y = 0 then
 817             return X;
 818          end if;
 819
 820          X := Y;
 821       end loop;
 822    end Max;
 823
 824    ---------
 825    -- Min --
 826    ---------
 827
 828    function Min
 829      (Tree : Tree_Type'Class;
 830       Node : Count_Type) return Count_Type
 831    is
 832       --  CLR p248
 833
 834       X : Count_Type := Node;
 835       Y : Count_Type;
 836
 837    begin
 838       loop
 839          Y := Left (Tree.Nodes (X));
 840
 841          if Y = 0 then
 842             return X;
 843          end if;
 844
 845          X := Y;
 846       end loop;
 847    end Min;
 848
 849    ----------
 850    -- Next --
 851    ----------
 852
 853    function Next
 854      (Tree : Tree_Type'Class;
 855       Node : Count_Type) return Count_Type
 856    is
 857    begin
 858       --  CLR p249
 859
 860       if Node = 0 then
 861          return 0;
 862       end if;
 863
 864       if Right (Tree.Nodes (Node)) /= 0 then
 865          return Min (Tree, Right (Tree.Nodes (Node)));
 866       end if;
 867
 868       declare
 869          X : Count_Type := Node;
 870          Y : Count_Type := Parent (Tree.Nodes (Node));
 871
 872       begin
 873          while Y /= 0
 874            and then X = Right (Tree.Nodes (Y))
 875          loop
 876             X := Y;
 877             Y := Parent (Tree.Nodes (Y));
 878          end loop;
 879
 880          return Y;
 881       end;
 882    end Next;
 883
 884    --------------
 885    -- Previous --
 886    --------------
 887
 888    function Previous
 889      (Tree : Tree_Type'Class;
 890       Node : Count_Type) return Count_Type
 891    is
 892    begin
 893       if Node = 0 then
 894          return 0;
 895       end if;
 896
 897       if Left (Tree.Nodes (Node)) /= 0 then
 898          return Max (Tree, Left (Tree.Nodes (Node)));
 899       end if;
 900
 901       declare
 902          X : Count_Type := Node;
 903          Y : Count_Type := Parent (Tree.Nodes (Node));
 904
 905       begin
 906          while Y /= 0
 907            and then X = Left (Tree.Nodes (Y))
 908          loop
 909             X := Y;
 910             Y := Parent (Tree.Nodes (Y));
 911          end loop;
 912
 913          return Y;
 914       end;
 915    end Previous;
 916
 917    --------------------------
 918    -- Rebalance_For_Insert --
 919    --------------------------
 920
 921    procedure Rebalance_For_Insert
 922      (Tree : in out Tree_Type'Class;
 923       Node : Count_Type)
 924    is
 925       --  CLR p.268
 926
 927       N : Nodes_Type renames Tree.Nodes;
 928
 929       X : Count_Type := Node;
 930       pragma Assert (X /= 0);
 931       pragma Assert (Color (N (X)) = Red);
 932
 933       Y : Count_Type;
 934
 935    begin
 936       while X /= Tree.Root and then Color (N (Parent (N (X)))) = Red loop
 937          if Parent (N (X)) = Left (N (Parent (N (Parent (N (X)))))) then
 938             Y := Right (N (Parent (N (Parent (N (X))))));
 939
 940             if Y /= 0 and then Color (N (Y)) = Red then
 941                Set_Color (N (Parent (N (X))), Black);
 942                Set_Color (N (Y), Black);
 943                Set_Color (N (Parent (N (Parent (N (X))))), Red);
 944                X := Parent (N (Parent (N (X))));
 945
 946             else
 947                if X = Right (N (Parent (N (X)))) then
 948                   X := Parent (N (X));
 949                   Left_Rotate (Tree, X);
 950                end if;
 951
 952                Set_Color (N (Parent (N (X))), Black);
 953                Set_Color (N (Parent (N (Parent (N (X))))), Red);
 954                Right_Rotate (Tree, Parent (N (Parent (N (X)))));
 955             end if;
 956
 957          else
 958             pragma Assert (Parent (N (X)) =
 959                              Right (N (Parent (N (Parent (N (X)))))));
 960
 961             Y := Left (N (Parent (N (Parent (N (X))))));
 962
 963             if Y /= 0 and then Color (N (Y)) = Red then
 964                Set_Color (N (Parent (N (X))), Black);
 965                Set_Color (N (Y), Black);
 966                Set_Color (N (Parent (N (Parent (N (X))))), Red);
 967                X := Parent (N (Parent (N (X))));
 968
 969             else
 970                if X = Left (N (Parent (N (X)))) then
 971                   X := Parent (N (X));
 972                   Right_Rotate (Tree, X);
 973                end if;
 974
 975                Set_Color (N (Parent (N (X))), Black);
 976                Set_Color (N (Parent (N (Parent (N (X))))), Red);
 977                Left_Rotate (Tree, Parent (N (Parent (N (X)))));
 978             end if;
 979          end if;
 980       end loop;
 981
 982       Set_Color (N (Tree.Root), Black);
 983    end Rebalance_For_Insert;
 984
 985    ------------------
 986    -- Right_Rotate --
 987    ------------------
 988
 989    procedure Right_Rotate (Tree : in out Tree_Type'Class; Y : Count_Type) is
 990       N : Nodes_Type renames Tree.Nodes;
 991
 992       X : constant Count_Type := Left (N (Y));
 993       pragma Assert (X /= 0);
 994
 995    begin
 996       Set_Left (N (Y), Right (N (X)));
 997
 998       if Right (N (X)) /= 0 then
 999          Set_Parent (N (Right (N (X))), Y);
1000       end if;
1001
1002       Set_Parent (N (X), Parent (N (Y)));
1003
1004       if Y = Tree.Root then
1005          Tree.Root := X;
1006       elsif Y = Left (N (Parent (N (Y)))) then
1007          Set_Left (N (Parent (N (Y))), X);
1008       else
1009          pragma Assert (Y = Right (N (Parent (N (Y)))));
1010          Set_Right (N (Parent (N (Y))), X);
1011       end if;
1012
1013       Set_Right (N (X), Y);
1014       Set_Parent (N (Y), X);
1015    end Right_Rotate;
1016
1017    ---------
1018    -- Vet --
1019    ---------
1020
1021    function Vet (Tree : Tree_Type'Class; Index : Count_Type) return Boolean is
1022       Nodes : Nodes_Type renames Tree.Nodes;
1023       Node  : Node_Type renames Nodes (Index);
1024
1025    begin
1026       if Parent (Node) = Index
1027         or else Left (Node) = Index
1028         or else Right (Node) = Index
1029       then
1030          return False;
1031       end if;
1032
1033       if Tree.Length = 0
1034         or else Tree.Root = 0
1035         or else Tree.First = 0
1036         or else Tree.Last = 0
1037       then
1038          return False;
1039       end if;
1040
1041       if Parent (Nodes (Tree.Root)) /= 0 then
1042          return False;
1043       end if;
1044
1045       if Left (Nodes (Tree.First)) /= 0 then
1046          return False;
1047       end if;
1048
1049       if Right (Nodes (Tree.Last)) /= 0 then
1050          return False;
1051       end if;
1052
1053       if Tree.Length = 1 then
1054          if Tree.First /= Tree.Last
1055            or else Tree.First /= Tree.Root
1056          then
1057             return False;
1058          end if;
1059
1060          if Index /= Tree.First then
1061             return False;
1062          end if;
1063
1064          if Parent (Node) /= 0
1065            or else Left (Node) /= 0
1066            or else Right (Node) /= 0
1067          then
1068             return False;
1069          end if;
1070
1071          return True;
1072       end if;
1073
1074       if Tree.First = Tree.Last then
1075          return False;
1076       end if;
1077
1078       if Tree.Length = 2 then
1079          if Tree.First /= Tree.Root
1080            and then Tree.Last /= Tree.Root
1081          then
1082             return False;
1083          end if;
1084
1085          if Tree.First /= Index
1086            and then Tree.Last /= Index
1087          then
1088             return False;
1089          end if;
1090       end if;
1091
1092       if Left (Node) /= 0
1093         and then Parent (Nodes (Left (Node))) /= Index
1094       then
1095          return False;
1096       end if;
1097
1098       if Right (Node) /= 0
1099         and then Parent (Nodes (Right (Node))) /= Index
1100       then
1101          return False;
1102       end if;
1103
1104       if Parent (Node) = 0 then
1105          if Tree.Root /= Index then
1106             return False;
1107          end if;
1108
1109       elsif Left (Nodes (Parent (Node))) /= Index
1110         and then Right (Nodes (Parent (Node))) /= Index
1111       then
1112          return False;
1113       end if;
1114
1115       return True;
1116    end Vet;
1117
1118 end Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations;