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 p. 274
  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 p. 273
 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
 337                Set_Parent (N (Z), Y);
 338                Set_Left   (N (Z), 0);
 339                Set_Right  (N (Z), 0);
 340
 341                declare
 342                   Y_Color : constant Color_Type := Color (N (Y));
 343                begin
 344                   Set_Color (N (Y), Color (N (Z)));
 345                   Set_Color (N (Z), Y_Color);
 346                end;
 347             end if;
 348
 349             if Color (N (Z)) = Black then
 350                Delete_Fixup (Tree, Z);
 351             end if;
 352
 353             pragma Assert (Left (N (Z)) = 0);
 354             pragma Assert (Right (N (Z)) = 0);
 355
 356             if Z = Right (N (Parent (N (Z)))) then
 357                Set_Right (N (Parent (N (Z))), 0);
 358             else
 359                pragma Assert (Z = Left (N (Parent (N (Z)))));
 360                Set_Left (N (Parent (N (Z))), 0);
 361             end if;
 362
 363          else
 364             if Y = Left (N (Parent (N (Y)))) then
 365                pragma Assert (Parent (N (Y)) /= Z);
 366
 367                Delete_Swap (Tree, Z, Y);
 368
 369                Set_Left (N (Parent (N (Z))), X);
 370                Set_Parent (N (X), Parent (N (Z)));
 371
 372             else
 373                pragma Assert (Y = Right (N (Parent (N (Y)))));
 374                pragma Assert (Parent (N (Y)) = Z);
 375
 376                Set_Parent (N (Y), Parent (N (Z)));
 377
 378                if Z = Tree.Root then
 379                   Tree.Root := Y;
 380                elsif Z = Left (N (Parent (N (Z)))) then
 381                   Set_Left (N (Parent (N (Z))), Y);
 382                else
 383                   pragma Assert (Z = Right (N (Parent (N (Z)))));
 384                   Set_Right (N (Parent (N (Z))), Y);
 385                end if;
 386
 387                Set_Left (N (Y), Left (N (Z)));
 388                Set_Parent (N (Left (N (Y))), Y);
 389
 390                declare
 391                   Y_Color : constant Color_Type := Color (N (Y));
 392                begin
 393                   Set_Color (N (Y), Color (N (Z)));
 394                   Set_Color (N (Z), Y_Color);
 395                end;
 396             end if;
 397
 398             if Color (N (Z)) = Black then
 399                Delete_Fixup (Tree, X);
 400             end if;
 401          end if;
 402       end if;
 403
 404       Tree.Length := Tree.Length - 1;
 405    end Delete_Node_Sans_Free;
 406
 407    -----------------
 408    -- Delete_Swap --
 409    -----------------
 410
 411    procedure Delete_Swap
 412      (Tree : in out Tree_Type'Class;
 413       Z, Y : Count_Type)
 414    is
 415       N : Nodes_Type renames Tree.Nodes;
 416
 417       pragma Assert (Z /= Y);
 418       pragma Assert (Parent (N (Y)) /= Z);
 419
 420       Y_Parent : constant Count_Type := Parent (N (Y));
 421       Y_Color  : constant Color_Type := Color (N (Y));
 422
 423    begin
 424       Set_Parent (N (Y), Parent (N (Z)));
 425       Set_Left   (N (Y), Left   (N (Z)));
 426       Set_Right  (N (Y), Right  (N (Z)));
 427       Set_Color  (N (Y), Color  (N (Z)));
 428
 429       if Tree.Root = Z then
 430          Tree.Root := Y;
 431       elsif Right (N (Parent (N (Y)))) = Z then
 432          Set_Right (N (Parent (N (Y))), Y);
 433       else
 434          pragma Assert (Left (N (Parent (N (Y)))) = Z);
 435          Set_Left (N (Parent (N (Y))), Y);
 436       end if;
 437
 438       if Right (N (Y)) /= 0 then
 439          Set_Parent (N (Right (N (Y))), Y);
 440       end if;
 441
 442       if Left (N (Y)) /= 0 then
 443          Set_Parent (N (Left (N (Y))), Y);
 444       end if;
 445
 446       Set_Parent (N (Z), Y_Parent);
 447       Set_Color  (N (Z), Y_Color);
 448       Set_Left   (N (Z), 0);
 449       Set_Right  (N (Z), 0);
 450    end Delete_Swap;
 451
 452    ----------
 453    -- Free --
 454    ----------
 455
 456    procedure Free (Tree : in out Tree_Type'Class; X : Count_Type) is
 457       pragma Assert (X > 0);
 458       pragma Assert (X <= Tree.Capacity);
 459
 460       N : Nodes_Type renames Tree.Nodes;
 461       --  pragma Assert (N (X).Prev >= 0);  -- node is active
 462       --  Find a way to mark a node as active vs. inactive; we could
 463       --  use a special value in Color_Type for this.  ???
 464
 465    begin
 466       --  The set container actually contains two data structures: a list for
 467       --  the "active" nodes that contain elements that have been inserted
 468       --  onto the tree, and another for the "inactive" nodes of the free
 469       --  store.
 470       --
 471       --  We desire that merely declaring an object should have only minimal
 472       --  cost; specially, we want to avoid having to initialize the free
 473       --  store (to fill in the links), especially if the capacity is large.
 474       --
 475       --  The head of the free list is indicated by Container.Free. If its
 476       --  value is non-negative, then the free store has been initialized
 477       --  in the "normal" way: Container.Free points to the head of the list
 478       --  of free (inactive) nodes, and the value 0 means the free list is
 479       --  empty. Each node on the free list has been initialized to point
 480       --  to the next free node (via its Parent component), and the value 0
 481       --  means that this is the last free node.
 482       --
 483       --  If Container.Free is negative, then the links on the free store
 484       --  have not been initialized. In this case the link values are
 485       --  implied: the free store comprises the components of the node array
 486       --  started with the absolute value of Container.Free, and continuing
 487       --  until the end of the array (Nodes'Last).
 488       --
 489       --  ???
 490       --  It might be possible to perform an optimization here. Suppose that
 491       --  the free store can be represented as having two parts: one
 492       --  comprising the non-contiguous inactive nodes linked together
 493       --  in the normal way, and the other comprising the contiguous
 494       --  inactive nodes (that are not linked together, at the end of the
 495       --  nodes array). This would allow us to never have to initialize
 496       --  the free store, except in a lazy way as nodes become inactive.
 497
 498       --  When an element is deleted from the list container, its node
 499       --  becomes inactive, and so we set its Prev component to a negative
 500       --  value, to indicate that it is now inactive. This provides a useful
 501       --  way to detect a dangling cursor reference.
 502
 503       --  The comment above is incorrect; we need some other way to
 504       --  indicate a node is inactive, for example by using a special
 505       --  Color_Type value.  ???
 506       --  N (X).Prev := -1;  -- Node is deallocated (not on active list)
 507
 508       if Tree.Free >= 0 then
 509          --  The free store has previously been initialized. All we need to
 510          --  do here is link the newly-free'd node onto the free list.
 511
 512          Set_Parent (N (X), Tree.Free);
 513          Tree.Free := X;
 514
 515       elsif X + 1 = abs Tree.Free then
 516          --  The free store has not been initialized, and the node becoming
 517          --  inactive immediately precedes the start of the free store. All
 518          --  we need to do is move the start of the free store back by one.
 519
 520          Tree.Free := Tree.Free + 1;
 521
 522       else
 523          --  The free store has not been initialized, and the node becoming
 524          --  inactive does not immediately precede the free store. Here we
 525          --  first initialize the free store (meaning the links are given
 526          --  values in the traditional way), and then link the newly-free'd
 527          --  node onto the head of the free store.
 528
 529          --  ???
 530          --  See the comments above for an optimization opportunity. If the
 531          --  next link for a node on the free store is negative, then this
 532          --  means the remaining nodes on the free store are physically
 533          --  contiguous, starting as the absolute value of 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       --  When a node is allocated from the free store, its pointer components
 591       --  (the links to other nodes in the tree) must also be initialized (to
 592       --  0, the equivalent of null). This simplifies the post-allocation
 593       --  handling of nodes inserted into terminal positions.
 594
 595       Set_Parent (N (Node), Parent => 0);
 596       Set_Left   (N (Node), Left   => 0);
 597       Set_Right  (N (Node), Right  => 0);
 598    end Generic_Allocate;
 599
 600    -------------------
 601    -- Generic_Equal --
 602    -------------------
 603
 604    function Generic_Equal (Left, Right : Tree_Type'Class) return Boolean is
 605       L_Node : Count_Type;
 606       R_Node : Count_Type;
 607
 608    begin
 609       if Left'Address = Right'Address then
 610          return True;
 611       end if;
 612
 613       if Left.Length /= Right.Length then
 614          return False;
 615       end if;
 616
 617       L_Node := Left.First;
 618       R_Node := Right.First;
 619       while L_Node /= 0 loop
 620          if not Is_Equal (Left.Nodes (L_Node), Right.Nodes (R_Node)) then
 621             return False;
 622          end if;
 623
 624          L_Node := Next (Left, L_Node);
 625          R_Node := Next (Right, R_Node);
 626       end loop;
 627
 628       return True;
 629    end Generic_Equal;
 630
 631    -----------------------
 632    -- Generic_Iteration --
 633    -----------------------
 634
 635    procedure Generic_Iteration (Tree : Tree_Type'Class) is
 636       procedure Iterate (P : Count_Type);
 637
 638       -------------
 639       -- Iterate --
 640       -------------
 641
 642       procedure Iterate (P : Count_Type) is
 643          X : Count_Type := P;
 644       begin
 645          while X /= 0 loop
 646             Iterate (Left (Tree.Nodes (X)));
 647             Process (X);
 648             X := Right (Tree.Nodes (X));
 649          end loop;
 650       end Iterate;
 651
 652    --  Start of processing for Generic_Iteration
 653
 654    begin
 655       Iterate (Tree.Root);
 656    end Generic_Iteration;
 657
 658    ------------------
 659    -- Generic_Read --
 660    ------------------
 661
 662    procedure Generic_Read
 663      (Stream : not null access Root_Stream_Type'Class;
 664       Tree   : in out Tree_Type'Class)
 665    is
 666       Len : Count_Type'Base;
 667
 668       Node, Last_Node : Count_Type;
 669
 670       N : Nodes_Type renames Tree.Nodes;
 671
 672    begin
 673       Clear_Tree (Tree);
 674       Count_Type'Base'Read (Stream, Len);
 675
 676       if Len < 0 then
 677          raise Program_Error with "bad container length (corrupt stream)";
 678       end if;
 679
 680       if Len = 0 then
 681          return;
 682       end if;
 683
 684       if Len > Tree.Capacity then
 685          raise Constraint_Error with "length exceeds capacity";
 686       end if;
 687
 688       --  Use Unconditional_Insert_With_Hint here instead ???
 689
 690       Allocate (Tree, Node);
 691       pragma Assert (Node /= 0);
 692
 693       Set_Color (N (Node), Black);
 694
 695       Tree.Root   := Node;
 696       Tree.First  := Node;
 697       Tree.Last   := Node;
 698       Tree.Length := 1;
 699
 700       for J in Count_Type range 2 .. Len loop
 701          Last_Node := Node;
 702          pragma Assert (Last_Node = Tree.Last);
 703
 704          Allocate (Tree, Node);
 705          pragma Assert (Node /= 0);
 706
 707          Set_Color (N (Node), Red);
 708          Set_Right (N (Last_Node), Right => Node);
 709          Tree.Last := Node;
 710          Set_Parent (N (Node), Parent => Last_Node);
 711
 712          Rebalance_For_Insert (Tree, Node);
 713          Tree.Length := Tree.Length + 1;
 714       end loop;
 715    end Generic_Read;
 716
 717    -------------------------------
 718    -- Generic_Reverse_Iteration --
 719    -------------------------------
 720
 721    procedure Generic_Reverse_Iteration (Tree : Tree_Type'Class) is
 722       procedure Iterate (P : Count_Type);
 723
 724       -------------
 725       -- Iterate --
 726       -------------
 727
 728       procedure Iterate (P : Count_Type) is
 729          X : Count_Type := P;
 730       begin
 731          while X /= 0 loop
 732             Iterate (Right (Tree.Nodes (X)));
 733             Process (X);
 734             X := Left (Tree.Nodes (X));
 735          end loop;
 736       end Iterate;
 737
 738    --  Start of processing for Generic_Reverse_Iteration
 739
 740    begin
 741       Iterate (Tree.Root);
 742    end Generic_Reverse_Iteration;
 743
 744    -------------------
 745    -- Generic_Write --
 746    -------------------
 747
 748    procedure Generic_Write
 749      (Stream : not null access Root_Stream_Type'Class;
 750       Tree   : Tree_Type'Class)
 751    is
 752       procedure Process (Node : Count_Type);
 753       pragma Inline (Process);
 754
 755       procedure Iterate is new Generic_Iteration (Process);
 756
 757       -------------
 758       -- Process --
 759       -------------
 760
 761       procedure Process (Node : Count_Type) is
 762       begin
 763          Write_Node (Stream, Tree.Nodes (Node));
 764       end Process;
 765
 766    --  Start of processing for Generic_Write
 767
 768    begin
 769       Count_Type'Base'Write (Stream, Tree.Length);
 770       Iterate (Tree);
 771    end Generic_Write;
 772
 773    -----------------
 774    -- Left_Rotate --
 775    -----------------
 776
 777    procedure Left_Rotate (Tree : in out Tree_Type'Class; X : Count_Type) is
 778       --  CLR p. 266
 779
 780       N : Nodes_Type renames Tree.Nodes;
 781
 782       Y : constant Count_Type := Right (N (X));
 783       pragma Assert (Y /= 0);
 784
 785    begin
 786       Set_Right (N (X), Left (N (Y)));
 787
 788       if Left (N (Y)) /= 0 then
 789          Set_Parent (N (Left (N (Y))), X);
 790       end if;
 791
 792       Set_Parent (N (Y), Parent (N (X)));
 793
 794       if X = Tree.Root then
 795          Tree.Root := Y;
 796       elsif X = Left (N (Parent (N (X)))) then
 797          Set_Left (N (Parent (N (X))), Y);
 798       else
 799          pragma Assert (X = Right (N (Parent (N (X)))));
 800          Set_Right (N (Parent (N (X))), Y);
 801       end if;
 802
 803       Set_Left   (N (Y), X);
 804       Set_Parent (N (X), Y);
 805    end Left_Rotate;
 806
 807    ---------
 808    -- Max --
 809    ---------
 810
 811    function Max
 812      (Tree : Tree_Type'Class;
 813       Node : Count_Type) return Count_Type
 814    is
 815       --  CLR p. 248
 816
 817       X : Count_Type := Node;
 818       Y : Count_Type;
 819
 820    begin
 821       loop
 822          Y := Right (Tree.Nodes (X));
 823
 824          if Y = 0 then
 825             return X;
 826          end if;
 827
 828          X := Y;
 829       end loop;
 830    end Max;
 831
 832    ---------
 833    -- Min --
 834    ---------
 835
 836    function Min
 837      (Tree : Tree_Type'Class;
 838       Node : Count_Type) return Count_Type
 839    is
 840       --  CLR p. 248
 841
 842       X : Count_Type := Node;
 843       Y : Count_Type;
 844
 845    begin
 846       loop
 847          Y := Left (Tree.Nodes (X));
 848
 849          if Y = 0 then
 850             return X;
 851          end if;
 852
 853          X := Y;
 854       end loop;
 855    end Min;
 856
 857    ----------
 858    -- Next --
 859    ----------
 860
 861    function Next
 862      (Tree : Tree_Type'Class;
 863       Node : Count_Type) return Count_Type
 864    is
 865    begin
 866       --  CLR p. 249
 867
 868       if Node = 0 then
 869          return 0;
 870       end if;
 871
 872       if Right (Tree.Nodes (Node)) /= 0 then
 873          return Min (Tree, Right (Tree.Nodes (Node)));
 874       end if;
 875
 876       declare
 877          X : Count_Type := Node;
 878          Y : Count_Type := Parent (Tree.Nodes (Node));
 879
 880       begin
 881          while Y /= 0
 882            and then X = Right (Tree.Nodes (Y))
 883          loop
 884             X := Y;
 885             Y := Parent (Tree.Nodes (Y));
 886          end loop;
 887
 888          return Y;
 889       end;
 890    end Next;
 891
 892    --------------
 893    -- Previous --
 894    --------------
 895
 896    function Previous
 897      (Tree : Tree_Type'Class;
 898       Node : Count_Type) return Count_Type
 899    is
 900    begin
 901       if Node = 0 then
 902          return 0;
 903       end if;
 904
 905       if Left (Tree.Nodes (Node)) /= 0 then
 906          return Max (Tree, Left (Tree.Nodes (Node)));
 907       end if;
 908
 909       declare
 910          X : Count_Type := Node;
 911          Y : Count_Type := Parent (Tree.Nodes (Node));
 912
 913       begin
 914          while Y /= 0
 915            and then X = Left (Tree.Nodes (Y))
 916          loop
 917             X := Y;
 918             Y := Parent (Tree.Nodes (Y));
 919          end loop;
 920
 921          return Y;
 922       end;
 923    end Previous;
 924
 925    --------------------------
 926    -- Rebalance_For_Insert --
 927    --------------------------
 928
 929    procedure Rebalance_For_Insert
 930      (Tree : in out Tree_Type'Class;
 931       Node : Count_Type)
 932    is
 933       --  CLR p. 268
 934
 935       N : Nodes_Type renames Tree.Nodes;
 936
 937       X : Count_Type := Node;
 938       pragma Assert (X /= 0);
 939       pragma Assert (Color (N (X)) = Red);
 940
 941       Y : Count_Type;
 942
 943    begin
 944       while X /= Tree.Root and then Color (N (Parent (N (X)))) = Red loop
 945          if Parent (N (X)) = Left (N (Parent (N (Parent (N (X)))))) then
 946             Y := Right (N (Parent (N (Parent (N (X))))));
 947
 948             if Y /= 0 and then Color (N (Y)) = Red then
 949                Set_Color (N (Parent (N (X))), Black);
 950                Set_Color (N (Y), Black);
 951                Set_Color (N (Parent (N (Parent (N (X))))), Red);
 952                X := Parent (N (Parent (N (X))));
 953
 954             else
 955                if X = Right (N (Parent (N (X)))) then
 956                   X := Parent (N (X));
 957                   Left_Rotate (Tree, X);
 958                end if;
 959
 960                Set_Color (N (Parent (N (X))), Black);
 961                Set_Color (N (Parent (N (Parent (N (X))))), Red);
 962                Right_Rotate (Tree, Parent (N (Parent (N (X)))));
 963             end if;
 964
 965          else
 966             pragma Assert (Parent (N (X)) =
 967                              Right (N (Parent (N (Parent (N (X)))))));
 968
 969             Y := Left (N (Parent (N (Parent (N (X))))));
 970
 971             if Y /= 0 and then Color (N (Y)) = Red then
 972                Set_Color (N (Parent (N (X))), Black);
 973                Set_Color (N (Y), Black);
 974                Set_Color (N (Parent (N (Parent (N (X))))), Red);
 975                X := Parent (N (Parent (N (X))));
 976
 977             else
 978                if X = Left (N (Parent (N (X)))) then
 979                   X := Parent (N (X));
 980                   Right_Rotate (Tree, X);
 981                end if;
 982
 983                Set_Color (N (Parent (N (X))), Black);
 984                Set_Color (N (Parent (N (Parent (N (X))))), Red);
 985                Left_Rotate (Tree, Parent (N (Parent (N (X)))));
 986             end if;
 987          end if;
 988       end loop;
 989
 990       Set_Color (N (Tree.Root), Black);
 991    end Rebalance_For_Insert;
 992
 993    ------------------
 994    -- Right_Rotate --
 995    ------------------
 996
 997    procedure Right_Rotate (Tree : in out Tree_Type'Class; Y : Count_Type) is
 998       N : Nodes_Type renames Tree.Nodes;
 999
1000       X : constant Count_Type := Left (N (Y));
1001       pragma Assert (X /= 0);
1002
1003    begin
1004       Set_Left (N (Y), Right (N (X)));
1005
1006       if Right (N (X)) /= 0 then
1007          Set_Parent (N (Right (N (X))), Y);
1008       end if;
1009
1010       Set_Parent (N (X), Parent (N (Y)));
1011
1012       if Y = Tree.Root then
1013          Tree.Root := X;
1014       elsif Y = Left (N (Parent (N (Y)))) then
1015          Set_Left (N (Parent (N (Y))), X);
1016       else
1017          pragma Assert (Y = Right (N (Parent (N (Y)))));
1018          Set_Right (N (Parent (N (Y))), X);
1019       end if;
1020
1021       Set_Right  (N (X), Y);
1022       Set_Parent (N (Y), X);
1023    end Right_Rotate;
1024
1025    ---------
1026    -- Vet --
1027    ---------
1028
1029    function Vet (Tree : Tree_Type'Class; Index : Count_Type) return Boolean is
1030       Nodes : Nodes_Type renames Tree.Nodes;
1031       Node  : Node_Type renames Nodes (Index);
1032
1033    begin
1034       if Parent (Node) = Index
1035         or else Left (Node) = Index
1036         or else Right (Node) = Index
1037       then
1038          return False;
1039       end if;
1040
1041       if Tree.Length = 0
1042         or else Tree.Root = 0
1043         or else Tree.First = 0
1044         or else Tree.Last = 0
1045       then
1046          return False;
1047       end if;
1048
1049       if Parent (Nodes (Tree.Root)) /= 0 then
1050          return False;
1051       end if;
1052
1053       if Left (Nodes (Tree.First)) /= 0 then
1054          return False;
1055       end if;
1056
1057       if Right (Nodes (Tree.Last)) /= 0 then
1058          return False;
1059       end if;
1060
1061       if Tree.Length = 1 then
1062          if Tree.First /= Tree.Last
1063            or else Tree.First /= Tree.Root
1064          then
1065             return False;
1066          end if;
1067
1068          if Index /= Tree.First then
1069             return False;
1070          end if;
1071
1072          if Parent (Node) /= 0
1073            or else Left (Node) /= 0
1074            or else Right (Node) /= 0
1075          then
1076             return False;
1077          end if;
1078
1079          return True;
1080       end if;
1081
1082       if Tree.First = Tree.Last then
1083          return False;
1084       end if;
1085
1086       if Tree.Length = 2 then
1087          if Tree.First /= Tree.Root
1088            and then Tree.Last /= Tree.Root
1089          then
1090             return False;
1091          end if;
1092
1093          if Tree.First /= Index
1094            and then Tree.Last /= Index
1095          then
1096             return False;
1097          end if;
1098       end if;
1099
1100       if Left (Node) /= 0
1101         and then Parent (Nodes (Left (Node))) /= Index
1102       then
1103          return False;
1104       end if;
1105
1106       if Right (Node) /= 0
1107         and then Parent (Nodes (Right (Node))) /= Index
1108       then
1109          return False;
1110       end if;
1111
1112       if Parent (Node) = 0 then
1113          if Tree.Root /= Index then
1114             return False;
1115          end if;
1116
1117       elsif Left (Nodes (Parent (Node))) /= Index
1118         and then Right (Nodes (Parent (Node))) /= Index
1119       then
1120          return False;
1121       end if;
1122
1123       return True;
1124    end Vet;
1125
1126 end Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations;