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-2013, 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       BL : Natural renames Left'Unrestricted_Access.Busy;
 630       LL : Natural renames Left'Unrestricted_Access.Lock;
 631
 632       BR : Natural renames Right'Unrestricted_Access.Busy;
 633       LR : Natural renames Right'Unrestricted_Access.Lock;
 634
 635       L_Node : Node_Access;
 636       R_Node : Node_Access;
 637
 638       Result : Boolean;
 639
 640    begin
 641       if Left'Address = Right'Address then
 642          return True;
 643       end if;
 644
 645       if Left.Length /= Right.Length then
 646          return False;
 647       end if;
 648
 649       --  If the containers are empty, return a result immediately, so as to
 650       --  not manipulate the tamper bits unnecessarily.
 651
 652       if Left.Length = 0 then
 653          return True;
 654       end if;
 655
 656       --  Per AI05-0022, the container implementation is required to detect
 657       --  element tampering by a generic actual subprogram.
 658
 659       BL := BL + 1;
 660       LL := LL + 1;
 661
 662       BR := BR + 1;
 663       LR := LR + 1;
 664
 665       L_Node := Left.First;
 666       R_Node := Right.First;
 667       Result := True;
 668       while L_Node /= null loop
 669          if not Is_Equal (L_Node, R_Node) then
 670             Result := False;
 671             exit;
 672          end if;
 673
 674          L_Node := Next (L_Node);
 675          R_Node := Next (R_Node);
 676       end loop;
 677
 678       BL := BL - 1;
 679       LL := LL - 1;
 680
 681       BR := BR - 1;
 682       LR := LR - 1;
 683
 684       return Result;
 685
 686    exception
 687       when others =>
 688          BL := BL - 1;
 689          LL := LL - 1;
 690
 691          BR := BR - 1;
 692          LR := LR - 1;
 693
 694          raise;
 695    end Generic_Equal;
 696
 697    -----------------------
 698    -- Generic_Iteration --
 699    -----------------------
 700
 701    procedure Generic_Iteration (Tree : Tree_Type) is
 702       procedure Iterate (P : Node_Access);
 703
 704       -------------
 705       -- Iterate --
 706       -------------
 707
 708       procedure Iterate (P : Node_Access) is
 709          X : Node_Access := P;
 710       begin
 711          while X /= null loop
 712             Iterate (Left (X));
 713             Process (X);
 714             X := Right (X);
 715          end loop;
 716       end Iterate;
 717
 718    --  Start of processing for Generic_Iteration
 719
 720    begin
 721       Iterate (Tree.Root);
 722    end Generic_Iteration;
 723
 724    ------------------
 725    -- Generic_Move --
 726    ------------------
 727
 728    procedure Generic_Move (Target, Source : in out Tree_Type) is
 729    begin
 730       if Target'Address = Source'Address then
 731          return;
 732       end if;
 733
 734       if Source.Busy > 0 then
 735          raise Program_Error with
 736            "attempt to tamper with cursors (container is busy)";
 737       end if;
 738
 739       Clear (Target);
 740
 741       Target := Source;
 742
 743       Source := (First  => null,
 744                  Last   => null,
 745                  Root   => null,
 746                  Length => 0,
 747                  Busy   => 0,
 748                  Lock   => 0);
 749    end Generic_Move;
 750
 751    ------------------
 752    -- Generic_Read --
 753    ------------------
 754
 755    procedure Generic_Read
 756      (Stream : not null access Root_Stream_Type'Class;
 757       Tree   : in out Tree_Type)
 758    is
 759       N : Count_Type'Base;
 760
 761       Node, Last_Node : Node_Access;
 762
 763    begin
 764       Clear (Tree);
 765
 766       Count_Type'Base'Read (Stream, N);
 767       pragma Assert (N >= 0);
 768
 769       if N = 0 then
 770          return;
 771       end if;
 772
 773       Node := Read_Node (Stream);
 774       pragma Assert (Node /= null);
 775       pragma Assert (Color (Node) = Red);
 776
 777       Set_Color (Node, Black);
 778
 779       Tree.Root := Node;
 780       Tree.First := Node;
 781       Tree.Last := Node;
 782
 783       Tree.Length := 1;
 784
 785       for J in Count_Type range 2 .. N loop
 786          Last_Node := Node;
 787          pragma Assert (Last_Node = Tree.Last);
 788
 789          Node := Read_Node (Stream);
 790          pragma Assert (Node /= null);
 791          pragma Assert (Color (Node) = Red);
 792
 793          Set_Right (Node => Last_Node, Right => Node);
 794          Tree.Last := Node;
 795          Set_Parent (Node => Node, Parent => Last_Node);
 796          Rebalance_For_Insert (Tree, Node);
 797          Tree.Length := Tree.Length + 1;
 798       end loop;
 799    end Generic_Read;
 800
 801    -------------------------------
 802    -- Generic_Reverse_Iteration --
 803    -------------------------------
 804
 805    procedure Generic_Reverse_Iteration (Tree : Tree_Type)
 806    is
 807       procedure Iterate (P : Node_Access);
 808
 809       -------------
 810       -- Iterate --
 811       -------------
 812
 813       procedure Iterate (P : Node_Access) is
 814          X : Node_Access := P;
 815       begin
 816          while X /= null loop
 817             Iterate (Right (X));
 818             Process (X);
 819             X := Left (X);
 820          end loop;
 821       end Iterate;
 822
 823    --  Start of processing for Generic_Reverse_Iteration
 824
 825    begin
 826       Iterate (Tree.Root);
 827    end Generic_Reverse_Iteration;
 828
 829    -------------------
 830    -- Generic_Write --
 831    -------------------
 832
 833    procedure Generic_Write
 834      (Stream : not null access Root_Stream_Type'Class;
 835       Tree   : Tree_Type)
 836    is
 837       procedure Process (Node : Node_Access);
 838       pragma Inline (Process);
 839
 840       procedure Iterate is
 841          new Generic_Iteration (Process);
 842
 843       -------------
 844       -- Process --
 845       -------------
 846
 847       procedure Process (Node : Node_Access) is
 848       begin
 849          Write_Node (Stream, Node);
 850       end Process;
 851
 852    --  Start of processing for Generic_Write
 853
 854    begin
 855       Count_Type'Base'Write (Stream, Tree.Length);
 856       Iterate (Tree);
 857    end Generic_Write;
 858
 859    -----------------
 860    -- Left_Rotate --
 861    -----------------
 862
 863    procedure Left_Rotate (Tree : in out Tree_Type; X : Node_Access) is
 864
 865       --  CLR p266
 866
 867       Y : constant Node_Access := Right (X);
 868       pragma Assert (Y /= null);
 869
 870    begin
 871       Set_Right (X, Left (Y));
 872
 873       if Left (Y) /= null then
 874          Set_Parent (Left (Y), X);
 875       end if;
 876
 877       Set_Parent (Y, Parent (X));
 878
 879       if X = Tree.Root then
 880          Tree.Root := Y;
 881       elsif X = Left (Parent (X)) then
 882          Set_Left (Parent (X), Y);
 883       else
 884          pragma Assert (X = Right (Parent (X)));
 885          Set_Right (Parent (X), Y);
 886       end if;
 887
 888       Set_Left (Y, X);
 889       Set_Parent (X, Y);
 890    end Left_Rotate;
 891
 892    ---------
 893    -- Max --
 894    ---------
 895
 896    function Max (Node : Node_Access) return Node_Access is
 897
 898       --  CLR p248
 899
 900       X : Node_Access := Node;
 901       Y : Node_Access;
 902
 903    begin
 904       loop
 905          Y := Right (X);
 906
 907          if Y = null then
 908             return X;
 909          end if;
 910
 911          X := Y;
 912       end loop;
 913    end Max;
 914
 915    ---------
 916    -- Min --
 917    ---------
 918
 919    function Min (Node : Node_Access) return Node_Access is
 920
 921       --  CLR p248
 922
 923       X : Node_Access := Node;
 924       Y : Node_Access;
 925
 926    begin
 927       loop
 928          Y := Left (X);
 929
 930          if Y = null then
 931             return X;
 932          end if;
 933
 934          X := Y;
 935       end loop;
 936    end Min;
 937
 938    ----------
 939    -- Next --
 940    ----------
 941
 942    function Next (Node : Node_Access) return Node_Access is
 943    begin
 944       --  CLR p249
 945
 946       if Node = null then
 947          return null;
 948       end if;
 949
 950       if Right (Node) /= null then
 951          return Min (Right (Node));
 952       end if;
 953
 954       declare
 955          X : Node_Access := Node;
 956          Y : Node_Access := Parent (Node);
 957
 958       begin
 959          while Y /= null
 960            and then X = Right (Y)
 961          loop
 962             X := Y;
 963             Y := Parent (Y);
 964          end loop;
 965
 966          return Y;
 967       end;
 968    end Next;
 969
 970    --------------
 971    -- Previous --
 972    --------------
 973
 974    function Previous (Node : Node_Access) return Node_Access is
 975    begin
 976       if Node = null then
 977          return null;
 978       end if;
 979
 980       if Left (Node) /= null then
 981          return Max (Left (Node));
 982       end if;
 983
 984       declare
 985          X : Node_Access := Node;
 986          Y : Node_Access := Parent (Node);
 987
 988       begin
 989          while Y /= null
 990            and then X = Left (Y)
 991          loop
 992             X := Y;
 993             Y := Parent (Y);
 994          end loop;
 995
 996          return Y;
 997       end;
 998    end Previous;
 999
