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