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