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