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