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