1000    --------------------------
1001    -- Rebalance_For_Insert --
1002    --------------------------
1003
1004    procedure Rebalance_For_Insert
1005      (Tree : in out Tree_Type;
1006       Node : Node_Access)
1007    is
1008       --  CLR p.268
1009
1010       X : Node_Access := Node;
1011       pragma Assert (X /= null);
1012       pragma Assert (Color (X) = Red);
1013
1014       Y : Node_Access;
1015
1016    begin
1017       while X /= Tree.Root and then Color (Parent (X)) = Red loop
1018          if Parent (X) = Left (Parent (Parent (X))) then
1019             Y := Right (Parent (Parent (X)));
1020
1021             if Y /= null and then Color (Y) = Red then
1022                Set_Color (Parent (X), Black);
1023                Set_Color (Y, Black);
1024                Set_Color (Parent (Parent (X)), Red);
1025                X := Parent (Parent (X));
1026
1027             else
1028                if X = Right (Parent (X)) then
1029                   X := Parent (X);
1030                   Left_Rotate (Tree, X);
1031                end if;
1032
1033                Set_Color (Parent (X), Black);
1034                Set_Color (Parent (Parent (X)), Red);
1035                Right_Rotate (Tree, Parent (Parent (X)));
1036             end if;
1037
1038          else
1039             pragma Assert (Parent (X) = Right (Parent (Parent (X))));
1040
1041             Y := Left (Parent (Parent (X)));
1042
1043             if Y /= null and then Color (Y) = Red then
1044                Set_Color (Parent (X), Black);
1045                Set_Color (Y, Black);
1046                Set_Color (Parent (Parent (X)), Red);
1047                X := Parent (Parent (X));
1048
1049             else
1050                if X = Left (Parent (X)) then
1051                   X := Parent (X);
1052                   Right_Rotate (Tree, X);
1053                end if;
1054
1055                Set_Color (Parent (X), Black);
1056                Set_Color (Parent (Parent (X)), Red);
1057                Left_Rotate (Tree, Parent (Parent (X)));
1058             end if;
1059          end if;
1060       end loop;
1061
1062       Set_Color (Tree.Root, Black);
1063    end Rebalance_For_Insert;
1064
1065    ------------------
1066    -- Right_Rotate --
1067    ------------------
1068
1069    procedure Right_Rotate (Tree : in out Tree_Type; Y : Node_Access) is
1070       X : constant Node_Access := Left (Y);
1071       pragma Assert (X /= null);
1072
1073    begin
1074       Set_Left (Y, Right (X));
1075
1076       if Right (X) /= null then
1077          Set_Parent (Right (X), Y);
1078       end if;
1079
1080       Set_Parent (X, Parent (Y));
1081
1082       if Y = Tree.Root then
1083          Tree.Root := X;
1084       elsif Y = Left (Parent (Y)) then
1085          Set_Left (Parent (Y), X);
1086       else
1087          pragma Assert (Y = Right (Parent (Y)));
1088          Set_Right (Parent (Y), X);
1089       end if;
1090
1091       Set_Right (X, Y);
1092       Set_Parent (Y, X);
1093    end Right_Rotate;
1094
1095    ---------
1096    -- Vet --
1097    ---------
1098
1099    function Vet (Tree : Tree_Type; Node : Node_Access) return Boolean is
1100    begin
1101       if Node = null then
1102          return True;
1103       end if;
1104
1105       if Parent (Node) = Node
1106         or else Left (Node) = Node
1107         or else Right (Node) = Node
1108       then
1109          return False;
1110       end if;
1111
1112       if Tree.Length = 0
1113         or else Tree.Root = null
1114         or else Tree.First = null
1115         or else Tree.Last = null
1116       then
1117          return False;
1118       end if;
1119
1120       if Parent (Tree.Root) /= null then
1121          return False;
1122       end if;
1123
1124       if Left (Tree.First) /= null then
1125          return False;
1126       end if;
1127
1128       if Right (Tree.Last) /= null then
1129          return False;
1130       end if;
1131
1132       if Tree.Length = 1 then
1133          if Tree.First /= Tree.Last
1134            or else Tree.First /= Tree.Root
1135          then
1136             return False;
1137          end if;
1138
1139          if Node /= Tree.First then
1140             return False;
1141          end if;
1142
1143          if Parent (Node) /= null
1144            or else Left (Node) /= null
1145            or else Right (Node) /= null
1146          then
1147             return False;
1148          end if;
1149
1150          return True;
1151       end if;
1152
1153       if Tree.First = Tree.Last then
1154          return False;
1155       end if;
1156
1157       if Tree.Length = 2 then
1158          if Tree.First /= Tree.Root
1159            and then Tree.Last /= Tree.Root
1160          then
1161             return False;
1162          end if;
1163
1164          if Tree.First /= Node
1165            and then Tree.Last /= Node
1166          then
1167             return False;
1168          end if;
1169       end if;
1170
1171       if Left (Node) /= null
1172         and then Parent (Left (Node)) /= Node
1173       then
1174          return False;
1175       end if;
1176
1177       if Right (Node) /= null
1178         and then Parent (Right (Node)) /= Node
1179       then
1180          return False;
1181       end if;
1182
1183       if Parent (Node) = null then
1184          if Tree.Root /= Node then
1185             return False;
1186          end if;
1187
1188       elsif Left (Parent (Node)) /= Node
1189         and then Right (Parent (Node)) /= Node
1190       then
1191          return False;
1192       end if;
1193
1194       return True;
1195    end Vet;
1196
1197 end Ada.Containers.Red_Black_Trees.Generic_Operations;