gcc/ada/a-crbtgo.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT LIBRARY COMPONENTS                          --
   4 --                                                                          --
   5 --        A D A . C O N T A I N E R S . R E D _ B L A C K _ T R E E S .     --
   6 --                    G E N E R I C _ O P E R A T I O N S                   --
   7 --                                                                          --
   8 --                                 B o d y                                  --
   9 --                                                                          --
  10 --          Copyright (C) 2004-2007, Free Software Foundation, Inc.         --
  11 --                                                                          --
  12 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  20 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  21 -- Boston, MA 02110-1301, USA.                                              --
  22 --                                                                          --
  23 -- As a special exception,  if other files  instantiate  generics from this --
  24 -- unit, or you link  this unit with other files  to produce an executable, --
  25 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  26 -- covered  by the  GNU  General  Public  License.  This exception does not --
  27 -- however invalidate  any other reasons why  the executable file  might be --
  28 -- covered by the  GNU Public License.                                      --
  29 --                                                                          --
  30 -- This unit was originally developed by Matthew J Heaney.                  --
  31 ------------------------------------------------------------------------------
  32
  33 --  The references below to "CLR" refer to the following book, from which
  34 --  several of the algorithms here were adapted:
  35 --     Introduction to Algorithms
  36 --     by Thomas H. Cormen, Charles E. Leiserson, Ronald L. Rivest
  37 --     Publisher: The MIT Press (June 18, 1990)
  38 --     ISBN: 0262031418
  39
  40 with System;  use type System.Address;
  41
  42 package body Ada.Containers.Red_Black_Trees.Generic_Operations is
  43
  44    -----------------------
  45    -- Local Subprograms --
  46    -----------------------
  47
  48    procedure Delete_Fixup (Tree : in out Tree_Type; Node : Node_Access);
  49
  50    procedure Delete_Swap (Tree : in out Tree_Type; Z, Y : Node_Access);
  51
  52    procedure Left_Rotate  (Tree : in out Tree_Type; X : Node_Access);
  53    procedure Right_Rotate (Tree : in out Tree_Type; Y : Node_Access);
  54
  55 --     ---------------------
  56 --     -- Check_Invariant --
  57 --     ---------------------
  58
  59 --     procedure Check_Invariant (Tree : Tree_Type) is
  60 --        Root : constant Node_Access := Tree.Root;
  61 --
  62 --        function Check (Node : Node_Access) return Natural;
  63 --
  64 --        -----------
  65 --        -- Check --
  66 --        -----------
  67 --
  68 --        function Check (Node : Node_Access) return Natural is
  69 --        begin
  70 --           if Node = null then
  71 --              return 0;
  72 --           end if;
  73 --
  74 --           if Color (Node) = Red then
  75 --              declare
  76 --                 L : constant Node_Access := Left (Node);
  77 --              begin
  78 --                 pragma Assert (L = null or else Color (L) = Black);
  79 --                 null;
  80 --              end;
  81 --
  82 --              declare
  83 --                 R : constant Node_Access := Right (Node);
  84 --              begin
  85 --                 pragma Assert (R = null or else Color (R) = Black);
  86 --                 null;
  87 --              end;
  88 --
  89 --              declare
  90 --                 NL : constant Natural := Check (Left (Node));
  91 --                 NR : constant Natural := Check (Right (Node));
  92 --              begin
  93 --                 pragma Assert (NL = NR);
  94 --                 return NL;
  95 --              end;
  96 --           end if;
  97 --
  98 --           declare
  99 --              NL : constant Natural := Check (Left (Node));
 100 --              NR : constant Natural := Check (Right (Node));
 101 --           begin
 102 --              pragma Assert (NL = NR);
 103 --              return NL + 1;
 104 --           end;
 105 --        end Check;
 106 --
 107 --     --  Start of processing for Check_Invariant
 108 --
 109 --     begin
 110 --        if Root = null then
 111 --           pragma Assert (Tree.First = null);
 112 --           pragma Assert (Tree.Last = null);
 113 --           pragma Assert (Tree.Length = 0);
 114 --           null;
 115 --
 116 --        else
 117 --           pragma Assert (Color (Root) = Black);
 118 --           pragma Assert (Tree.Length > 0);
 119 --           pragma Assert (Tree.Root /= null);
 120 --           pragma Assert (Tree.First /= null);
 121 --           pragma Assert (Tree.Last /= null);
 122 --           pragma Assert (Parent (Tree.Root) = null);
 123 --           pragma Assert ((Tree.Length > 1)
 124 --                             or else (Tree.First = Tree.Last
 125 --                                        and Tree.First = Tree.Root));
 126 --           pragma Assert (Left (Tree.First) = null);
 127 --           pragma Assert (Right (Tree.Last) = null);
 128 --
 129 --           declare
 130 --              L  : constant Node_Access := Left (Root);
 131 --              R  : constant Node_Access := Right (Root);
 132 --              NL : constant Natural := Check (L);
 133 --              NR : constant Natural := Check (R);
 134 --           begin
 135 --              pragma Assert (NL = NR);
 136 --              null;
 137 --           end;
 138 --        end if;
 139 --     end Check_Invariant;
 140
 141    ------------------
 142    -- Delete_Fixup --
 143    ------------------
 144
 145    procedure Delete_Fixup (Tree : in out Tree_Type; Node : Node_Access) is
 146
 147       --  CLR p274
 148
 149       X : Node_Access := Node;
 150       W : Node_Access;
 151
 152    begin
 153       while X /= Tree.Root
 154         and then Color (X) = Black
 155       loop
 156          if X = Left (Parent (X)) then
 157             W :=  Right (Parent (X));
 158
 159             if Color (W) = Red then
 160                Set_Color (W, Black);
 161                Set_Color (Parent (X), Red);
 162                Left_Rotate (Tree, Parent (X));
 163                W := Right (Parent (X));
 164             end if;
 165
 166             if (Left (W)  = null or else Color (Left (W)) = Black)
 167               and then
 168                (Right (W) = null or else Color (Right (W)) = Black)
 169             then
 170                Set_Color (W, Red);
 171                X := Parent (X);
 172
 173             else
 174                if Right (W) = null
 175                  or else Color (Right (W)) = Black
 176                then
 177                   if Left (W) /= null then
 178                      Set_Color (Left (W), Black);
 179                   end if;
 180
 181                   Set_Color (W, Red);
 182                   Right_Rotate (Tree, W);
 183                   W := Right (Parent (X));
 184                end if;
 185
 186                Set_Color (W, Color (Parent (X)));
 187                Set_Color (Parent (X), Black);
 188                Set_Color (Right (W), Black);
 189                Left_Rotate  (Tree, Parent (X));
 190                X := Tree.Root;
 191             end if;
 192
 193          else
 194             pragma Assert (X = Right (Parent (X)));
 195
 196             W :=  Left (Parent (X));
 197
 198             if Color (W) = Red then
 199                Set_Color (W, Black);
 200                Set_Color (Parent (X), Red);
 201                Right_Rotate (Tree, Parent (X));
 202                W := Left (Parent (X));
 203             end if;
 204
 205             if (Left (W)  = null or else Color (Left (W)) = Black)
 206                   and then
 207                (Right (W) = null or else Color (Right (W)) = Black)
 208             then
 209                Set_Color (W, Red);
 210                X := Parent (X);
 211
 212             else
 213                if Left (W) = null or else Color (Left (W)) = Black then
 214                   if Right (W) /= null then
 215                      Set_Color (Right (W), Black);
 216                   end if;
 217
 218                   Set_Color (W, Red);
 219                   Left_Rotate (Tree, W);
 220                   W := Left (Parent (X));
 221                end if;
 222
 223                Set_Color (W, Color (Parent (X)));
 224                Set_Color (Parent (X), Black);
 225                Set_Color (Left (W), Black);
 226                Right_Rotate (Tree, Parent (X));
 227                X := Tree.Root;
 228             end if;
 229          end if;
 230       end loop;
 231
 232       Set_Color (X, Black);
 233    end Delete_Fixup;
 234
 235    ---------------------------
 236    -- Delete_Node_Sans_Free --
 237    ---------------------------
 238
 239    procedure Delete_Node_Sans_Free
 240      (Tree : in out Tree_Type;
 241       Node : Node_Access)
 242    is
 243       --  CLR p273
 244
 245       X, Y : Node_Access;
 246
 247       Z : constant Node_Access := Node;
 248       pragma Assert (Z /= null);
 249
 250    begin
 251       if Tree.Busy > 0 then
 252          raise Program_Error with
 253            "attempt to tamper with cursors (container is busy)";
 254       end if;
 255
 256 --    pragma Assert (Tree.Length > 0);
 257 --    pragma Assert (Tree.Root /= null);
 258 --    pragma Assert (Tree.First /= null);
 259 --    pragma Assert (Tree.Last /= null);
 260 --    pragma Assert (Parent (Tree.Root) = null);
 261 --    pragma Assert ((Tree.Length > 1)
 262 --                      or else (Tree.First = Tree.Last
 263 --                                 and then Tree.First = Tree.Root));
 264 --    pragma Assert ((Left (Node) = null)
 265 --                      or else (Parent (Left (Node)) = Node));
 266 --    pragma Assert ((Right (Node) = null)
 267 --                      or else (Parent (Right (Node)) = Node));
 268 --    pragma Assert (((Parent (Node) = null) and then (Tree.Root = Node))
 269 --                      or else ((Parent (Node) /= null) and then
 270 --                                ((Left (Parent (Node)) = Node)
 271 --                                   or else (Right (Parent (Node)) = Node))));
 272
 273       if Left (Z) = null then
 274          if Right (Z) = null then
 275             if Z = Tree.First then
 276                Tree.First := Parent (Z);
 277             end if;
 278
 279             if Z = Tree.Last then
 280                Tree.Last := Parent (Z);
 281             end if;
 282
 283             if Color (Z) = Black then
 284                Delete_Fixup (Tree, Z);
 285             end if;
 286
 287             pragma Assert (Left (Z) = null);
 288             pragma Assert (Right (Z) = null);
 289
 290             if Z = Tree.Root then
 291                pragma Assert (Tree.Length = 1);
 292                pragma Assert (Parent (Z) = null);
 293                Tree.Root := null;
 294             elsif Z = Left (Parent (Z)) then
 295                Set_Left (Parent (Z), null);
 296             else
 297                pragma Assert (Z = Right (Parent (Z)));
 298                Set_Right (Parent (Z), null);
 299             end if;
 300
 301          else
 302             pragma Assert (Z /= Tree.Last);
 303
 304             X := Right (Z);
 305
 306             if Z = Tree.First then
 307                Tree.First := Min (X);
 308             end if;
 309
 310             if Z = Tree.Root then
 311                Tree.Root := X;
 312             elsif Z = Left (Parent (Z)) then
 313                Set_Left (Parent (Z), X);
 314             else
 315                pragma Assert (Z = Right (Parent (Z)));
 316                Set_Right (Parent (Z), X);
 317             end if;
 318
 319             Set_Parent (X, Parent (Z));
 320
 321             if Color (Z) = Black then
 322                Delete_Fixup (Tree, X);
 323             end if;
 324          end if;
 325
 326       elsif Right (Z) = null then
 327          pragma Assert (Z /= Tree.First);
 328
 329          X := Left (Z);
 330
 331          if Z = Tree.Last then
 332             Tree.Last := Max (X);
 333          end if;
 334
 335          if Z = Tree.Root then
 336             Tree.Root := X;
 337          elsif Z = Left (Parent (Z)) then
 338             Set_Left (Parent (Z), X);
 339          else
 340             pragma Assert (Z = Right (Parent (Z)));
 341             Set_Right (Parent (Z), X);
 342          end if;
 343
 344          Set_Parent (X, Parent (Z));
 345
 346          if Color (Z) = Black then
 347             Delete_Fixup (Tree, X);
 348          end if;
 349
 350       else
 351          pragma Assert (Z /= Tree.First);
 352          pragma Assert (Z /= Tree.Last);
 353
 354          Y := Next (Z);
 355          pragma Assert (Left (Y) = null);
 356
 357          X := Right (Y);
 358
 359          if X = null then
 360             if Y = Left (Parent (Y)) then
 361                pragma Assert (Parent (Y) /= Z);
 362                Delete_Swap (Tree, Z, Y);
 363                Set_Left (Parent (Z), Z);
 364
 365             else
 366                pragma Assert (Y = Right (Parent (Y)));
 367                pragma Assert (Parent (Y) = Z);
 368                Set_Parent (Y, Parent (Z));
 369
 370                if Z = Tree.Root then
 371                   Tree.Root := Y;
 372                elsif Z = Left (Parent (Z)) then
 373                   Set_Left (Parent (Z), Y);
 374                else
 375                   pragma Assert (Z = Right (Parent (Z)));
 376                   Set_Right (Parent (Z), Y);
 377                end if;
 378
 379                Set_Left (Y, Left (Z));
 380                Set_Parent (Left (Y), Y);
 381                Set_Right (Y, Z);
 382                Set_Parent (Z, Y);
 383                Set_Left (Z, null);
 384                Set_Right (Z, null);
 385
 386                declare
 387                   Y_Color : constant Color_Type := Color (Y);
 388                begin
 389                   Set_Color (Y, Color (Z));
 390                   Set_Color (Z, Y_Color);
 391                end;
 392             end if;
 393
 394             if Color (Z) = Black then
 395                Delete_Fixup (Tree, Z);
 396             end if;
 397
 398             pragma Assert (Left (Z) = null);
 399             pragma Assert (Right (Z) = null);
 400
 401             if Z = Right (Parent (Z)) then
 402                Set_Right (Parent (Z), null);
 403             else
 404                pragma Assert (Z = Left (Parent (Z)));
 405                Set_Left (Parent (Z), null);
 406             end if;
 407
 408          else
 409             if Y = Left (Parent (Y)) then
 410                pragma Assert (Parent (Y) /= Z);
 411
 412                Delete_Swap (Tree, Z, Y);
 413
 414                Set_Left (Parent (Z), X);
 415                Set_Parent (X, Parent (Z));
 416
 417             else
 418                pragma Assert (Y = Right (Parent (Y)));
 419                pragma Assert (Parent (Y) = Z);
 420
 421                Set_Parent (Y, Parent (Z));
 422
 423                if Z = Tree.Root then
 424                   Tree.Root := Y;
 425                elsif Z = Left (Parent (Z)) then
 426                   Set_Left (Parent (Z), Y);
 427                else
 428                   pragma Assert (Z = Right (Parent (Z)));
 429                   Set_Right (Parent (Z), Y);
 430                end if;
 431
 432                Set_Left (Y, Left (Z));
 433                Set_Parent (Left (Y), Y);
 434
 435                declare
 436                   Y_Color : constant Color_Type := Color (Y);
 437                begin
 438                   Set_Color (Y, Color (Z));
 439                   Set_Color (Z, Y_Color);
 440                end;
 441             end if;
 442
 443             if Color (Z) = Black then
 444                Delete_Fixup (Tree, X);
 445             end if;
 446          end if;
 447       end if;
 448
 449       Tree.Length := Tree.Length - 1;
 450    end Delete_Node_Sans_Free;
 451
 452    -----------------
 453    -- Delete_Swap --
 454    -----------------
 455
 456    procedure Delete_Swap
 457      (Tree : in out Tree_Type;
 458       Z, Y : Node_Access)
 459    is
 460       pragma Assert (Z /= Y);
 461       pragma Assert (Parent (Y) /= Z);
 462
 463       Y_Parent : constant Node_Access := Parent (Y);
 464       Y_Color  : constant Color_Type  := Color (Y);
 465
 466    begin
 467       Set_Parent (Y, Parent (Z));
 468       Set_Left (Y, Left (Z));
 469       Set_Right (Y, Right (Z));
 470       Set_Color (Y, Color (Z));
 471
 472       if Tree.Root = Z then
 473          Tree.Root := Y;
 474       elsif Right (Parent (Y)) = Z then
 475          Set_Right (Parent (Y), Y);
 476       else
 477          pragma Assert (Left (Parent (Y)) = Z);
 478          Set_Left (Parent (Y), Y);
 479       end if;
 480
 481       if Right (Y) /= null then
 482          Set_Parent (Right (Y), Y);
 483       end if;
 484
 485       if Left (Y) /= null then
 486          Set_Parent (Left (Y), Y);
 487       end if;
 488
 489       Set_Parent (Z, Y_Parent);
 490       Set_Color (Z, Y_Color);
 491       Set_Left (Z, null);
 492       Set_Right (Z, null);
 493    end Delete_Swap;
 494
 495    --------------------
 496    -- Generic_Adjust --
 497    --------------------
 498
 499    procedure Generic_Adjust (Tree : in out Tree_Type) is
 500       N    : constant Count_Type := Tree.Length;
 501       Root : constant Node_Access := Tree.Root;
 502
 503    begin
 504       if N = 0 then
 505          pragma Assert (Root = null);
 506          pragma Assert (Tree.Busy = 0);
 507          pragma Assert (Tree.Lock = 0);
 508          return;
 509       end if;
 510
 511       Tree.Root := null;
 512       Tree.First := null;
 513       Tree.Last := null;
 514       Tree.Length := 0;
 515
 516       Tree.Root := Copy_Tree (Root);
 517       Tree.First := Min (Tree.Root);
 518       Tree.Last := Max (Tree.Root);
 519       Tree.Length := N;
 520    end Generic_Adjust;
 521
 522    -------------------
 523    -- Generic_Clear --
 524    -------------------
 525
 526    procedure Generic_Clear (Tree : in out Tree_Type) is
 527       Root : Node_Access := Tree.Root;
 528    begin
 529       if Tree.Busy > 0 then
 530          raise Program_Error with
 531            "attempt to tamper with cursors (container is busy)";
 532       end if;
 533
 534       Tree := (First  => null,
 535                Last   => null,
 536                Root   => null,
 537                Length => 0,
 538                Busy   => 0,
 539                Lock   => 0);
 540
 541       Delete_Tree (Root);
 542    end Generic_Clear;
 543
 544    -----------------------
 545    -- Generic_Copy_Tree --
 546    -----------------------
 547
 548    function Generic_Copy_Tree (Source_Root : Node_Access) return Node_Access is
 549       Target_Root : Node_Access := Copy_Node (Source_Root);
 550       P, X        : Node_Access;
 551
 552    begin
 553       if Right (Source_Root) /= null then
 554          Set_Right
 555            (Node  => Target_Root,
 556             Right => Generic_Copy_Tree (Right (Source_Root)));
 557
 558          Set_Parent
 559            (Node   => Right (Target_Root),
 560             Parent => Target_Root);
 561       end if;
 562
 563       P := Target_Root;
 564
 565       X := Left (Source_Root);
 566       while X /= null loop
 567          declare
 568             Y : constant Node_Access := Copy_Node (X);
 569          begin
 570             Set_Left (Node => P, Left => Y);
 571             Set_Parent (Node => Y, Parent => P);
 572
 573             if Right (X) /= null then
 574                Set_Right
 575                  (Node  => Y,
 576                   Right => Generic_Copy_Tree (Right (X)));
 577
 578                Set_Parent
 579                  (Node   => Right (Y),
 580                   Parent => Y);
 581             end if;
 582
 583             P := Y;
 584             X := Left (X);
 585          end;
 586       end loop;
 587
 588       return Target_Root;
 589    exception
 590       when others =>
 591          Delete_Tree (Target_Root);
 592          raise;
 593    end Generic_Copy_Tree;
 594
 595    -------------------------
 596    -- Generic_Delete_Tree --
 597    -------------------------
 598
 599    procedure Generic_Delete_Tree (X : in out Node_Access) is
 600       Y : Node_Access;
 601       pragma Warnings (Off, Y);
 602    begin
 603       while X /= null loop
 604          Y := Right (X);
 605          Generic_Delete_Tree (Y);
 606          Y := Left (X);
 607          Free (X);
 608          X := Y;
 609       end loop;
 610    end Generic_Delete_Tree;
 611
 612    -------------------
 613    -- Generic_Equal --
 614    -------------------
 615
 616    function Generic_Equal (Left, Right : Tree_Type) return Boolean is
 617       L_Node : Node_Access;
 618       R_Node : Node_Access;
 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       L_Node := Left.First;
 630       R_Node := Right.First;
 631       while L_Node /= null loop
 632          if not Is_Equal (L_Node, R_Node) then
 633             return False;
 634          end if;
 635
 636          L_Node := Next (L_Node);
 637          R_Node := Next (R_Node);
 638       end loop;
 639
 640       return True;
 641    end Generic_Equal;
 642
 643    -----------------------
 644    -- Generic_Iteration --
 645    -----------------------
 646
 647    procedure Generic_Iteration (Tree : Tree_Type) is
 648       procedure Iterate (P : Node_Access);
 649
 650       -------------
 651       -- Iterate --
 652       -------------
 653
 654       procedure Iterate (P : Node_Access) is
 655          X : Node_Access := P;
 656       begin
 657          while X /= null loop
 658             Iterate (Left (X));
 659             Process (X);
 660             X := Right (X);
 661          end loop;
 662       end Iterate;
 663
 664    --  Start of processing for Generic_Iteration
 665
 666    begin
 667       Iterate (Tree.Root);
 668    end Generic_Iteration;
 669
 670    ------------------
 671    -- Generic_Move --
 672    ------------------
 673
 674    procedure Generic_Move (Target, Source : in out Tree_Type) is
 675    begin
 676       if Target'Address = Source'Address then
 677          return;
 678       end if;
 679
 680       if Source.Busy > 0 then
 681          raise Program_Error with
 682            "attempt to tamper with cursors (container is busy)";
 683       end if;
 684
 685       Clear (Target);
 686
 687       Target := Source;
 688
 689       Source := (First  => null,
 690                  Last   => null,
 691                  Root   => null,
 692                  Length => 0,
 693                  Busy   => 0,
 694                  Lock   => 0);
 695    end Generic_Move;
 696
 697    ------------------
 698    -- Generic_Read --
 699    ------------------
 700
 701    procedure Generic_Read
 702      (Stream : not null access Root_Stream_Type'Class;
 703       Tree   : in out Tree_Type)
 704    is
 705       N : Count_Type'Base;
 706
 707       Node, Last_Node : Node_Access;
 708
 709    begin
 710       Clear (Tree);
 711
 712       Count_Type'Base'Read (Stream, N);
 713       pragma Assert (N >= 0);
 714
 715       if N = 0 then
 716          return;
 717       end if;
 718
 719       Node := Read_Node (Stream);
 720       pragma Assert (Node /= null);
 721       pragma Assert (Color (Node) = Red);
 722
 723       Set_Color (Node, Black);
 724
 725       Tree.Root := Node;
 726       Tree.First := Node;
 727       Tree.Last := Node;
 728
 729       Tree.Length := 1;
 730
 731       for J in Count_Type range 2 .. N loop
 732          Last_Node := Node;
 733          pragma Assert (Last_Node = Tree.Last);
 734
 735          Node := Read_Node (Stream);
 736          pragma Assert (Node /= null);
 737          pragma Assert (Color (Node) = Red);
 738
 739          Set_Right (Node => Last_Node, Right => Node);
 740          Tree.Last := Node;
 741          Set_Parent (Node => Node, Parent => Last_Node);
 742          Rebalance_For_Insert (Tree, Node);
 743          Tree.Length := Tree.Length + 1;
 744       end loop;
 745    end Generic_Read;
 746
 747    -------------------------------
 748    -- Generic_Reverse_Iteration --
 749    -------------------------------
 750
 751    procedure Generic_Reverse_Iteration (Tree : Tree_Type)
 752    is
 753       procedure Iterate (P : Node_Access);
 754
 755       -------------
 756       -- Iterate --
 757       -------------
 758
 759       procedure Iterate (P : Node_Access) is
 760          X : Node_Access := P;
 761       begin
 762          while X /= null loop
 763             Iterate (Right (X));
 764             Process (X);
 765             X := Left (X);
 766          end loop;
 767       end Iterate;
 768
 769    --  Start of processing for Generic_Reverse_Iteration
 770
 771    begin
 772       Iterate (Tree.Root);
 773    end Generic_Reverse_Iteration;
 774
 775    -------------------
 776    -- Generic_Write --
 777    -------------------
 778
 779    procedure Generic_Write
 780      (Stream : not null access Root_Stream_Type'Class;
 781       Tree   : Tree_Type)
 782    is
 783       procedure Process (Node : Node_Access);
 784       pragma Inline (Process);
 785
 786       procedure Iterate is
 787          new Generic_Iteration (Process);
 788
 789       -------------
 790       -- Process --
 791       -------------
 792
 793       procedure Process (Node : Node_Access) is
 794       begin
 795          Write_Node (Stream, Node);
 796       end Process;
 797
 798    --  Start of processing for Generic_Write
 799
 800    begin
 801       Count_Type'Base'Write (Stream, Tree.Length);
 802       Iterate (Tree);
 803    end Generic_Write;
 804
 805    -----------------
 806    -- Left_Rotate --
 807    -----------------
 808
 809    procedure Left_Rotate (Tree : in out Tree_Type; X : Node_Access) is
 810
 811       --  CLR p266
 812
 813       Y : constant Node_Access := Right (X);
 814       pragma Assert (Y /= null);
 815
 816    begin
 817       Set_Right (X, Left (Y));
 818
 819       if Left (Y) /= null then
 820          Set_Parent (Left (Y), X);
 821       end if;
 822
 823       Set_Parent (Y, Parent (X));
 824
 825       if X = Tree.Root then
 826          Tree.Root := Y;
 827       elsif X = Left (Parent (X)) then
 828          Set_Left (Parent (X), Y);
 829       else
 830          pragma Assert (X = Right (Parent (X)));
 831          Set_Right (Parent (X), Y);
 832       end if;
 833
 834       Set_Left (Y, X);
 835       Set_Parent (X, Y);
 836    end Left_Rotate;
 837
 838    ---------
 839    -- Max --
 840    ---------
 841
 842    function Max (Node : Node_Access) return Node_Access is
 843
 844       --  CLR p248
 845
 846       X : Node_Access := Node;
 847       Y : Node_Access;
 848
 849    begin
 850       loop
 851          Y := Right (X);
 852
 853          if Y = null then
 854             return X;
 855          end if;
 856
 857          X := Y;
 858       end loop;
 859    end Max;
 860
 861    ---------
 862    -- Min --
 863    ---------
 864
 865    function Min (Node : Node_Access) return Node_Access is
 866
 867       --  CLR p248
 868
 869       X : Node_Access := Node;
 870       Y : Node_Access;
 871
 872    begin
 873       loop
 874          Y := Left (X);
 875
 876          if Y = null then
 877             return X;
 878          end if;
 879
 880          X := Y;
 881       end loop;
 882    end Min;
 883
 884    ----------
 885    -- Next --
 886    ----------
 887
 888    function Next (Node : Node_Access) return Node_Access is
 889    begin
 890       --  CLR p249
 891
 892       if Node = null then
 893          return null;
 894       end if;
 895
 896       if Right (Node) /= null then
 897          return Min (Right (Node));
 898       end if;
 899
 900       declare
 901          X : Node_Access := Node;
 902          Y : Node_Access := Parent (Node);
 903
 904       begin
 905          while Y /= null
 906            and then X = Right (Y)
 907          loop
 908             X := Y;
 909             Y := Parent (Y);
 910          end loop;
 911
 912          return Y;
 913       end;
 914    end Next;
 915
 916    --------------
 917    -- Previous --
 918    --------------
 919
 920    function Previous (Node : Node_Access) return Node_Access is
 921    begin
 922       if Node = null then
 923          return null;
 924       end if;
 925
 926       if Left (Node) /= null then
 927          return Max (Left (Node));
 928       end if;
 929
 930       declare
 931          X : Node_Access := Node;
 932          Y : Node_Access := Parent (Node);
 933
 934       begin
 935          while Y /= null
 936            and then X = Left (Y)
 937          loop
 938             X := Y;
 939             Y := Parent (Y);
 940          end loop;
 941
 942          return Y;
 943       end;
 944    end Previous;
 945
 946    --------------------------
 947    -- Rebalance_For_Insert --
 948    --------------------------
 949
 950    procedure Rebalance_For_Insert
 951      (Tree : in out Tree_Type;
 952       Node : Node_Access)
 953    is
 954       --  CLR p.268
 955
 956       X : Node_Access := Node;
 957       pragma Assert (X /= null);
 958       pragma Assert (Color (X) = Red);
 959
 960       Y : Node_Access;
 961
 962    begin
 963       while X /= Tree.Root and then Color (Parent (X)) = Red loop
 964          if Parent (X) = Left (Parent (Parent (X))) then
 965             Y := Right (Parent (Parent (X)));
 966
 967             if Y /= null and then Color (Y) = Red then
 968                Set_Color (Parent (X), Black);
 969                Set_Color (Y, Black);
 970                Set_Color (Parent (Parent (X)), Red);
 971                X := Parent (Parent (X));
 972
 973             else
 974                if X = Right (Parent (X)) then
 975                   X := Parent (X);
 976                   Left_Rotate (Tree, X);
 977                end if;
 978
 979                Set_Color (Parent (X), Black);
 980                Set_Color (Parent (Parent (X)), Red);
 981                Right_Rotate (Tree, Parent (Parent (X)));
 982             end if;
 983
 984          else
 985             pragma Assert (Parent (X) = Right (Parent (Parent (X))));
 986
 987             Y := Left (Parent (Parent (X)));
 988
 989             if Y /= null and then Color (Y) = Red then
 990                Set_Color (Parent (X), Black);
 991                Set_Color (Y, Black);
 992                Set_Color (Parent (Parent (X)), Red);
 993                X := Parent (Parent (X));
 994
 995             else
 996                if X = Left (Parent (X)) then
 997                   X := Parent (X);
 998                   Right_Rotate (Tree, X);
 999                end if;
