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