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