gcc/ada/a-crbtgk.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT LIBRARY COMPONENTS                          --
   4 --                                                                          --
   5 --               ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_KEYS                --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --             Copyright (C) 2004 Free Software Foundation, Inc.            --
  10 --                                                                          --
  11 -- This specification is derived from the Ada Reference Manual for use with --
  12 -- GNAT. The copyright notice above, and the license provisions that follow --
  13 -- apply solely to the  contents of the part following the private keyword. --
  14 --                                                                          --
  15 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  16 -- terms of the  GNU General Public License as published  by the Free Soft- --
  17 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  18 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  19 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  20 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  21 -- for  more details.  You should have  received  a copy of the GNU General --
  22 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  23 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  24 -- MA 02111-1307, USA.                                                      --
  25 --                                                                          --
  26 -- As a special exception,  if other files  instantiate  generics from this --
  27 -- unit, or you link  this unit with other files  to produce an executable, --
  28 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  29 -- covered  by the  GNU  General  Public  License.  This exception does not --
  30 -- however invalidate  any other reasons why  the executable file  might be --
  31 -- covered by the  GNU Public License.                                      --
  32 --                                                                          --
  33 -- This unit was originally developed by Matthew J Heaney.                  --
  34 ------------------------------------------------------------------------------
  35
  36 package body Ada.Containers.Red_Black_Trees.Generic_Keys is
  37
  38    package Ops renames Tree_Operations;
  39
  40    -------------
  41    -- Ceiling --
  42    -------------
  43
  44    --  AKA Lower_Bound
  45
  46    function Ceiling (Tree : Tree_Type; Key  : Key_Type) return Node_Access is
  47       Y : Node_Access;
  48       X : Node_Access := Tree.Root;
  49
  50    begin
  51       while X /= Ops.Null_Node loop
  52          if Is_Greater_Key_Node (Key, X) then
  53             X := Ops.Right (X);
  54          else
  55             Y := X;
  56             X := Ops.Left (X);
  57          end if;
  58       end loop;
  59
  60       return Y;
  61    end Ceiling;
  62
  63    ----------
  64    -- Find --
  65    ----------
  66
  67    function Find (Tree : Tree_Type; Key  : Key_Type) return Node_Access is
  68       Y : Node_Access;
  69       X : Node_Access := Tree.Root;
  70
  71    begin
  72       while X /= Ops.Null_Node loop
  73          if Is_Greater_Key_Node (Key, X) then
  74             X := Ops.Right (X);
  75          else
  76             Y := X;
  77             X := Ops.Left (X);
  78          end if;
  79       end loop;
  80
  81       if Y = Ops.Null_Node then
  82          return Ops.Null_Node;
  83       end if;
  84
  85       if Is_Less_Key_Node (Key, Y) then
  86          return Ops.Null_Node;
  87       end if;
  88
  89       return Y;
  90    end Find;
  91
  92    -----------
  93    -- Floor --
  94    -----------
  95
  96    function Floor (Tree : Tree_Type; Key  : Key_Type) return Node_Access is
  97       Y : Node_Access;
  98       X : Node_Access := Tree.Root;
  99
 100    begin
 101       while X /= Ops.Null_Node loop
 102          if Is_Less_Key_Node (Key, X) then
 103             X := Ops.Left (X);
 104          else
 105             Y := X;
 106             X := Ops.Right (X);
 107          end if;
 108       end loop;
 109
 110       return Y;
 111    end Floor;
 112
 113    --------------------------------
 114    -- Generic_Conditional_Insert --
 115    --------------------------------
 116
 117    procedure Generic_Conditional_Insert
 118      (Tree    : in out Tree_Type;
 119       Key     : Key_Type;
 120       Node    : out Node_Access;
 121       Success : out Boolean)
 122    is
 123       Y : Node_Access := Ops.Null_Node;
 124       X : Node_Access := Tree.Root;
 125
 126    begin
 127       Success := True;
 128       while X /= Ops.Null_Node loop
 129          Y := X;
 130          Success := Is_Less_Key_Node (Key, X);
 131
 132          if Success then
 133             X := Ops.Left (X);
 134          else
 135             X := Ops.Right (X);
 136          end if;
 137       end loop;
 138
 139       Node := Y;
 140
 141       if Success then
 142          if Node = Tree.First then
 143             Insert_Post (Tree, X, Y, Key, Node);
 144             return;
 145          end if;
 146
 147          Node := Ops.Previous (Node);
 148       end if;
 149
 150       if Is_Greater_Key_Node (Key, Node) then
 151          Insert_Post (Tree, X, Y, Key, Node);
 152          Success := True;
 153          return;
 154       end if;
 155
 156       Success := False;
 157    end Generic_Conditional_Insert;
 158
 159    ------------------------------------------
 160    -- Generic_Conditional_Insert_With_Hint --
 161    ------------------------------------------
 162
 163    procedure Generic_Conditional_Insert_With_Hint
 164      (Tree     : in out Tree_Type;
 165       Position : Node_Access;
 166       Key      : Key_Type;
 167       Node     : out Node_Access;
 168       Success  : out Boolean)
 169    is
 170    begin
 171       if Position = Ops.Null_Node then  -- largest
 172          if Tree.Length > 0
 173            and then Is_Greater_Key_Node (Key, Tree.Last)
 174          then
 175             Insert_Post (Tree, Ops.Null_Node, Tree.Last, Key, Node);
 176             Success := True;
 177          else
 178             Conditional_Insert_Sans_Hint (Tree, Key, Node, Success);
 179          end if;
 180
 181          return;
 182       end if;
 183
 184       pragma Assert (Tree.Length > 0);
 185
 186       if Is_Less_Key_Node (Key, Position) then
 187          if Position = Tree.First then
 188             Insert_Post (Tree, Position, Position, Key, Node);
 189             Success := True;
 190             return;
 191          end if;
 192
 193          declare
 194             Before : constant Node_Access := Ops.Previous (Position);
 195
 196          begin
 197             if Is_Greater_Key_Node (Key, Before) then
 198                if Ops.Right (Before) = Ops.Null_Node then
 199                   Insert_Post (Tree, Ops.Null_Node, Before, Key, Node);
 200                else
 201                   Insert_Post (Tree, Position, Position, Key, Node);
 202                end if;
 203
 204                Success := True;
 205
 206             else
 207                Conditional_Insert_Sans_Hint (Tree, Key, Node, Success);
 208             end if;
 209          end;
 210
 211          return;
 212       end if;
 213
 214       if Is_Greater_Key_Node (Key, Position) then
 215          if Position = Tree.Last then
 216             Insert_Post (Tree, Ops.Null_Node, Tree.Last, Key, Node);
 217             Success := True;
 218             return;
 219          end if;
 220
 221          declare
 222             After : constant Node_Access := Ops.Next (Position);
 223
 224          begin
 225             if Is_Less_Key_Node (Key, After) then
 226                if Ops.Right (Position) = Ops.Null_Node then
 227                   Insert_Post (Tree, Ops.Null_Node, Position, Key, Node);
 228                else
 229                   Insert_Post (Tree, After, After, Key, Node);
 230                end if;
 231
 232                Success := True;
 233
 234             else
 235                Conditional_Insert_Sans_Hint (Tree, Key, Node, Success);
 236             end if;
 237          end;
 238
 239          return;
 240       end if;
 241
 242       Node := Position;
 243       Success := False;
 244    end Generic_Conditional_Insert_With_Hint;
 245
 246    -------------------------
 247    -- Generic_Insert_Post --
 248    -------------------------
 249
 250    procedure Generic_Insert_Post
 251      (Tree : in out Tree_Type;
 252       X, Y : Node_Access;
 253       Key  : Key_Type;
 254       Z    : out Node_Access)
 255    is
 256       subtype Length_Subtype is Count_Type range 0 .. Count_Type'Last - 1;
 257
 258       New_Length : constant Count_Type := Length_Subtype'(Tree.Length) + 1;
 259
 260    begin
 261       if Y = Ops.Null_Node
 262         or else X /= Ops.Null_Node
 263         or else Is_Less_Key_Node (Key, Y)
 264       then
 265          pragma Assert (Y = Ops.Null_Node
 266                           or else Ops.Left (Y) = Ops.Null_Node);
 267
 268          --  Delay allocation as long as we can, in order to defend
 269          --  against exceptions propagated by relational operators.
 270
 271          Z := New_Node;
 272
 273          pragma Assert (Z /= Ops.Null_Node);
 274          pragma Assert (Ops.Color (Z) = Red);
 275
 276          if Y = Ops.Null_Node then
 277             pragma Assert (Tree.Length = 0);
 278             pragma Assert (Tree.Root = Ops.Null_Node);
 279             pragma Assert (Tree.First = Ops.Null_Node);
 280             pragma Assert (Tree.Last = Ops.Null_Node);
 281
 282             Tree.Root := Z;
 283             Tree.First := Z;
 284             Tree.Last := Z;
 285
 286          else
 287             Ops.Set_Left (Y, Z);
 288
 289             if Y = Tree.First then
 290                Tree.First := Z;
 291             end if;
 292          end if;
 293
 294       else
 295          pragma Assert (Ops.Right (Y) = Ops.Null_Node);
 296
 297          --  Delay allocation as long as we can, in order to defend
 298          --  against exceptions propagated by relational operators.
 299
 300          Z := New_Node;
 301
 302          pragma Assert (Z /= Ops.Null_Node);
 303          pragma Assert (Ops.Color (Z) = Red);
 304
 305          Ops.Set_Right (Y, Z);
 306
 307          if Y = Tree.Last then
 308             Tree.Last := Z;
 309          end if;
 310       end if;
 311
 312       Ops.Set_Parent (Z, Y);
 313       Ops.Rebalance_For_Insert (Tree, Z);
 314       Tree.Length := New_Length;
 315    end Generic_Insert_Post;
 316
 317    -----------------------
 318    -- Generic_Iteration --
 319    -----------------------
 320
 321    procedure Generic_Iteration
 322      (Tree : Tree_Type;
 323       Key  : Key_Type)
 324    is
 325       procedure Iterate (Node : Node_Access);
 326
 327       -------------
 328       -- Iterate --
 329       -------------
 330
 331       procedure Iterate (Node : Node_Access) is
 332          N : Node_Access := Node;
 333       begin
 334          while N /= Ops.Null_Node loop
 335             if Is_Less_Key_Node (Key, N) then
 336                N := Ops.Left (N);
 337             elsif Is_Greater_Key_Node (Key, N) then
 338                N := Ops.Right (N);
 339             else
 340                Iterate (Ops.Left (N));
 341                Process (N);
 342                N := Ops.Right (N);
 343             end if;
 344          end loop;
 345       end Iterate;
 346
 347    --  Start of processing for Generic_Iteration
 348
 349    begin
 350       Iterate (Tree.Root);
 351    end Generic_Iteration;
 352
 353    -------------------------------
 354    -- Generic_Reverse_Iteration --
 355    -------------------------------
 356
 357    procedure Generic_Reverse_Iteration
 358      (Tree : Tree_Type;
 359       Key  : Key_Type)
 360    is
 361       procedure Iterate (Node : Node_Access);
 362
 363       -------------
 364       -- Iterate --
 365       -------------
 366
 367       procedure Iterate (Node : Node_Access) is
 368          N : Node_Access := Node;
 369       begin
 370          while N /= Ops.Null_Node loop
 371             if Is_Less_Key_Node (Key, N) then
 372                N := Ops.Left (N);
 373             elsif Is_Greater_Key_Node (Key, N) then
 374                N := Ops.Right (N);
 375             else
 376                Iterate (Ops.Right (N));
 377                Process (N);
 378                N := Ops.Left (N);
 379             end if;
 380          end loop;
 381       end Iterate;
 382
 383    --  Start of processing for Generic_Reverse_Iteration
 384
 385    begin
 386       Iterate (Tree.Root);
 387    end Generic_Reverse_Iteration;
 388
 389    ----------------------------------
 390    -- Generic_Unconditional_Insert --
 391    ----------------------------------
 392
 393    procedure Generic_Unconditional_Insert
 394      (Tree : in out Tree_Type;
 395       Key  : Key_Type;
 396       Node : out Node_Access)
 397    is
 398       Y : Node_Access := Ops.Null_Node;
 399       X : Node_Access := Tree.Root;
 400
 401    begin
 402       while X /= Ops.Null_Node loop
 403          Y := X;
 404
 405          if Is_Less_Key_Node (Key, X) then
 406             X := Ops.Left (X);
 407          else
 408             X := Ops.Right (X);
 409          end if;
 410       end loop;
 411
 412       Insert_Post (Tree, X, Y, Key, Node);
 413    end Generic_Unconditional_Insert;
 414
 415    --------------------------------------------
 416    -- Generic_Unconditional_Insert_With_Hint --
 417    --------------------------------------------
 418
 419    procedure Generic_Unconditional_Insert_With_Hint
 420      (Tree : in out Tree_Type;
 421       Hint : Node_Access;
 422       Key  : Key_Type;
 423       Node : out Node_Access)
 424    is
 425       --  TODO: verify this algorithm.  It was (quickly) adapted it from the
 426       --  same algorithm for conditional_with_hint. It may be that the test
 427       --  Key > Hint should be something like a Key >= Hint, to handle the
 428       --  case when Hint is The Last Item of A (Contiguous) sequence of
 429       --  Equivalent Items.  (The Key < Hint Test is probably OK. It is not
 430       --  clear that you can use Key <= Hint, since new items are always
 431       --  inserted last in the sequence of equivalent items.) ???
 432
 433    begin
 434       if Hint = Ops.Null_Node then  -- largest
 435          if Tree.Length > 0
 436            and then Is_Greater_Key_Node (Key, Tree.Last)
 437          then
 438             Insert_Post (Tree, Ops.Null_Node, Tree.Last, Key, Node);
 439          else
 440             Unconditional_Insert_Sans_Hint (Tree, Key, Node);
 441          end if;
 442
 443          return;
 444       end if;
 445
 446       pragma Assert (Tree.Length > 0);
 447
 448       if Is_Less_Key_Node (Key, Hint) then
 449          if Hint = Tree.First then
 450             Insert_Post (Tree, Hint, Hint, Key, Node);
 451             return;
 452          end if;
 453
 454          declare
 455             Before : constant Node_Access := Ops.Previous (Hint);
 456          begin
 457             if Is_Greater_Key_Node (Key, Before) then
 458                if Ops.Right (Before) = Ops.Null_Node then
 459                   Insert_Post (Tree, Ops.Null_Node, Before, Key, Node);
 460                else
 461                   Insert_Post (Tree, Hint, Hint, Key, Node);
 462                end if;
 463             else
 464                Unconditional_Insert_Sans_Hint (Tree, Key, Node);
 465             end if;
 466          end;
 467
 468          return;
 469       end if;
 470
 471       if Is_Greater_Key_Node (Key, Hint) then
 472          if Hint = Tree.Last then
 473             Insert_Post (Tree, Ops.Null_Node, Tree.Last, Key, Node);
 474             return;
 475          end if;
 476
 477          declare
 478             After : constant Node_Access := Ops.Next (Hint);
 479          begin
 480             if Is_Less_Key_Node (Key, After) then
 481                if Ops.Right (Hint) = Ops.Null_Node then
 482                   Insert_Post (Tree, Ops.Null_Node, Hint, Key, Node);
 483                else
 484                   Insert_Post (Tree, After, After, Key, Node);
 485                end if;
 486             else
 487                Unconditional_Insert_Sans_Hint (Tree, Key, Node);
 488             end if;
 489          end;
 490
 491          return;
 492       end if;
 493
 494       Unconditional_Insert_Sans_Hint (Tree, Key, Node);
 495    end Generic_Unconditional_Insert_With_Hint;
 496
 497    -----------------
 498    -- Upper_Bound --
 499    -----------------
 500
 501    function Upper_Bound
 502      (Tree : Tree_Type;
 503       Key  : Key_Type) return Node_Access
 504    is
 505       Y : Node_Access;
 506       X : Node_Access := Tree.Root;
 507
 508    begin
 509       while X /= Ops.Null_Node loop
 510          if Is_Less_Key_Node (Key, X) then
 511             Y := X;
 512             X := Ops.Left (X);
 513          else
 514             X := Ops.Right (X);
 515          end if;
 516       end loop;
 517
 518       return Y;
 519    end Upper_Bound;
 520
 521 end Ada.Containers.Red_Black_Trees.Generic_Keys;
 522
 523