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