gcc/ada/a-btgbso.adb

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