gcc/ada/a-crbtgk.adb

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