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-2006, Free Software Foundation, Inc.         --
  11 --                                                                          --
  12 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  20 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  21 -- Boston, MA 02110-1301, USA.                                              --
  22 --                                                                          --
  23 -- As a special exception,  if other files  instantiate  generics from this --
  24 -- unit, or you link  this unit with other files  to produce an executable, --
  25 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  26 -- covered  by the  GNU  General  Public  License.  This exception does not --
  27 -- however invalidate  any other reasons why  the executable file  might be --
  28 -- covered by the  GNU Public License.                                      --
  29 --                                                                          --
  30 -- This unit was originally developed by Matthew J Heaney.                  --
  31 ------------------------------------------------------------------------------
  32
  33 package body Ada.Containers.Red_Black_Trees.Generic_Keys is
  34
  35    package Ops renames Tree_Operations;
  36
  37    -------------
  38    -- Ceiling --
  39    -------------
  40
  41    --  AKA Lower_Bound
  42
  43    function Ceiling (Tree : Tree_Type; Key : Key_Type) return Node_Access is
  44       Y : Node_Access;
  45       X : Node_Access;
  46
  47    begin
  48       X := Tree.Root;
  49       while X /= null loop
  50          if Is_Greater_Key_Node (Key, X) then
  51             X := Ops.Right (X);
  52          else
  53             Y := X;
  54             X := Ops.Left (X);
  55          end if;
  56       end loop;
  57
  58       return Y;
  59    end Ceiling;
  60
  61    ----------
  62    -- Find --
  63    ----------
  64
  65    function Find (Tree : Tree_Type; Key  : Key_Type) return Node_Access is
  66       Y : Node_Access;
  67       X : Node_Access;
  68
  69    begin
  70       X := Tree.Root;
  71       while X /= null loop
  72          if Is_Greater_Key_Node (Key, X) then
  73             X := Ops.Right (X);
  74          else
  75             Y := X;
  76             X := Ops.Left (X);
  77          end if;
  78       end loop;
  79
  80       if Y = null then
  81          return null;
  82       end if;
  83
  84       if Is_Less_Key_Node (Key, Y) then
  85          return null;
  86       end if;
  87
  88       return Y;
  89    end Find;
  90
  91    -----------
  92    -- Floor --
  93    -----------
  94
  95    function Floor (Tree : Tree_Type; Key  : Key_Type) return Node_Access is
  96       Y : Node_Access;
  97       X : Node_Access;
  98
  99    begin
 100       X := Tree.Root;
 101       while X /= null 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       Inserted : out Boolean)
 122    is
 123       Y : Node_Access := null;
 124       X : Node_Access := Tree.Root;
 125
 126    begin
 127       Inserted := True;
 128       while X /= null loop
 129          Y := X;
 130          Inserted := Is_Less_Key_Node (Key, X);
 131
 132          if Inserted then
 133             X := Ops.Left (X);
 134          else
 135             X := Ops.Right (X);
 136          end if;
 137       end loop;
 138
 139       --  If Inserted is True, then this means either that Tree is
 140       --  empty, or there was a least one node (strictly) greater than
 141       --  Key. Otherwise, it means that Key is equal to or greater than
 142       --  every node.
 143
 144       if Inserted then
 145          if Y = Tree.First then
 146             Insert_Post (Tree, Y, True, Node);
 147             return;
 148          end if;
 149
 150          Node := Ops.Previous (Y);
 151
 152       else
 153          Node := Y;
 154       end if;
 155
 156       --  Here Node has a value that is less than or equal to Key. We
 157       --  now have to resolve whether Key is equal to or greater than
 158       --  Node, which determines whether the insertion succeeds.
 159
 160       if Is_Greater_Key_Node (Key, Node) then
 161          Insert_Post (Tree, Y, Inserted, Node);
 162          Inserted := True;
 163          return;
 164       end if;
 165
 166       Inserted := False;
 167    end Generic_Conditional_Insert;
 168
 169    ------------------------------------------
 170    -- Generic_Conditional_Insert_With_Hint --
 171    ------------------------------------------
 172
 173    procedure Generic_Conditional_Insert_With_Hint
 174      (Tree      : in out Tree_Type;
 175       Position  : Node_Access;
 176       Key       : Key_Type;
 177       Node      : out Node_Access;
 178       Inserted  : out Boolean)
 179    is
 180    begin
 181       --  The purpose of a hint is to avoid a search from the root of
 182       --  tree. If we have it hint it means we only need to traverse the
 183       --  subtree rooted at the hint to find the nearest neighbor. Note
 184       --  that finding the neighbor means merely walking the tree; this
 185       --  is not a search and the only comparisons that occur are with
 186       --  the hint and its neighbor.
 187
 188       --  If Position is null, this is intepreted to mean that Key is
 189       --  large relative to the nodes in the tree. If the tree is empty,
 190       --  or Key is greater than the last node in the tree, then we're
 191       --  done; otherwise the hint was "wrong" and we must search.
 192
 193       if Position = null then  -- largest
 194          if Tree.Last = null
 195            or else Is_Greater_Key_Node (Key, Tree.Last)
 196          then
 197             Insert_Post (Tree, Tree.Last, False, Node);
 198             Inserted := True;
 199          else
 200             Conditional_Insert_Sans_Hint (Tree, Key, Node, Inserted);
 201          end if;
 202
 203          return;
 204       end if;
 205
 206       pragma Assert (Tree.Length > 0);
 207
 208       --  A hint can either name the node that immediately follows Key,
 209       --  or immediately precedes Key. We first test whether Key is is
 210       --  less than the hint, and if so we compare Key to the node that
 211       --  precedes the hint. If Key is both less than the hint and
 212       --  greater than the hint's preceding neighbor, then we're done;
 213       --  otherwise we must search.
 214
 215       --  Note also that a hint can either be an anterior node or a leaf
 216       --  node. A new node is always inserted at the bottom of the tree
 217       --  (at least prior to rebalancing), becoming the new left or
 218       --  right child of leaf node (which prior to the insertion must
 219       --  necessarily be null, since this is a leaf). If the hint names
 220       --  an anterior node then its neighbor must be a leaf, and so
 221       --  (here) we insert after the neighbor. If the hint names a leaf
 222       --  then its neighbor must be anterior and so we insert before the
 223       --  hint.
 224
 225       if Is_Less_Key_Node (Key, Position) then
 226          declare
 227             Before : constant Node_Access := Ops.Previous (Position);
 228
 229          begin
 230             if Before = null then
 231                Insert_Post (Tree, Tree.First, True, Node);
 232                Inserted := True;
 233
 234             elsif Is_Greater_Key_Node (Key, Before) then
 235                if Ops.Right (Before) = null then
 236                   Insert_Post (Tree, Before, False, Node);
 237                else
 238                   Insert_Post (Tree, Position, True, Node);
 239                end if;
 240
 241                Inserted := True;
 242
 243             else
 244                Conditional_Insert_Sans_Hint (Tree, Key, Node, Inserted);
 245             end if;
 246          end;
 247
 248          return;
 249       end if;
 250
 251       --  We know that Key isn't less than the hint so we try again,
 252       --  this time to see if it's greater than the hint. If so we
 253       --  compare Key to the node that follows the hint. If Key is both
 254       --  greater than the hint and less than the hint's next neighbor,
 255       --  then we're done; otherwise we must search.
 256
 257       if Is_Greater_Key_Node (Key, Position) then
 258          declare
 259             After : constant Node_Access := Ops.Next (Position);
 260
 261          begin
 262             if After = null then
 263                Insert_Post (Tree, Tree.Last, False, Node);
 264                Inserted := True;
 265
 266             elsif Is_Less_Key_Node (Key, After) then
 267                if Ops.Right (Position) = null then
 268                   Insert_Post (Tree, Position, False, Node);
 269                else
 270                   Insert_Post (Tree, After, True, Node);
 271                end if;
 272
 273                Inserted := True;
 274
 275             else
 276                Conditional_Insert_Sans_Hint (Tree, Key, Node, Inserted);
 277             end if;
 278          end;
 279
 280          return;
 281       end if;
 282
 283       --  We know that Key is neither less than the hint nor greater
 284       --  than the hint, and that's the definition of equivalence.
 285       --  There's nothing else we need to do, since a search would just
 286       --  reach the same conclusion.
 287
 288       Node := Position;
 289       Inserted := False;
 290    end Generic_Conditional_Insert_With_Hint;
 291
 292    -------------------------
 293    -- Generic_Insert_Post --
 294    -------------------------
 295
 296    procedure Generic_Insert_Post
 297      (Tree   : in out Tree_Type;
 298       Y      : Node_Access;
 299       Before : Boolean;
 300       Z      : out Node_Access)
 301    is
 302    begin
 303       if Tree.Length = Count_Type'Last then
 304          raise Constraint_Error with "too many elements";
 305       end if;
 306
 307       if Tree.Busy > 0 then
 308          raise Program_Error with
 309            "attempt to tamper with cursors (container is busy)";
 310       end if;
 311
 312       Z := New_Node;
 313       pragma Assert (Z /= null);
 314       pragma Assert (Ops.Color (Z) = Red);
 315
 316       if Y = null then
 317          pragma Assert (Tree.Length = 0);
 318          pragma Assert (Tree.Root = null);
 319          pragma Assert (Tree.First = null);
 320          pragma Assert (Tree.Last = null);
 321
 322          Tree.Root := Z;
 323          Tree.First := Z;
 324          Tree.Last := Z;
 325
 326       elsif Before then
 327          pragma Assert (Ops.Left (Y) = null);
 328
 329          Ops.Set_Left (Y, Z);
 330
 331          if Y = Tree.First then
 332             Tree.First := Z;
 333          end if;
 334
 335       else
 336          pragma Assert (Ops.Right (Y) = null);
 337
 338          Ops.Set_Right (Y, Z);
 339
 340          if Y = Tree.Last then
 341             Tree.Last := Z;
 342          end if;
 343       end if;
 344
 345       Ops.Set_Parent (Z, Y);
 346       Ops.Rebalance_For_Insert (Tree, Z);
 347       Tree.Length := Tree.Length + 1;
 348    end Generic_Insert_Post;
 349
 350    -----------------------
 351    -- Generic_Iteration --
 352    -----------------------
 353
 354    procedure Generic_Iteration
 355      (Tree : Tree_Type;
 356       Key  : Key_Type)
 357    is
 358       procedure Iterate (Node : Node_Access);
 359
 360       -------------
 361       -- Iterate --
 362       -------------
 363
 364       procedure Iterate (Node : Node_Access) is
 365          N : Node_Access;
 366       begin
 367          N := Node;
 368          while N /= null loop
 369             if Is_Less_Key_Node (Key, N) then
 370                N := Ops.Left (N);
 371             elsif Is_Greater_Key_Node (Key, N) then
 372                N := Ops.Right (N);
 373             else
 374                Iterate (Ops.Left (N));
 375                Process (N);
 376                N := Ops.Right (N);
 377             end if;
 378          end loop;
 379       end Iterate;
 380
 381    --  Start of processing for Generic_Iteration
 382
 383    begin
 384       Iterate (Tree.Root);
 385    end Generic_Iteration;
 386
 387    -------------------------------
 388    -- Generic_Reverse_Iteration --
 389    -------------------------------
 390
 391    procedure Generic_Reverse_Iteration
 392      (Tree : Tree_Type;
 393       Key  : Key_Type)
 394    is
 395       procedure Iterate (Node : Node_Access);
 396
 397       -------------
 398       -- Iterate --
 399       -------------
 400
 401       procedure Iterate (Node : Node_Access) is
 402          N : Node_Access;
 403       begin
 404          N := Node;
 405          while N /= null loop
 406             if Is_Less_Key_Node (Key, N) then
 407                N := Ops.Left (N);
 408             elsif Is_Greater_Key_Node (Key, N) then
 409                N := Ops.Right (N);
 410             else
 411                Iterate (Ops.Right (N));
 412                Process (N);
 413                N := Ops.Left (N);
 414             end if;
 415          end loop;
 416       end Iterate;
 417
 418    --  Start of processing for Generic_Reverse_Iteration
 419
 420    begin
 421       Iterate (Tree.Root);
 422    end Generic_Reverse_Iteration;
 423
 424    ----------------------------------
 425    -- Generic_Unconditional_Insert --
 426    ----------------------------------
 427
 428    procedure Generic_Unconditional_Insert
 429      (Tree : in out Tree_Type;
 430       Key  : Key_Type;
 431       Node : out Node_Access)
 432    is
 433       Y : Node_Access;
 434       X : Node_Access;
 435
 436       Before : Boolean;
 437
 438    begin
 439       Y := null;
 440       Before := False;
 441
 442       X := Tree.Root;
 443       while X /= null loop
 444          Y := X;
 445          Before := Is_Less_Key_Node (Key, X);
 446
 447          if Before then
 448             X := Ops.Left (X);
 449          else
 450             X := Ops.Right (X);
 451          end if;
 452       end loop;
 453
 454       Insert_Post (Tree, Y, Before, Node);
 455    end Generic_Unconditional_Insert;
 456
 457    --------------------------------------------
 458    -- Generic_Unconditional_Insert_With_Hint --
 459    --------------------------------------------
 460
 461    procedure Generic_Unconditional_Insert_With_Hint
 462      (Tree : in out Tree_Type;
 463       Hint : Node_Access;
 464       Key  : Key_Type;
 465       Node : out Node_Access)
 466    is
 467    begin
 468       --  There are fewer constraints for an unconditional insertion
 469       --  than for a conditional insertion, since we allow duplicate
 470       --  keys. So instead of having to check (say) whether Key is
 471       --  (strictly) greater than the hint's previous neighbor, here we
 472       --  allow Key to be equal to or greater than the previous node.
 473
 474       --  There is the issue of what to do if Key is equivalent to the
 475       --  hint. Does the new node get inserted before or after the hint?
 476       --  We decide that it gets inserted after the hint, reasoning that
 477       --  this is consistent with behavior for non-hint insertion, which
 478       --  inserts a new node after existing nodes with equivalent keys.
 479
 480       --  First we check whether the hint is null, which is interpreted
 481       --  to mean that Key is large relative to existing nodes.
 482       --  Following our rule above, if Key is equal to or greater than
 483       --  the last node, then we insert the new node immediately after
 484       --  last. (We don't have an operation for testing whether a key is
 485       --  "equal to or greater than" a node, so we must say instead "not
 486       --  less than", which is equivalent.)
 487
 488       if Hint = null then  -- largest
 489          if Tree.Last = null then
 490             Insert_Post (Tree, null, False, Node);
 491          elsif Is_Less_Key_Node (Key, Tree.Last) then
 492             Unconditional_Insert_Sans_Hint (Tree, Key, Node);
 493          else
 494             Insert_Post (Tree, Tree.Last, False, Node);
 495          end if;
 496
 497          return;
 498       end if;
 499
 500       pragma Assert (Tree.Length > 0);
 501
 502       --  We decide here whether to insert the new node prior to the
 503       --  hint. Key could be equivalent to the hint, so in theory we
 504       --  could write the following test as "not greater than" (same as
 505       --  "less than or equal to"). If Key were equivalent to the hint,
 506       --  that would mean that the new node gets inserted before an
 507       --  equivalent node. That wouldn't break any container invariants,
 508       --  but our rule above says that new nodes always get inserted
 509       --  after equivalent nodes. So here we test whether Key is both
 510       --  less than the hint and and equal to or greater than the hint's
 511       --  previous neighbor, and if so insert it before the hint.
 512
 513       if Is_Less_Key_Node (Key, Hint) then
 514          declare
 515             Before : constant Node_Access := Ops.Previous (Hint);
 516          begin
 517             if Before = null then
 518                Insert_Post (Tree, Hint, True, Node);
 519             elsif Is_Less_Key_Node (Key, Before) then
 520                Unconditional_Insert_Sans_Hint (Tree, Key, Node);
 521             elsif Ops.Right (Before) = null then
 522                Insert_Post (Tree, Before, False, Node);
 523             else
 524                Insert_Post (Tree, Hint, True, Node);
 525             end if;
 526          end;
 527
 528          return;
 529       end if;
 530
 531       --  We know that Key isn't less than the hint, so it must be equal
 532       --  or greater. So we just test whether Key is less than or equal
 533       --  to (same as "not greater than") the hint's next neighbor, and
 534       --  if so insert it after the hint.
 535
 536       declare
 537          After : constant Node_Access := Ops.Next (Hint);
 538       begin
 539          if After = null then
 540             Insert_Post (Tree, Hint, False, Node);
 541          elsif Is_Greater_Key_Node (Key, After) then
 542             Unconditional_Insert_Sans_Hint (Tree, Key, Node);
 543          elsif Ops.Right (Hint) = null then
 544             Insert_Post (Tree, Hint, False, Node);
 545          else
 546             Insert_Post (Tree, After, True, Node);
 547          end if;
 548       end;
 549    end Generic_Unconditional_Insert_With_Hint;
 550
 551    -----------------
 552    -- Upper_Bound --
 553    -----------------
 554
 555    function Upper_Bound
 556      (Tree : Tree_Type;
 557       Key  : Key_Type) return Node_Access
 558    is
 559       Y : Node_Access;
 560       X : Node_Access;
 561
 562    begin
 563       X := Tree.Root;
 564       while X /= null loop
 565          if Is_Less_Key_Node (Key, X) then
 566             Y := X;
 567             X := Ops.Left (X);
 568          else
 569             X := Ops.Right (X);
 570          end if;
 571       end loop;
 572
 573       return Y;
 574    end Upper_Bound;
 575
 576 end Ada.Containers.Red_Black_Trees.Generic_Keys;