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       subtype Length_Subtype is Count_Type range 0 .. Count_Type'Last - 1;
 258
 259       New_Length : constant Count_Type := Length_Subtype'(Tree.Length) + 1;
 260
 261    begin
 262       if Tree.Busy > 0 then
 263          raise Program_Error;
 264       end if;
 265
 266       if Y = null
 267         or else X /= null
 268         or else Is_Less_Key_Node (Key, Y)
 269       then
 270          pragma Assert (Y = null
 271                           or else Ops.Left (Y) = null);
 272
 273          --  Delay allocation as long as we can, in order to defend
 274          --  against exceptions propagated by relational operators.
 275
 276          Z := New_Node;
 277
 278          pragma Assert (Z /= null);
 279          pragma Assert (Ops.Color (Z) = Red);
 280
 281          if Y = null then
 282             pragma Assert (Tree.Length = 0);
 283             pragma Assert (Tree.Root = null);
 284             pragma Assert (Tree.First = null);
 285             pragma Assert (Tree.Last = null);
 286
 287             Tree.Root := Z;
 288             Tree.First := Z;
 289             Tree.Last := Z;
 290
 291          else
 292             Ops.Set_Left (Y, Z);
 293
 294             if Y = Tree.First then
 295                Tree.First := Z;
 296             end if;
 297          end if;
 298
 299       else
 300          pragma Assert (Ops.Right (Y) = null);
 301
 302          --  Delay allocation as long as we can, in order to defend
 303          --  against exceptions propagated by relational operators.
 304
 305          Z := New_Node;
 306
 307          pragma Assert (Z /= null);
 308          pragma Assert (Ops.Color (Z) = Red);
 309
 310          Ops.Set_Right (Y, Z);
 311
 312          if Y = Tree.Last then
 313             Tree.Last := Z;
 314          end if;
 315       end if;
 316
 317       Ops.Set_Parent (Z, Y);
 318       Ops.Rebalance_For_Insert (Tree, Z);
 319       Tree.Length := New_Length;
 320    end Generic_Insert_Post;
 321
 322    -----------------------
 323    -- Generic_Iteration --
 324    -----------------------
 325
 326    procedure Generic_Iteration
 327      (Tree : Tree_Type;
 328       Key  : Key_Type)
 329    is
 330       procedure Iterate (Node : Node_Access);
 331
 332       -------------
 333       -- Iterate --
 334       -------------
 335
 336       procedure Iterate (Node : Node_Access) is
 337          N : Node_Access := Node;
 338       begin
 339          while N /= null loop
 340             if Is_Less_Key_Node (Key, N) then
 341                N := Ops.Left (N);
 342             elsif Is_Greater_Key_Node (Key, N) then
 343                N := Ops.Right (N);
 344             else
 345                Iterate (Ops.Left (N));
 346                Process (N);
 347                N := Ops.Right (N);
 348             end if;
 349          end loop;
 350       end Iterate;
 351
 352    --  Start of processing for Generic_Iteration
 353
 354    begin
 355       Iterate (Tree.Root);
 356    end Generic_Iteration;
 357
 358    -------------------------------
 359    -- Generic_Reverse_Iteration --
 360    -------------------------------
 361
 362    procedure Generic_Reverse_Iteration
 363      (Tree : Tree_Type;
 364       Key  : Key_Type)
 365    is
 366       procedure Iterate (Node : Node_Access);
 367
 368       -------------
 369       -- Iterate --
 370       -------------
 371
 372       procedure Iterate (Node : Node_Access) is
 373          N : Node_Access := Node;
 374       begin
 375          while N /= null loop
 376             if Is_Less_Key_Node (Key, N) then
 377                N := Ops.Left (N);
 378             elsif Is_Greater_Key_Node (Key, N) then
 379                N := Ops.Right (N);
 380             else
 381                Iterate (Ops.Right (N));
 382                Process (N);
 383                N := Ops.Left (N);
 384             end if;
 385          end loop;
 386       end Iterate;
 387
 388    --  Start of processing for Generic_Reverse_Iteration
 389
 390    begin
 391       Iterate (Tree.Root);
 392    end Generic_Reverse_Iteration;
 393
 394    ----------------------------------
 395    -- Generic_Unconditional_Insert --
 396    ----------------------------------
 397
 398    procedure Generic_Unconditional_Insert
 399      (Tree : in out Tree_Type;
 400       Key  : Key_Type;
 401       Node : out Node_Access)
 402    is
 403       Y : Node_Access := null;
 404       X : Node_Access := Tree.Root;
 405
 406    begin
 407       while X /= null loop
 408          Y := X;
 409
 410          if Is_Less_Key_Node (Key, X) then
 411             X := Ops.Left (X);
 412          else
 413             X := Ops.Right (X);
 414          end if;
 415       end loop;
 416
 417       Insert_Post (Tree, X, Y, Key, Node);
 418    end Generic_Unconditional_Insert;
 419
 420    --------------------------------------------
 421    -- Generic_Unconditional_Insert_With_Hint --
 422    --------------------------------------------
 423
 424    procedure Generic_Unconditional_Insert_With_Hint
 425      (Tree : in out Tree_Type;
 426       Hint : Node_Access;
 427       Key  : Key_Type;
 428       Node : out Node_Access)
 429    is
 430       --  TODO: verify this algorithm.  It was (quickly) adapted it from the
 431       --  same algorithm for conditional_with_hint. It may be that the test
 432       --  Key > Hint should be something like a Key >= Hint, to handle the
 433       --  case when Hint is The Last Item of A (Contiguous) sequence of
 434       --  Equivalent Items.  (The Key < Hint Test is probably OK. It is not
 435       --  clear that you can use Key <= Hint, since new items are always
 436       --  inserted last in the sequence of equivalent items.) ???
 437
 438    begin
 439       if Hint = null then  -- largest
 440          if Tree.Length > 0
 441            and then Is_Greater_Key_Node (Key, Tree.Last)
 442          then
 443             Insert_Post (Tree, null, Tree.Last, Key, Node);
 444          else
 445             Unconditional_Insert_Sans_Hint (Tree, Key, Node);
 446          end if;
 447
 448          return;
 449       end if;
 450
 451       pragma Assert (Tree.Length > 0);
 452
 453       if Is_Less_Key_Node (Key, Hint) then
 454          if Hint = Tree.First then
 455             Insert_Post (Tree, Hint, Hint, Key, Node);
 456             return;
 457          end if;
 458
 459          declare
 460             Before : constant Node_Access := Ops.Previous (Hint);
 461          begin
 462             if Is_Greater_Key_Node (Key, Before) then
 463                if Ops.Right (Before) = null then
 464                   Insert_Post (Tree, null, Before, Key, Node);
 465                else
 466                   Insert_Post (Tree, Hint, Hint, Key, Node);
 467                end if;
 468             else
 469                Unconditional_Insert_Sans_Hint (Tree, Key, Node);
 470             end if;
 471          end;
 472
 473          return;
 474       end if;
 475
 476       if Is_Greater_Key_Node (Key, Hint) then
 477          if Hint = Tree.Last then
 478             Insert_Post (Tree, null, Tree.Last, Key, Node);
 479             return;
 480          end if;
 481
 482          declare
 483             After : constant Node_Access := Ops.Next (Hint);
 484          begin
 485             if Is_Less_Key_Node (Key, After) then
 486                if Ops.Right (Hint) = null then
 487                   Insert_Post (Tree, null, Hint, Key, Node);
 488                else
 489                   Insert_Post (Tree, After, After, Key, Node);
 490                end if;
 491             else
 492                Unconditional_Insert_Sans_Hint (Tree, Key, Node);
 493             end if;
 494          end;
 495
 496          return;
 497       end if;
 498
 499       Unconditional_Insert_Sans_Hint (Tree, Key, Node);
 500    end Generic_Unconditional_Insert_With_Hint;
 501
 502    -----------------
 503    -- Upper_Bound --
 504    -----------------
 505
 506    function Upper_Bound
 507      (Tree : Tree_Type;
 508       Key  : Key_Type) return Node_Access
 509    is
 510       Y : Node_Access;
 511       X : Node_Access := Tree.Root;
 512
 513    begin
 514       while X /= null loop
 515          if Is_Less_Key_Node (Key, X) then
 516             Y := X;
 517             X := Ops.Left (X);
 518          else
 519             X := Ops.Right (X);
 520          end if;
 521       end loop;
 522
 523       return Y;
 524    end Upper_Bound;
 525
 526 end Ada.Containers.Red_Black_Trees.Generic_Keys;