1000
1001                Set_Color (Parent (X), Black);
1002                Set_Color (Parent (Parent (X)), Red);
1003                Left_Rotate (Tree, Parent (Parent (X)));
1004             end if;
1005          end if;
1006       end loop;
1007
1008       Set_Color (Tree.Root, Black);
1009    end Rebalance_For_Insert;
1010
1011    ------------------
1012    -- Right_Rotate --
1013    ------------------
1014
1015    procedure Right_Rotate (Tree : in out Tree_Type; Y : Node_Access) is
1016       X : constant Node_Access := Left (Y);
1017       pragma Assert (X /= null);
1018
1019    begin
1020       Set_Left (Y, Right (X));
1021
1022       if Right (X) /= null then
1023          Set_Parent (Right (X), Y);
1024       end if;
1025
1026       Set_Parent (X, Parent (Y));
1027
1028       if Y = Tree.Root then
1029          Tree.Root := X;
1030       elsif Y = Left (Parent (Y)) then
1031          Set_Left (Parent (Y), X);
1032       else
1033          pragma Assert (Y = Right (Parent (Y)));
1034          Set_Right (Parent (Y), X);
1035       end if;
1036
1037       Set_Right (X, Y);
1038       Set_Parent (Y, X);
1039    end Right_Rotate;
1040
1041    ---------
1042    -- Vet --
1043    ---------
1044
1045    function Vet (Tree : Tree_Type; Node : Node_Access) return Boolean is
1046    begin
1047       if Node = null then
1048          return True;
1049       end if;
1050
1051       if Parent (Node) = Node
1052         or else Left (Node) = Node
1053         or else Right (Node) = Node
1054       then
1055          return False;
1056       end if;
1057
1058       if Tree.Length = 0
1059         or else Tree.Root = null
1060         or else Tree.First = null
1061         or else Tree.Last = null
1062       then
1063          return False;
1064       end if;
1065
1066       if Parent (Tree.Root) /= null then
1067          return False;
1068       end if;
1069
1070       if Left (Tree.First) /= null then
1071          return False;
1072       end if;
1073
1074       if Right (Tree.Last) /= null then
1075          return False;
1076       end if;
1077
1078       if Tree.Length = 1 then
1079          if Tree.First /= Tree.Last
1080            or else Tree.First /= Tree.Root
1081          then
1082             return False;
1083          end if;
1084
1085          if Node /= Tree.First then
1086             return False;
1087          end if;
1088
1089          if Parent (Node) /= null
1090            or else Left (Node) /= null
1091            or else Right (Node) /= null
1092          then
1093             return False;
1094          end if;
1095
1096          return True;
1097       end if;
1098
1099       if Tree.First = Tree.Last then
1100          return False;
1101       end if;
1102
1103       if Tree.Length = 2 then
1104          if Tree.First /= Tree.Root
1105            and then Tree.Last /= Tree.Root
1106          then
1107             return False;
1108          end if;
1109
1110          if Tree.First /= Node
1111            and then Tree.Last /= Node
1112          then
1113             return False;
1114          end if;
1115       end if;
1116
1117       if Left (Node) /= null
1118         and then Parent (Left (Node)) /= Node
1119       then
1120          return False;
1121       end if;
1122
1123       if Right (Node) /= null
1124         and then Parent (Right (Node)) /= Node
1125       then
1126          return False;
1127       end if;
1128
1129       if Parent (Node) = null then
1130          if Tree.Root /= Node then
1131             return False;
1132          end if;
1133
1134       elsif Left (Parent (Node)) /= Node
1135         and then Right (Parent (Node)) /= Node
1136       then
1137          return False;
1138       end if;
1139
1140       return True;
1141    end Vet;
1142
1143 end Ada.Containers.Red_Black_Trees.Generic_Operations;