gcc/ada/a-crbtgo.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT LIBRARY COMPONENTS                          --
   4 --                                                                          --
   5 --            ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_OPERATIONS             --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --             Copyright (C) 2004 Free Software Foundation, Inc.            --
  10 --                                                                          --
  11 -- This specification is derived from the Ada Reference Manual for use with --
  12 -- GNAT. The copyright notice above, and the license provisions that follow --
  13 -- apply solely to the  contents of the part following the private keyword. --
  14 --                                                                          --
  15 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  16 -- terms of the  GNU General Public License as published  by the Free Soft- --
  17 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  18 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  19 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  20 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  21 -- for  more details.  You should have  received  a copy of the GNU General --
  22 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  23 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  24 -- MA 02111-1307, USA.                                                      --
  25 --                                                                          --
  26 -- As a special exception,  if other files  instantiate  generics from this --
  27 -- unit, or you link  this unit with other files  to produce an executable, --
  28 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  29 -- covered  by the  GNU  General  Public  License.  This exception does not --
  30 -- however invalidate  any other reasons why  the executable file  might be --
  31 -- covered by the  GNU Public License.                                      --
  32 --                                                                          --
  33 -- This unit was originally developed by Matthew J Heaney.                  --
  34 ------------------------------------------------------------------------------
  35
  36 package body Ada.Containers.Red_Black_Trees.Generic_Operations is
  37
  38    -----------------------
  39    -- Local Subprograms --
  40    -----------------------
  41
  42    procedure Delete_Fixup (Tree : in out Tree_Type; Node : Node_Access);
  43
  44    procedure Delete_Swap (Tree : in out Tree_Type; Z, Y : Node_Access);
  45
  46    procedure Left_Rotate  (Tree : in out Tree_Type; X : Node_Access);
  47    procedure Right_Rotate (Tree : in out Tree_Type; Y : Node_Access);
  48
  49    ---------------------
  50    -- Check_Invariant --
  51    ---------------------
  52
  53    procedure Check_Invariant (Tree : Tree_Type) is
  54       Root : constant Node_Access := Tree.Root;
  55
  56       function Check (Node : Node_Access) return Natural;
  57
  58       -----------
  59       -- Check --
  60       -----------
  61
  62       function Check (Node : Node_Access) return Natural is
  63       begin
  64          if Node = Null_Node then
  65             return 0;
  66          end if;
  67
  68          if Color (Node) = Red then
  69             declare
  70                L : constant Node_Access := Left (Node);
  71             begin
  72                pragma Assert (L = Null_Node or else Color (L) = Black);
  73                null;
  74             end;
  75
  76             declare
  77                R : constant Node_Access := Right (Node);
  78             begin
  79                pragma Assert (R = Null_Node or else Color (R) = Black);
  80                null;
  81             end;
  82
  83             declare
  84                NL : constant Natural := Check (Left (Node));
  85                NR : constant Natural := Check (Right (Node));
  86             begin
  87                pragma Assert (NL = NR);
  88                return NL;
  89             end;
  90          end if;
  91
  92          declare
  93             NL : constant Natural := Check (Left (Node));
  94             NR : constant Natural := Check (Right (Node));
  95          begin
  96             pragma Assert (NL = NR);
  97             return NL + 1;
  98          end;
  99       end Check;
 100
 101    --  Start of processing for Check_Invariant
 102
 103    begin
 104       if Root = Null_Node then
 105          pragma Assert (Tree.First = Null_Node);
 106          pragma Assert (Tree.Last = Null_Node);
 107          pragma Assert (Tree.Length = 0);
 108          null;
 109
 110       else
 111          pragma Assert (Color (Root) = Black);
 112          pragma Assert (Tree.Length > 0);
 113          pragma Assert (Tree.Root /= Null_Node);
 114          pragma Assert (Tree.First /= Null_Node);
 115          pragma Assert (Tree.Last /= Null_Node);
 116          pragma Assert (Parent (Tree.Root) = Null_Node);
 117          pragma Assert ((Tree.Length > 1)
 118                            or else (Tree.First = Tree.Last
 119                                       and Tree.First = Tree.Root));
 120          pragma Assert (Left (Tree.First) = Null_Node);
 121          pragma Assert (Right (Tree.Last) = Null_Node);
 122
 123          declare
 124             L  : constant Node_Access := Left (Root);
 125             R  : constant Node_Access := Right (Root);
 126             NL : constant Natural := Check (L);
 127             NR : constant Natural := Check (R);
 128          begin
 129             pragma Assert (NL = NR);
 130             null;
 131          end;
 132       end if;
 133    end Check_Invariant;
 134
 135    ------------------
 136    -- Delete_Fixup --
 137    ------------------
 138
 139    procedure Delete_Fixup (Tree : in out Tree_Type; Node : Node_Access) is
 140
 141       --  CLR p274 ???
 142
 143       X : Node_Access := Node;
 144       W : Node_Access;
 145
 146    begin
 147       while X /= Tree.Root
 148         and then Color (X) = Black
 149       loop
 150          if X = Left (Parent (X)) then
 151             W :=  Right (Parent (X));
 152
 153             if Color (W) = Red then
 154                Set_Color (W, Black);
 155                Set_Color (Parent (X), Red);
 156                Left_Rotate (Tree, Parent (X));
 157                W := Right (Parent (X));
 158             end if;
 159
 160             if (Left (W)  = Null_Node or else Color (Left (W)) = Black)
 161               and then
 162                (Right (W) = Null_Node or else Color (Right (W)) = Black)
 163             then
 164                Set_Color (W, Red);
 165                X := Parent (X);
 166
 167             else
 168                if Right (W) = Null_Node
 169                  or else Color (Right (W)) = Black
 170                then
 171                   if Left (W) /= Null_Node then
 172                      Set_Color (Left (W), Black);
 173                   end if;
 174
 175                   Set_Color (W, Red);
 176                   Right_Rotate (Tree, W);
 177                   W := Right (Parent (X));
 178                end if;
 179
 180                Set_Color (W, Color (Parent (X)));
 181                Set_Color (Parent (X), Black);
 182                Set_Color (Right (W), Black);
 183                Left_Rotate  (Tree, Parent (X));
 184                X := Tree.Root;
 185             end if;
 186
 187          else
 188             pragma Assert (X = Right (Parent (X)));
 189
 190             W :=  Left (Parent (X));
 191
 192             if Color (W) = Red then
 193                Set_Color (W, Black);
 194                Set_Color (Parent (X), Red);
 195                Right_Rotate (Tree, Parent (X));
 196                W := Left (Parent (X));
 197             end if;
 198
 199             if (Left (W)  = Null_Node or else Color (Left (W)) = Black)
 200                   and then
 201                (Right (W) = Null_Node or else Color (Right (W)) = Black)
 202             then
 203                Set_Color (W, Red);
 204                X := Parent (X);
 205
 206             else
 207                if Left (W) = Null_Node or else Color (Left (W)) = Black then
 208                   if Right (W) /= Null_Node then
 209                      Set_Color (Right (W), Black);
 210                   end if;
 211
 212                   Set_Color (W, Red);
 213                   Left_Rotate (Tree, W);
 214                   W := Left (Parent (X));
 215                end if;
 216
 217                Set_Color (W, Color (Parent (X)));
 218                Set_Color (Parent (X), Black);
 219                Set_Color (Left (W), Black);
 220                Right_Rotate (Tree, Parent (X));
 221                X := Tree.Root;
 222             end if;
 223          end if;
 224       end loop;
 225
 226       Set_Color (X, Black);
 227    end Delete_Fixup;
 228
 229    ---------------------------
 230    -- Delete_Node_Sans_Free --
 231    ---------------------------
 232
 233    procedure Delete_Node_Sans_Free
 234      (Tree : in out Tree_Type;
 235       Node : Node_Access)
 236    is
 237       --  CLR p273 ???
 238
 239       X, Y : Node_Access;
 240
 241       Z : constant Node_Access := Node;
 242       pragma Assert (Z /= Null_Node);
 243
 244    begin
 245       pragma Assert (Tree.Length > 0);
 246       pragma Assert (Tree.Root /= Null_Node);
 247       pragma Assert (Tree.First /= Null_Node);
 248       pragma Assert (Tree.Last /= Null_Node);
 249       pragma Assert (Parent (Tree.Root) = Null_Node);
 250       pragma Assert ((Tree.Length > 1)
 251                         or else (Tree.First = Tree.Last
 252                                    and then Tree.First = Tree.Root));
 253       pragma Assert ((Left (Node) = Null_Node)
 254                         or else (Parent (Left (Node)) = Node));
 255       pragma Assert ((Right (Node) = Null_Node)
 256                         or else (Parent (Right (Node)) = Node));
 257       pragma Assert (((Parent (Node) = Null_Node) and then (Tree.Root = Node))
 258                         or else ((Parent (Node) /= Null_Node) and then
 259                                   ((Left (Parent (Node)) = Node)
 260                                      or else (Right (Parent (Node)) = Node))));
 261
 262       if Left (Z) = Null_Node then
 263          if Right (Z) = Null_Node then
 264             if Z = Tree.First then
 265                Tree.First := Parent (Z);
 266             end if;
 267
 268             if Z = Tree.Last then
 269                Tree.Last := Parent (Z);
 270             end if;
 271
 272             if Color (Z) = Black then
 273                Delete_Fixup (Tree, Z);
 274             end if;
 275
 276             pragma Assert (Left (Z) = Null_Node);
 277             pragma Assert (Right (Z) = Null_Node);
 278
 279             if Z = Tree.Root then
 280                pragma Assert (Tree.Length = 1);
 281                pragma Assert (Parent (Z) = Null_Node);
 282                Tree.Root := Null_Node;
 283             elsif Z = Left (Parent (Z)) then
 284                Set_Left (Parent (Z), Null_Node);
 285             else
 286                pragma Assert (Z = Right (Parent (Z)));
 287                Set_Right (Parent (Z), Null_Node);
 288             end if;
 289
 290          else
 291             pragma Assert (Z /= Tree.Last);
 292
 293             X := Right (Z);
 294
 295             if Z = Tree.First then
 296                Tree.First := Min (X);
 297             end if;
 298
 299             if Z = Tree.Root then
 300                Tree.Root := X;
 301             elsif Z = Left (Parent (Z)) then
 302                Set_Left (Parent (Z), X);
 303             else
 304                pragma Assert (Z = Right (Parent (Z)));
 305                Set_Right (Parent (Z), X);
 306             end if;
 307
 308             Set_Parent (X, Parent (Z));
 309
 310             if Color (Z) = Black then
 311                Delete_Fixup (Tree, X);
 312             end if;
 313          end if;
 314
 315       elsif Right (Z) = Null_Node then
 316          pragma Assert (Z /= Tree.First);
 317
 318          X := Left (Z);
 319
 320          if Z = Tree.Last then
 321             Tree.Last := Max (X);
 322          end if;
 323
 324          if Z = Tree.Root then
 325             Tree.Root := X;
 326          elsif Z = Left (Parent (Z)) then
 327             Set_Left (Parent (Z), X);
 328          else
 329             pragma Assert (Z = Right (Parent (Z)));
 330             Set_Right (Parent (Z), X);
 331          end if;
 332
 333          Set_Parent (X, Parent (Z));
 334
 335          if Color (Z) = Black then
 336             Delete_Fixup (Tree, X);
 337          end if;
 338
 339       else
 340          pragma Assert (Z /= Tree.First);
 341          pragma Assert (Z /= Tree.Last);
 342
 343          Y := Next (Z);
 344          pragma Assert (Left (Y) = Null_Node);
 345
 346          X := Right (Y);
 347
 348          if X = Null_Node then
 349             if Y = Left (Parent (Y)) then
 350                pragma Assert (Parent (Y) /= Z);
 351                Delete_Swap (Tree, Z, Y);
 352                Set_Left (Parent (Z), Z);
 353
 354             else
 355                pragma Assert (Y = Right (Parent (Y)));
 356                pragma Assert (Parent (Y) = Z);
 357                Set_Parent (Y, Parent (Z));
 358
 359                if Z = Tree.Root then
 360                   Tree.Root := Y;
 361                elsif Z = Left (Parent (Z)) then
 362                   Set_Left (Parent (Z), Y);
 363                else
 364                   pragma Assert (Z = Right (Parent (Z)));
 365                   Set_Right (Parent (Z), Y);
 366                end if;
 367
 368                Set_Left (Y, Left (Z));
 369                Set_Parent (Left (Y), Y);
 370                Set_Right (Y, Z);
 371                Set_Parent (Z, Y);
 372                Set_Left (Z, Null_Node);
 373                Set_Right (Z, Null_Node);
 374
 375                declare
 376                   Y_Color : constant Color_Type := Color (Y);
 377                begin
 378                   Set_Color (Y, Color (Z));
 379                   Set_Color (Z, Y_Color);
 380                end;
 381             end if;
 382
 383             if Color (Z) = Black then
 384                Delete_Fixup (Tree, Z);
 385             end if;
 386
 387             pragma Assert (Left (Z) = Null_Node);
 388             pragma Assert (Right (Z) = Null_Node);
 389
 390             if Z = Right (Parent (Z)) then
 391                Set_Right (Parent (Z), Null_Node);
 392             else
 393                pragma Assert (Z = Left (Parent (Z)));
 394                Set_Left (Parent (Z), Null_Node);
 395             end if;
 396
 397          else
 398             if Y = Left (Parent (Y)) then
 399                pragma Assert (Parent (Y) /= Z);
 400
 401                Delete_Swap (Tree, Z, Y);
 402
 403                Set_Left (Parent (Z), X);
 404                Set_Parent (X, Parent (Z));
 405
 406             else
 407                pragma Assert (Y = Right (Parent (Y)));
 408                pragma Assert (Parent (Y) = Z);
 409
 410                Set_Parent (Y, Parent (Z));
 411
 412                if Z = Tree.Root then
 413                   Tree.Root := Y;
 414                elsif Z = Left (Parent (Z)) then
 415                   Set_Left (Parent (Z), Y);
 416                else
 417                   pragma Assert (Z = Right (Parent (Z)));
 418                   Set_Right (Parent (Z), Y);
 419                end if;
 420
 421                Set_Left (Y, Left (Z));
 422                Set_Parent (Left (Y), Y);
 423
 424                declare
 425                   Y_Color : constant Color_Type := Color (Y);
 426                begin
 427                   Set_Color (Y, Color (Z));
 428                   Set_Color (Z, Y_Color);
 429                end;
 430             end if;
 431
 432             if Color (Z) = Black then
 433                Delete_Fixup (Tree, X);
 434             end if;
 435          end if;
 436       end if;
 437
 438       Tree.Length := Tree.Length - 1;
 439    end Delete_Node_Sans_Free;
 440
 441    -----------------
 442    -- Delete_Swap --
 443    -----------------
 444
 445    procedure Delete_Swap
 446      (Tree : in out Tree_Type;
 447       Z, Y : Node_Access)
 448    is
 449       pragma Assert (Z /= Y);
 450       pragma Assert (Parent (Y) /= Z);
 451
 452       Y_Parent : constant Node_Access := Parent (Y);
 453       Y_Color  : constant Color_Type  := Color (Y);
 454
 455    begin
 456       Set_Parent (Y, Parent (Z));
 457       Set_Left (Y, Left (Z));
 458       Set_Right (Y, Right (Z));
 459       Set_Color (Y, Color (Z));
 460
 461       if Tree.Root = Z then
 462          Tree.Root := Y;
 463       elsif Right (Parent (Y)) = Z then
 464          Set_Right (Parent (Y), Y);
 465       else
 466          pragma Assert (Left (Parent (Y)) = Z);
 467          Set_Left (Parent (Y), Y);
 468       end if;
 469
 470       if Right (Y) /= Null_Node then
 471          Set_Parent (Right (Y), Y);
 472       end if;
 473
 474       if Left (Y) /= Null_Node then
 475          Set_Parent (Left (Y), Y);
 476       end if;
 477
 478       Set_Parent (Z, Y_Parent);
 479       Set_Color (Z, Y_Color);
 480       Set_Left (Z, Null_Node);
 481       Set_Right (Z, Null_Node);
 482    end Delete_Swap;
 483
 484    -------------------
 485    -- Generic_Equal --
 486    -------------------
 487
 488    function Generic_Equal (Left, Right : Tree_Type) return Boolean is
 489       L_Node : Node_Access;
 490       R_Node : Node_Access;
 491
 492    begin
 493       if Left.Length /= Right.Length then
 494          return False;
 495       end if;
 496
 497       L_Node := Left.First;
 498       R_Node := Right.First;
 499       while L_Node /= Null_Node loop
 500          if not Is_Equal (L_Node, R_Node) then
 501             return False;
 502          end if;
 503
 504          L_Node := Next (L_Node);
 505          R_Node := Next (R_Node);
 506       end loop;
 507
 508       return True;
 509    end Generic_Equal;
 510
 511    -----------------------
 512    -- Generic_Iteration --
 513    -----------------------
 514
 515    procedure Generic_Iteration (Tree : Tree_Type) is
 516       procedure Iterate (P : Node_Access);
 517
 518       -------------
 519       -- Iterate --
 520       -------------
 521
 522       procedure Iterate (P : Node_Access) is
 523          X : Node_Access := P;
 524       begin
 525          while X /= Null_Node loop
 526             Iterate (Left (X));
 527             Process (X);
 528             X := Right (X);
 529          end loop;
 530       end Iterate;
 531
 532    --  Start of processing for Generic_Iteration
 533
 534    begin
 535       Iterate (Tree.Root);
 536    end Generic_Iteration;
 537
 538    ------------------
 539    -- Generic_Read --
 540    ------------------
 541
 542    procedure Generic_Read (Tree : in out Tree_Type; N : Count_Type) is
 543
 544       pragma Assert (Tree.Length = 0);
 545       --  Clear and back node reinit was done by caller
 546
 547       Node, Last_Node : Node_Access;
 548
 549    begin
 550       if N = 0 then
 551          return;
 552       end if;
 553
 554       Node := New_Node;
 555       pragma Assert (Node /= Null_Node);
 556       pragma Assert (Color (Node) = Red);
 557
 558       Set_Color (Node, Black);
 559
 560       Tree.Root := Node;
 561       Tree.First := Node;
 562       Tree.Last := Node;
 563
 564       Tree.Length := 1;
 565
 566       for J in Count_Type range 2 .. N loop
 567          Last_Node := Node;
 568          pragma Assert (Last_Node = Tree.Last);
 569
 570          Node := New_Node;
 571          pragma Assert (Node /= Null_Node);
 572          pragma Assert (Color (Node) = Red);
 573
 574          Set_Right (Node => Last_Node, Right => Node);
 575          Tree.Last := Node;
 576          Set_Parent (Node => Node, Parent => Last_Node);
 577          Rebalance_For_Insert (Tree, Node);
 578          Tree.Length := Tree.Length + 1;
 579       end loop;
 580    end Generic_Read;
 581
 582    -------------------------------
 583    -- Generic_Reverse_Iteration --
 584    -------------------------------
 585
 586    procedure Generic_Reverse_Iteration (Tree : Tree_Type)
 587    is
 588       procedure Iterate (P : Node_Access);
 589
 590       -------------
 591       -- Iterate --
 592       -------------
 593
 594       procedure Iterate (P : Node_Access) is
 595          X : Node_Access := P;
 596       begin
 597          while X /= Null_Node loop
 598             Iterate (Right (X));
 599             Process (X);
 600             X := Left (X);
 601          end loop;
 602       end Iterate;
 603
 604    --  Start of processing for Generic_Reverse_Iteration
 605
 606    begin
 607       Iterate (Tree.Root);
 608    end Generic_Reverse_Iteration;
 609
 610    -----------------
 611    -- Left_Rotate --
 612    -----------------
 613
 614    procedure Left_Rotate (Tree : in out Tree_Type; X : Node_Access) is
 615
 616       --  CLR p266 ???
 617
 618       Y : constant Node_Access := Right (X);
 619       pragma Assert (Y /= Null_Node);
 620
 621    begin
 622       Set_Right (X, Left (Y));
 623
 624       if Left (Y) /= Null_Node then
 625          Set_Parent (Left (Y), X);
 626       end if;
 627
 628       Set_Parent (Y, Parent (X));
 629
 630       if X = Tree.Root then
 631          Tree.Root := Y;
 632       elsif X = Left (Parent (X)) then
 633          Set_Left (Parent (X), Y);
 634       else
 635          pragma Assert (X = Right (Parent (X)));
 636          Set_Right (Parent (X), Y);
 637       end if;
 638
 639       Set_Left (Y, X);
 640       Set_Parent (X, Y);
 641    end Left_Rotate;
 642
 643    ---------
 644    -- Max --
 645    ---------
 646
 647    function Max (Node : Node_Access) return Node_Access is
 648
 649       --  CLR p248 ???
 650
 651       X : Node_Access := Node;
 652       Y : Node_Access;
 653
 654    begin
 655       loop
 656          Y := Right (X);
 657
 658          if Y = Null_Node then
 659             return X;
 660          end if;
 661
 662          X := Y;
 663       end loop;
 664    end Max;
 665
 666    ---------
 667    -- Min --
 668    ---------
 669
 670    function Min (Node : Node_Access) return Node_Access is
 671
 672       --  CLR p248 ???
 673
 674       X : Node_Access := Node;
 675       Y : Node_Access;
 676
 677    begin
 678       loop
 679          Y := Left (X);
 680
 681          if Y = Null_Node then
 682             return X;
 683          end if;
 684
 685          X := Y;
 686       end loop;
 687    end Min;
 688
 689    ----------
 690    -- Move --
 691    ----------
 692
 693    procedure Move (Target, Source : in out Tree_Type) is
 694    begin
 695       if Target.Length > 0 then
 696          raise Constraint_Error;
 697       end if;
 698
 699       Target := Source;
 700       Source := (First => Null_Node,
 701                  Last  => Null_Node,
 702                  Root  => Null_Node,
 703                  Length => 0);
 704    end Move;
 705
 706    ----------
 707    -- Next --
 708    ----------
 709
 710    function Next (Node : Node_Access) return Node_Access is
 711    begin
 712       --  CLR p249 ???
 713
 714       if Node = Null_Node then
 715          return Null_Node;
 716       end if;
 717
 718       if Right (Node) /= Null_Node then
 719          return Min (Right (Node));
 720       end if;
 721
 722       declare
 723          X : Node_Access := Node;
 724          Y : Node_Access := Parent (Node);
 725
 726       begin
 727          while Y /= Null_Node
 728            and then X = Right (Y)
 729          loop
 730             X := Y;
 731             Y := Parent (Y);
 732          end loop;
 733
 734          --  Why is this code commented out ???
 735
 736 --           if Right (X) /= Y then
 737 --              return Y;
 738 --           else
 739 --              return X;
 740 --           end if;
 741
 742          return Y;
 743       end;
 744    end Next;
 745
 746    --------------
 747    -- Previous --
 748    --------------
 749
 750    function Previous (Node : Node_Access) return Node_Access is
 751    begin
 752       if Node = Null_Node then
 753          return Null_Node;
 754       end if;
 755
 756       if Left (Node) /= Null_Node then
 757          return Max (Left (Node));
 758       end if;
 759
 760       declare
 761          X : Node_Access := Node;
 762          Y : Node_Access := Parent (Node);
 763
 764       begin
 765          while Y /= Null_Node
 766            and then X = Left (Y)
 767          loop
 768             X := Y;
 769             Y := Parent (Y);
 770          end loop;
 771
 772          --  Why is this code commented out ???
 773
 774 --           if Left (X) /= Y then
 775 --              return Y;
 776 --           else
 777 --              return X;
 778 --           end if;
 779
 780          return Y;
 781       end;
 782    end Previous;
 783
 784    --------------------------
 785    -- Rebalance_For_Insert --
 786    --------------------------
 787
 788    procedure Rebalance_For_Insert
 789      (Tree : in out Tree_Type;
 790       Node : Node_Access)
 791    is
 792       --  CLR p.268 ???
 793
 794       X : Node_Access := Node;
 795       pragma Assert (X /= Null_Node);
 796       pragma Assert (Color (X) = Red);
 797
 798       Y : Node_Access;
 799
 800    begin
 801       while X /= Tree.Root and then Color (Parent (X)) = Red loop
 802          if Parent (X) = Left (Parent (Parent (X))) then
 803             Y := Right (Parent (Parent (X)));
 804
 805             if Y /= Null_Node and then Color (Y) = Red then
 806                Set_Color (Parent (X), Black);
 807                Set_Color (Y, Black);
 808                Set_Color (Parent (Parent (X)), Red);
 809                X := Parent (Parent (X));
 810
 811             else
 812                if X = Right (Parent (X)) then
 813                   X := Parent (X);
 814                   Left_Rotate (Tree, X);
 815                end if;
 816
 817                Set_Color (Parent (X), Black);
 818                Set_Color (Parent (Parent (X)), Red);
 819                Right_Rotate (Tree, Parent (Parent (X)));
 820             end if;
 821
 822          else
 823             pragma Assert (Parent (X) = Right (Parent (Parent (X))));
 824
 825             Y := Left (Parent (Parent (X)));
 826
 827             if Y /= Null_Node and then Color (Y) = Red then
 828                Set_Color (Parent (X), Black);
 829                Set_Color (Y, Black);
 830                Set_Color (Parent (Parent (X)), Red);
 831                X := Parent (Parent (X));
 832
 833             else
 834                if X = Left (Parent (X)) then
 835                   X := Parent (X);
 836                   Right_Rotate (Tree, X);
 837                end if;
 838
 839                Set_Color (Parent (X), Black);
 840                Set_Color (Parent (Parent (X)), Red);
 841                Left_Rotate (Tree, Parent (Parent (X)));
 842             end if;
 843          end if;
 844       end loop;
 845
 846       Set_Color (Tree.Root, Black);
 847    end Rebalance_For_Insert;
 848
 849    ------------------
 850    -- Right_Rotate --
 851    ------------------
 852
 853    procedure Right_Rotate (Tree : in out Tree_Type; Y : Node_Access) is
 854       X : constant Node_Access := Left (Y);
 855       pragma Assert (X /= Null_Node);
 856
 857    begin
 858       Set_Left (Y, Right (X));
 859
 860       if Right (X) /= Null_Node then
 861          Set_Parent (Right (X), Y);
 862       end if;
 863
 864       Set_Parent (X, Parent (Y));
 865
 866       if Y = Tree.Root then
 867          Tree.Root := X;
 868       elsif Y = Left (Parent (Y)) then
 869          Set_Left (Parent (Y), X);
 870       else
 871          pragma Assert (Y = Right (Parent (Y)));
 872          Set_Right (Parent (Y), X);
 873       end if;
 874
 875       Set_Right (X, Y);
 876       Set_Parent (Y, X);
 877    end Right_Rotate;
 878
 879 end Ada.Containers.Red_Black_Trees.Generic_Operations;