gcc/ada/a-rbtgso.adb

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