gcc/ada/a-rbtgso.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 _ S E T _ O P E R A T I O N S                --
   7 --                                                                          --
   8 --                                 B o d y                                  --
   9 --                                                                          --
  10 --          Copyright (C) 2004-2007, 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 with System; use type System.Address;
  34
  35 package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is
  36
  37    -----------------------
  38    -- Local Subprograms --
  39    -----------------------
  40
  41    procedure Clear (Tree : in out Tree_Type);
  42
  43    function Copy (Source : Tree_Type) return Tree_Type;
  44
  45    -----------
  46    -- Clear --
  47    -----------
  48
  49    procedure Clear (Tree : in out Tree_Type) is
  50       pragma Assert (Tree.Busy = 0);
  51       pragma Assert (Tree.Lock = 0);
  52
  53       Root : Node_Access := Tree.Root;
  54       pragma Warnings (Off, Root);
  55
  56    begin
  57       Tree.Root := null;
  58       Tree.First := null;
  59       Tree.Last := null;
  60       Tree.Length := 0;
  61
  62       Delete_Tree (Root);
  63    end Clear;
  64
  65    ----------
  66    -- Copy --
  67    ----------
  68
  69    function Copy (Source : Tree_Type) return Tree_Type is
  70       Target : Tree_Type;
  71
  72    begin
  73       if Source.Length = 0 then
  74          return Target;
  75       end if;
  76
  77       Target.Root := Copy_Tree (Source.Root);
  78       Target.First := Tree_Operations.Min (Target.Root);
  79       Target.Last := Tree_Operations.Max (Target.Root);
  80       Target.Length := Source.Length;
  81
  82       return Target;
  83    end Copy;
  84
  85    ----------------
  86    -- Difference --
  87    ----------------
  88
  89    procedure Difference (Target : in out Tree_Type; Source : Tree_Type) is
  90       Tgt : Node_Access := Target.First;
  91       Src : Node_Access := Source.First;
  92
  93    begin
  94       if Target'Address = Source'Address then
  95          if Target.Busy > 0 then
  96             raise Program_Error with
  97               "attempt to tamper with cursors (container is busy)";
  98          end if;
  99
 100          Clear (Target);
 101          return;
 102       end if;
 103
 104       if Source.Length = 0 then
 105          return;
 106       end if;
 107
 108       if Target.Busy > 0 then
 109          raise Program_Error with
 110            "attempt to tamper with cursors (container is busy)";
 111       end if;
 112
 113       loop
 114          if Tgt = null then
 115             return;
 116          end if;
 117
 118          if Src = null then
 119             return;
 120          end if;
 121
 122          if Is_Less (Tgt, Src) then
 123             Tgt := Tree_Operations.Next (Tgt);
 124
 125          elsif Is_Less (Src, Tgt) then
 126             Src := Tree_Operations.Next (Src);
 127
 128          else
 129             declare
 130                X : Node_Access := Tgt;
 131             begin
 132                Tgt := Tree_Operations.Next (Tgt);
 133                Tree_Operations.Delete_Node_Sans_Free (Target, X);
 134                Free (X);
 135             end;
 136
 137             Src := Tree_Operations.Next (Src);
 138          end if;
 139       end loop;
 140    end Difference;
 141
 142    function Difference (Left, Right : Tree_Type) return Tree_Type is
 143       Tree : Tree_Type;
 144
 145       L_Node : Node_Access := Left.First;
 146       R_Node : Node_Access := Right.First;
 147
 148       Dst_Node : Node_Access;
 149       pragma Warnings (Off, Dst_Node);
 150
 151    begin
 152       if Left'Address = Right'Address then
 153          return Tree;  -- Empty set
 154       end if;
 155
 156       if Left.Length = 0 then
 157          return Tree;  -- Empty set
 158       end if;
 159
 160       if Right.Length = 0 then
 161          return Copy (Left);
 162       end if;
 163
 164       loop
 165          if L_Node = null then
 166             return Tree;
 167          end if;
 168
 169          if R_Node = null then
 170             while L_Node /= null loop
 171                Insert_With_Hint
 172                  (Dst_Tree => Tree,
 173                   Dst_Hint => null,
 174                   Src_Node => L_Node,
 175                   Dst_Node => Dst_Node);
 176
 177                L_Node := Tree_Operations.Next (L_Node);
 178
 179             end loop;
 180
 181             return Tree;
 182          end if;
 183
 184          if Is_Less (L_Node, R_Node) then
 185             Insert_With_Hint
 186               (Dst_Tree => Tree,
 187                Dst_Hint => null,
 188                Src_Node => L_Node,
 189                Dst_Node => Dst_Node);
 190
 191             L_Node := Tree_Operations.Next (L_Node);
 192
 193          elsif Is_Less (R_Node, L_Node) then
 194             R_Node := Tree_Operations.Next (R_Node);
 195
 196          else
 197             L_Node := Tree_Operations.Next (L_Node);
 198             R_Node := Tree_Operations.Next (R_Node);
 199          end if;
 200       end loop;
 201
 202    exception
 203       when others =>
 204          Delete_Tree (Tree.Root);
 205          raise;
 206    end Difference;
 207
 208    ------------------
 209    -- Intersection --
 210    ------------------
 211
 212    procedure Intersection
 213      (Target : in out Tree_Type;
 214       Source : Tree_Type)
 215    is
 216       Tgt : Node_Access := Target.First;
 217       Src : Node_Access := Source.First;
 218
 219    begin
 220       if Target'Address = Source'Address then
 221          return;
 222       end if;
 223
 224       if Target.Busy > 0 then
 225          raise Program_Error with
 226            "attempt to tamper with cursors (container is busy)";
 227       end if;
 228
 229       if Source.Length = 0 then
 230          Clear (Target);
 231          return;
 232       end if;
 233
 234       while Tgt /= null
 235         and then Src /= null
 236       loop
 237          if Is_Less (Tgt, Src) then
 238             declare
 239                X : Node_Access := Tgt;
 240             begin
 241                Tgt := Tree_Operations.Next (Tgt);
 242                Tree_Operations.Delete_Node_Sans_Free (Target, X);
 243                Free (X);
 244             end;
 245
 246          elsif Is_Less (Src, Tgt) then
 247             Src := Tree_Operations.Next (Src);
 248
 249          else
 250             Tgt := Tree_Operations.Next (Tgt);
 251             Src := Tree_Operations.Next (Src);
 252          end if;
 253       end loop;
 254
 255       while Tgt /= null loop
 256          declare
 257             X : Node_Access := Tgt;
 258          begin
 259             Tgt := Tree_Operations.Next (Tgt);
 260             Tree_Operations.Delete_Node_Sans_Free (Target, X);
 261             Free (X);
 262          end;
 263       end loop;
 264    end Intersection;
 265
 266    function Intersection (Left, Right : Tree_Type) return Tree_Type is
 267       Tree : Tree_Type;
 268
 269       L_Node : Node_Access := Left.First;
 270       R_Node : Node_Access := Right.First;
 271
 272       Dst_Node : Node_Access;
 273       pragma Warnings (Off, Dst_Node);
 274
 275    begin
 276       if Left'Address = Right'Address then
 277          return Copy (Left);
 278       end if;
 279
 280       loop
 281          if L_Node = null then
 282             return Tree;
 283          end if;
 284
 285          if R_Node = null then
 286             return Tree;
 287          end if;
 288
 289          if Is_Less (L_Node, R_Node) then
 290             L_Node := Tree_Operations.Next (L_Node);
 291
 292          elsif Is_Less (R_Node, L_Node) then
 293             R_Node := Tree_Operations.Next (R_Node);
 294
 295          else
 296             Insert_With_Hint
 297               (Dst_Tree => Tree,
 298                Dst_Hint => null,
 299                Src_Node => L_Node,
 300                Dst_Node => Dst_Node);
 301
 302             L_Node := Tree_Operations.Next (L_Node);
 303             R_Node := Tree_Operations.Next (R_Node);
 304          end if;
 305       end loop;
 306
 307    exception
 308       when others =>
 309          Delete_Tree (Tree.Root);
 310          raise;
 311    end Intersection;
 312
 313    ---------------
 314    -- Is_Subset --
 315    ---------------
 316
 317    function Is_Subset
 318      (Subset : Tree_Type;
 319       Of_Set : Tree_Type) return Boolean
 320    is
 321    begin
 322       if Subset'Address = Of_Set'Address then
 323          return True;
 324       end if;
 325
 326       if Subset.Length > Of_Set.Length then
 327          return False;
 328       end if;
 329
 330       declare
 331          Subset_Node : Node_Access := Subset.First;
 332          Set_Node    : Node_Access := Of_Set.First;
 333
 334       begin
 335          loop
 336             if Set_Node = null then
 337                return Subset_Node = null;
 338             end if;
 339
 340             if Subset_Node = null then
 341                return True;
 342             end if;
 343
 344             if Is_Less (Subset_Node, Set_Node) then
 345                return False;
 346             end if;
 347
 348             if Is_Less (Set_Node, Subset_Node) then
 349                Set_Node := Tree_Operations.Next (Set_Node);
 350             else
 351                Set_Node := Tree_Operations.Next (Set_Node);
 352                Subset_Node := Tree_Operations.Next (Subset_Node);
 353             end if;
 354          end loop;
 355       end;
 356    end Is_Subset;
 357
 358    -------------
 359    -- Overlap --
 360    -------------
 361
 362    function Overlap (Left, Right : Tree_Type) return Boolean is
 363       L_Node : Node_Access := Left.First;
 364       R_Node : Node_Access := Right.First;
 365
 366    begin
 367       if Left'Address = Right'Address then
 368          return Left.Length /= 0;
 369       end if;
 370
 371       loop
 372          if L_Node = null
 373            or else R_Node = null
 374          then
 375             return False;
 376          end if;
 377
 378          if Is_Less (L_Node, R_Node) then
 379             L_Node := Tree_Operations.Next (L_Node);
 380
 381          elsif Is_Less (R_Node, L_Node) then
 382             R_Node := Tree_Operations.Next (R_Node);
 383
 384          else
 385             return True;
 386          end if;
 387       end loop;
 388    end Overlap;
 389
 390    --------------------------
 391    -- Symmetric_Difference --
 392    --------------------------
 393
 394    procedure Symmetric_Difference
 395      (Target : in out Tree_Type;
 396       Source : Tree_Type)
 397    is
 398       Tgt : Node_Access := Target.First;
 399       Src : Node_Access := Source.First;
 400
 401       New_Tgt_Node : Node_Access;
 402       pragma Warnings (Off, New_Tgt_Node);
 403
 404    begin
 405       if Target.Busy > 0 then
 406          raise Program_Error with
 407            "attempt to tamper with cursors (container is busy)";
 408       end if;
 409
 410       if Target'Address = Source'Address then
 411          Clear (Target);
 412          return;
 413       end if;
 414
 415       loop
 416          if Tgt = null then
 417             while Src /= null loop
 418                Insert_With_Hint
 419                  (Dst_Tree => Target,
 420                   Dst_Hint => null,
 421                   Src_Node => Src,
 422                   Dst_Node => New_Tgt_Node);
 423
 424                Src := Tree_Operations.Next (Src);
 425             end loop;
 426
 427             return;
 428          end if;
 429
 430          if Src = null then
 431             return;
 432          end if;
 433
 434          if Is_Less (Tgt, Src) then
 435             Tgt := Tree_Operations.Next (Tgt);
 436
 437          elsif Is_Less (Src, Tgt) then
 438             Insert_With_Hint
 439               (Dst_Tree => Target,
 440                Dst_Hint => Tgt,
 441                Src_Node => Src,
 442                Dst_Node => New_Tgt_Node);
 443
 444             Src := Tree_Operations.Next (Src);
 445
 446          else
 447             declare
 448                X : Node_Access := Tgt;
 449             begin
 450                Tgt := Tree_Operations.Next (Tgt);
 451                Tree_Operations.Delete_Node_Sans_Free (Target, X);
 452                Free (X);
 453             end;
 454
 455             Src := Tree_Operations.Next (Src);
 456          end if;
 457       end loop;
 458    end Symmetric_Difference;
 459
 460    function Symmetric_Difference (Left, Right : Tree_Type) return Tree_Type is
 461       Tree : Tree_Type;
 462
 463       L_Node : Node_Access := Left.First;
 464       R_Node : Node_Access := Right.First;
 465
 466       Dst_Node : Node_Access;
 467       pragma Warnings (Off, Dst_Node);
 468
 469    begin
 470       if Left'Address = Right'Address then
 471          return Tree;  -- Empty set
 472       end if;
 473
 474       if Right.Length = 0 then
 475          return Copy (Left);
 476       end if;
 477
 478       if Left.Length = 0 then
 479          return Copy (Right);
 480       end if;
 481
 482       loop
 483          if L_Node = null then
 484             while R_Node /= null loop
 485                Insert_With_Hint
 486                  (Dst_Tree => Tree,
 487                   Dst_Hint => null,
 488                   Src_Node => R_Node,
 489                   Dst_Node => Dst_Node);
 490                R_Node := Tree_Operations.Next (R_Node);
 491             end loop;
 492
 493             return Tree;
 494          end if;
 495
 496          if R_Node = null then
 497             while L_Node /= null loop
 498                Insert_With_Hint
 499                  (Dst_Tree => Tree,
 500                   Dst_Hint => null,
 501                   Src_Node => L_Node,
 502                   Dst_Node => Dst_Node);
 503
 504                L_Node := Tree_Operations.Next (L_Node);
 505             end loop;
 506
 507             return Tree;
 508          end if;
 509
 510          if Is_Less (L_Node, R_Node) then
 511             Insert_With_Hint
 512               (Dst_Tree => Tree,
 513                Dst_Hint => null,
 514                Src_Node => L_Node,
 515                Dst_Node => Dst_Node);
 516
 517             L_Node := Tree_Operations.Next (L_Node);
 518
 519          elsif Is_Less (R_Node, L_Node) then
 520             Insert_With_Hint
 521               (Dst_Tree => Tree,
 522                Dst_Hint => null,
 523                Src_Node => R_Node,
 524                Dst_Node => Dst_Node);
 525
 526             R_Node := Tree_Operations.Next (R_Node);
 527
 528          else
 529             L_Node := Tree_Operations.Next (L_Node);
 530             R_Node := Tree_Operations.Next (R_Node);
 531          end if;
 532       end loop;
 533
 534    exception
 535       when others =>
 536          Delete_Tree (Tree.Root);
 537          raise;
 538    end Symmetric_Difference;
 539
 540    -----------
 541    -- Union --
 542    -----------
 543
 544    procedure Union (Target : in out Tree_Type; Source : Tree_Type)
 545    is
 546       Hint : Node_Access;
 547
 548       procedure Process (Node : Node_Access);
 549       pragma Inline (Process);
 550
 551       procedure Iterate is new Tree_Operations.Generic_Iteration (Process);
 552
 553       -------------
 554       -- Process --
 555       -------------
 556
 557       procedure Process (Node : Node_Access) is
 558       begin
 559          Insert_With_Hint
 560            (Dst_Tree => Target,
 561             Dst_Hint => Hint,
 562             Src_Node => Node,
 563             Dst_Node => Hint);
 564       end Process;
 565
 566    --  Start of processing for Union
 567
 568    begin
 569       if Target'Address = Source'Address then
 570          return;
 571       end if;
 572
 573       if Target.Busy > 0 then
 574          raise Program_Error with
 575            "attempt to tamper with cursors (container is busy)";
 576       end if;
 577
 578       Iterate (Source);
 579    end Union;
 580
 581    function Union (Left, Right : Tree_Type) return Tree_Type is
 582    begin
 583       if Left'Address = Right'Address then
 584          return Copy (Left);
 585       end if;
 586
 587       if Left.Length = 0 then
 588          return Copy (Right);
 589       end if;
 590
 591       if Right.Length = 0 then
 592          return Copy (Left);
 593       end if;
 594
 595       declare
 596          Tree : Tree_Type := Copy (Left);
 597
 598          Hint : Node_Access;
 599
 600          procedure Process (Node : Node_Access);
 601          pragma Inline (Process);
 602
 603          procedure Iterate is
 604            new Tree_Operations.Generic_Iteration (Process);
 605
 606          -------------
 607          -- Process --
 608          -------------
 609
 610          procedure Process (Node : Node_Access) is
 611          begin
 612             Insert_With_Hint
 613               (Dst_Tree => Tree,
 614                Dst_Hint => Hint,
 615                Src_Node => Node,
 616                Dst_Node => Hint);
 617          end Process;
 618
 619       --  Start of processing for Union
 620
 621       begin
 622          Iterate (Right);
 623          return Tree;
 624
 625       exception
 626          when others =>
 627             Delete_Tree (Tree.Root);
 628             raise;
 629       end;
 630
 631    end Union;
 632
 633 end Ada.Containers.Red_Black_Trees.Generic_Set_Operations;