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-2006, 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 with
 250            "attempt to tamper with cursors (container is busy)";
 251       end if;
 252
 253 --    pragma Assert (Tree.Length > 0);
 254 --    pragma Assert (Tree.Root /= null);
 255 --    pragma Assert (Tree.First /= null);
 256 --    pragma Assert (Tree.Last /= null);
 257 --    pragma Assert (Parent (Tree.Root) = null);
 258 --    pragma Assert ((Tree.Length > 1)
 259 --                      or else (Tree.First = Tree.Last
 260 --                                 and then Tree.First = Tree.Root));
 261 --    pragma Assert ((Left (Node) = null)
 262 --                      or else (Parent (Left (Node)) = Node));
 263 --    pragma Assert ((Right (Node) = null)
 264 --                      or else (Parent (Right (Node)) = Node));
 265 --    pragma Assert (((Parent (Node) = null) and then (Tree.Root = Node))
 266 --                      or else ((Parent (Node) /= null) and then
 267 --                                ((Left (Parent (Node)) = Node)
 268 --                                   or else (Right (Parent (Node)) = Node))));
 269
 270       if Left (Z) = null then
 271          if Right (Z) = null then
 272             if Z = Tree.First then
 273                Tree.First := Parent (Z);
 274             end if;
 275
 276             if Z = Tree.Last then
 277                Tree.Last := Parent (Z);
 278             end if;
 279
 280             if Color (Z) = Black then
 281                Delete_Fixup (Tree, Z);
 282             end if;
 283
 284             pragma Assert (Left (Z) = null);
 285             pragma Assert (Right (Z) = null);
 286
 287             if Z = Tree.Root then
 288                pragma Assert (Tree.Length = 1);
 289                pragma Assert (Parent (Z) = null);
 290                Tree.Root := null;
 291             elsif Z = Left (Parent (Z)) then
 292                Set_Left (Parent (Z), null);
 293             else
 294                pragma Assert (Z = Right (Parent (Z)));
 295                Set_Right (Parent (Z), null);
 296             end if;
 297
 298          else
 299             pragma Assert (Z /= Tree.Last);
 300
 301             X := Right (Z);
 302
 303             if Z = Tree.First then
 304                Tree.First := Min (X);
 305             end if;
 306
 307             if Z = Tree.Root then
 308                Tree.Root := X;
 309             elsif Z = Left (Parent (Z)) then
 310                Set_Left (Parent (Z), X);
 311             else
 312                pragma Assert (Z = Right (Parent (Z)));
 313                Set_Right (Parent (Z), X);
 314             end if;
 315
 316             Set_Parent (X, Parent (Z));
 317
 318             if Color (Z) = Black then
 319                Delete_Fixup (Tree, X);
 320             end if;
 321          end if;
 322
 323       elsif Right (Z) = null then
 324          pragma Assert (Z /= Tree.First);
 325
 326          X := Left (Z);
 327
 328          if Z = Tree.Last then
 329             Tree.Last := Max (X);
 330          end if;
 331
 332          if Z = Tree.Root then
 333             Tree.Root := X;
 334          elsif Z = Left (Parent (Z)) then
 335             Set_Left (Parent (Z), X);
 336          else
 337             pragma Assert (Z = Right (Parent (Z)));
 338             Set_Right (Parent (Z), X);
 339          end if;
 340
 341          Set_Parent (X, Parent (Z));
 342
 343          if Color (Z) = Black then
 344             Delete_Fixup (Tree, X);
 345          end if;
 346
 347       else
 348          pragma Assert (Z /= Tree.First);
 349          pragma Assert (Z /= Tree.Last);
 350
 351          Y := Next (Z);
 352          pragma Assert (Left (Y) = null);
 353
 354          X := Right (Y);
 355
 356          if X = null then
 357             if Y = Left (Parent (Y)) then
 358                pragma Assert (Parent (Y) /= Z);
 359                Delete_Swap (Tree, Z, Y);
 360                Set_Left (Parent (Z), Z);
 361
 362             else
 363                pragma Assert (Y = Right (Parent (Y)));
 364                pragma Assert (Parent (Y) = Z);
 365                Set_Parent (Y, Parent (Z));
 366
 367                if Z = Tree.Root then
 368                   Tree.Root := Y;
 369                elsif Z = Left (Parent (Z)) then
 370                   Set_Left (Parent (Z), Y);
 371                else
 372                   pragma Assert (Z = Right (Parent (Z)));
 373                   Set_Right (Parent (Z), Y);
 374                end if;
 375
 376                Set_Left (Y, Left (Z));
 377                Set_Parent (Left (Y), Y);
 378                Set_Right (Y, Z);
 379                Set_Parent (Z, Y);
 380                Set_Left (Z, null);
 381                Set_Right (Z, null);
 382
 383                declare
 384                   Y_Color : constant Color_Type := Color (Y);
 385                begin
 386                   Set_Color (Y, Color (Z));
 387                   Set_Color (Z, Y_Color);
 388                end;
 389             end if;
 390
 391             if Color (Z) = Black then
 392                Delete_Fixup (Tree, Z);
 393             end if;
 394
 395             pragma Assert (Left (Z) = null);
 396             pragma Assert (Right (Z) = null);
 397
 398             if Z = Right (Parent (Z)) then
 399                Set_Right (Parent (Z), null);
 400             else
 401                pragma Assert (Z = Left (Parent (Z)));
 402                Set_Left (Parent (Z), null);
 403             end if;
 404
 405          else
 406             if Y = Left (Parent (Y)) then
 407                pragma Assert (Parent (Y) /= Z);
 408
 409                Delete_Swap (Tree, Z, Y);
 410
 411                Set_Left (Parent (Z), X);
 412                Set_Parent (X, Parent (Z));
 413
 414             else
 415                pragma Assert (Y = Right (Parent (Y)));
 416                pragma Assert (Parent (Y) = Z);
 417
 418                Set_Parent (Y, Parent (Z));
 419
 420                if Z = Tree.Root then
 421                   Tree.Root := Y;
 422                elsif Z = Left (Parent (Z)) then
 423                   Set_Left (Parent (Z), Y);
 424                else
 425                   pragma Assert (Z = Right (Parent (Z)));
 426                   Set_Right (Parent (Z), Y);
 427                end if;
 428
 429                Set_Left (Y, Left (Z));
 430                Set_Parent (Left (Y), Y);
 431
 432                declare
 433                   Y_Color : constant Color_Type := Color (Y);
 434                begin
 435                   Set_Color (Y, Color (Z));
 436                   Set_Color (Z, Y_Color);
 437                end;
 438             end if;
 439
 440             if Color (Z) = Black then
 441                Delete_Fixup (Tree, X);
 442             end if;
 443          end if;
 444       end if;
 445
 446       Tree.Length := Tree.Length - 1;
 447    end Delete_Node_Sans_Free;
 448
 449    -----------------
 450    -- Delete_Swap --
 451    -----------------
 452
 453    procedure Delete_Swap
 454      (Tree : in out Tree_Type;
 455       Z, Y : Node_Access)
 456    is
 457       pragma Assert (Z /= Y);
 458       pragma Assert (Parent (Y) /= Z);
 459
 460       Y_Parent : constant Node_Access := Parent (Y);
 461       Y_Color  : constant Color_Type  := Color (Y);
 462
 463    begin
 464       Set_Parent (Y, Parent (Z));
 465       Set_Left (Y, Left (Z));
 466       Set_Right (Y, Right (Z));
 467       Set_Color (Y, Color (Z));
 468
 469       if Tree.Root = Z then
 470          Tree.Root := Y;
 471       elsif Right (Parent (Y)) = Z then
 472          Set_Right (Parent (Y), Y);
 473       else
 474          pragma Assert (Left (Parent (Y)) = Z);
 475          Set_Left (Parent (Y), Y);
 476       end if;
 477
 478       if Right (Y) /= null then
 479          Set_Parent (Right (Y), Y);
 480       end if;
 481
 482       if Left (Y) /= null then
 483          Set_Parent (Left (Y), Y);
 484       end if;
 485
 486       Set_Parent (Z, Y_Parent);
 487       Set_Color (Z, Y_Color);
 488       Set_Left (Z, null);
 489       Set_Right (Z, null);
 490    end Delete_Swap;
 491
 492    --------------------
 493    -- Generic_Adjust --
 494    --------------------
 495
 496    procedure Generic_Adjust (Tree : in out Tree_Type) is
 497       N    : constant Count_Type := Tree.Length;
 498       Root : constant Node_Access := Tree.Root;
 499
 500    begin
 501       if N = 0 then
 502          pragma Assert (Root = null);
 503          pragma Assert (Tree.Busy = 0);
 504          pragma Assert (Tree.Lock = 0);
 505          return;
 506       end if;
 507
 508       Tree.Root := null;
 509       Tree.First := null;
 510       Tree.Last := null;
 511       Tree.Length := 0;
 512
 513       Tree.Root := Copy_Tree (Root);
 514       Tree.First := Min (Tree.Root);
 515       Tree.Last := Max (Tree.Root);
 516       Tree.Length := N;
 517    end Generic_Adjust;
 518
 519    -------------------
 520    -- Generic_Clear --
 521    -------------------
 522
 523    procedure Generic_Clear (Tree : in out Tree_Type) is
 524       Root : Node_Access := Tree.Root;
 525    begin
 526       if Tree.Busy > 0 then
 527          raise Program_Error with
 528            "attempt to tamper with cursors (container is busy)";
 529       end if;
 530
 531       Tree := (First  => null,
 532                Last   => null,
 533                Root   => null,
 534                Length => 0,
 535                Busy   => 0,
 536                Lock   => 0);
 537
 538       Delete_Tree (Root);
 539    end Generic_Clear;
 540
 541    -----------------------
 542    -- Generic_Copy_Tree --
 543    -----------------------
 544
 545    function Generic_Copy_Tree (Source_Root : Node_Access) return Node_Access is
 546       Target_Root : Node_Access := Copy_Node (Source_Root);
 547       P, X        : Node_Access;
 548
 549    begin
 550       if Right (Source_Root) /= null then
 551          Set_Right
 552            (Node  => Target_Root,
 553             Right => Generic_Copy_Tree (Right (Source_Root)));
 554
 555          Set_Parent
 556            (Node   => Right (Target_Root),
 557             Parent => Target_Root);
 558       end if;
 559
 560       P := Target_Root;
 561
 562       X := Left (Source_Root);
 563       while X /= null loop
 564          declare
 565             Y : constant Node_Access := Copy_Node (X);
 566          begin
 567             Set_Left (Node => P, Left => Y);
 568             Set_Parent (Node => Y, Parent => P);
 569
 570             if Right (X) /= null then
 571                Set_Right
 572                  (Node  => Y,
 573                   Right => Generic_Copy_Tree (Right (X)));
 574
 575                Set_Parent
 576                  (Node   => Right (Y),
 577                   Parent => Y);
 578             end if;
 579
 580             P := Y;
 581             X := Left (X);
 582          end;
 583       end loop;
 584
 585       return Target_Root;
 586    exception
 587       when others =>
 588          Delete_Tree (Target_Root);
 589          raise;
 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 with
 678            "attempt to tamper with cursors (container is busy)";
 679       end if;
 680
 681       Clear (Target);
 682
 683       Target := Source;
 684
 685       Source := (First  => null,
 686                  Last   => null,
 687                  Root   => null,
 688                  Length => 0,
 689                  Busy   => 0,
 690                  Lock   => 0);
 691    end Generic_Move;
 692
 693    ------------------
 694    -- Generic_Read --
 695    ------------------
 696
 697    procedure Generic_Read
 698      (Stream : access Root_Stream_Type'Class;
 699       Tree   : in out Tree_Type)
 700    is
 701       N : Count_Type'Base;
 702
 703       Node, Last_Node : Node_Access;
 704
 705    begin
 706       Clear (Tree);
 707
 708       Count_Type'Base'Read (Stream, N);
 709       pragma Assert (N >= 0);
 710
 711       if N = 0 then
 712          return;
 713       end if;
 714
 715       Node := Read_Node (Stream);
 716       pragma Assert (Node /= null);
 717       pragma Assert (Color (Node) = Red);
 718
 719       Set_Color (Node, Black);
 720
 721       Tree.Root := Node;
 722       Tree.First := Node;
 723       Tree.Last := Node;
 724
 725       Tree.Length := 1;
 726
 727       for J in Count_Type range 2 .. N loop
 728          Last_Node := Node;
 729          pragma Assert (Last_Node = Tree.Last);
 730
 731          Node := Read_Node (Stream);
 732          pragma Assert (Node /= null);
 733          pragma Assert (Color (Node) = Red);
 734
 735          Set_Right (Node => Last_Node, Right => Node);
 736          Tree.Last := Node;
 737          Set_Parent (Node => Node, Parent => Last_Node);
 738          Rebalance_For_Insert (Tree, Node);
 739          Tree.Length := Tree.Length + 1;
 740       end loop;
 741    end Generic_Read;
 742
 743    -------------------------------
 744    -- Generic_Reverse_Iteration --
 745    -------------------------------
 746
 747    procedure Generic_Reverse_Iteration (Tree : Tree_Type)
 748    is
 749       procedure Iterate (P : Node_Access);
 750
 751       -------------
 752       -- Iterate --
 753       -------------
 754
 755       procedure Iterate (P : Node_Access) is
 756          X : Node_Access := P;
 757       begin
 758          while X /= null loop
 759             Iterate (Right (X));
 760             Process (X);
 761             X := Left (X);
 762          end loop;
 763       end Iterate;
 764
 765    --  Start of processing for Generic_Reverse_Iteration
 766
 767    begin
 768       Iterate (Tree.Root);
 769    end Generic_Reverse_Iteration;
 770
 771    -------------------
 772    -- Generic_Write --
 773    -------------------
 774
 775    procedure Generic_Write
 776      (Stream : access Root_Stream_Type'Class;
 777       Tree   : Tree_Type)
 778    is
 779       procedure Process (Node : Node_Access);
 780       pragma Inline (Process);
 781
 782       procedure Iterate is
 783          new Generic_Iteration (Process);
 784
 785       -------------
 786       -- Process --
 787       -------------
 788
 789       procedure Process (Node : Node_Access) is
 790       begin
 791          Write_Node (Stream, Node);
 792       end Process;
 793
 794    --  Start of processing for Generic_Write
 795
 796    begin
 797       Count_Type'Base'Write (Stream, Tree.Length);
 798       Iterate (Tree);
 799    end Generic_Write;
 800
 801    -----------------
 802    -- Left_Rotate --
 803    -----------------
 804
 805    procedure Left_Rotate (Tree : in out Tree_Type; X : Node_Access) is
 806
 807       --  CLR p266 ???
 808
 809       Y : constant Node_Access := Right (X);
 810       pragma Assert (Y /= null);
 811
 812    begin
 813       Set_Right (X, Left (Y));
 814
 815       if Left (Y) /= null then
 816          Set_Parent (Left (Y), X);
 817       end if;
 818
 819       Set_Parent (Y, Parent (X));
 820
 821       if X = Tree.Root then
 822          Tree.Root := Y;
 823       elsif X = Left (Parent (X)) then
 824          Set_Left (Parent (X), Y);
 825       else
 826          pragma Assert (X = Right (Parent (X)));
 827          Set_Right (Parent (X), Y);
 828       end if;
 829
 830       Set_Left (Y, X);
 831       Set_Parent (X, Y);
 832    end Left_Rotate;
 833
 834    ---------
 835    -- Max --
 836    ---------
 837
 838    function Max (Node : Node_Access) return Node_Access is
 839
 840       --  CLR p248 ???
 841
 842       X : Node_Access := Node;
 843       Y : Node_Access;
 844
 845    begin
 846       loop
 847          Y := Right (X);
 848
 849          if Y = null then
 850             return X;
 851          end if;
 852
 853          X := Y;
 854       end loop;
 855    end Max;
 856
 857    ---------
 858    -- Min --
 859    ---------
 860
 861    function Min (Node : Node_Access) return Node_Access is
 862
 863       --  CLR p248 ???
 864
 865       X : Node_Access := Node;
 866       Y : Node_Access;
 867
 868    begin
 869       loop
 870          Y := Left (X);
 871
 872          if Y = null then
 873             return X;
 874          end if;
 875
 876          X := Y;
 877       end loop;
 878    end Min;
 879
 880    ----------
 881    -- Next --
 882    ----------
 883
 884    function Next (Node : Node_Access) return Node_Access is
 885    begin
 886       --  CLR p249 ???
 887
 888       if Node = null then
 889          return null;
 890       end if;
 891
 892       if Right (Node) /= null then
 893          return Min (Right (Node));
 894       end if;
 895
 896       declare
 897          X : Node_Access := Node;
 898          Y : Node_Access := Parent (Node);
 899
 900       begin
 901          while Y /= null
 902            and then X = Right (Y)
 903          loop
 904             X := Y;
 905             Y := Parent (Y);
 906          end loop;
 907
 908          --  Why is this code commented out ???
 909
 910 --           if Right (X) /= Y then
 911 --              return Y;
 912 --           else
 913 --              return X;
 914 --           end if;
 915
 916          return Y;
 917       end;
 918    end Next;
 919
 920    --------------
 921    -- Previous --
 922    --------------
 923
 924    function Previous (Node : Node_Access) return Node_Access is
 925    begin
 926       if Node = null then
 927          return null;
 928       end if;
 929
 930       if Left (Node) /= null then
 931          return Max (Left (Node));
 932       end if;
 933
 934       declare
 935          X : Node_Access := Node;
 936          Y : Node_Access := Parent (Node);
 937
 938       begin
 939          while Y /= null
 940            and then X = Left (Y)
 941          loop
 942             X := Y;
 943             Y := Parent (Y);
 944          end loop;
 945
 946          --  Why is this code commented out ???
 947
 948 --           if Left (X) /= Y then
 949 --              return Y;
 950 --           else
 951 --              return X;
 952 --           end if;
 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;