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