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