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-2013, 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       BT : Natural renames Target.Busy;
  57       LT : Natural renames Target.Lock;
  58
  59       BS : Natural renames Source'Unrestricted_Access.Busy;
  60       LS : Natural renames Source'Unrestricted_Access.Lock;
  61
  62       Tgt, Src : Count_Type;
  63
  64       TN : Nodes_Type renames Target.Nodes;
  65       SN : Nodes_Type renames Source.Nodes;
  66
  67       Compare : Integer;
  68
  69    begin
  70       if Target'Address = Source'Address then
  71          if Target.Busy > 0 then
  72             raise Program_Error with
  73               "attempt to tamper with cursors (container is busy)";
  74          end if;
  75
  76          Tree_Operations.Clear_Tree (Target);
  77          return;
  78       end if;
  79
  80       if Source.Length = 0 then
  81          return;
  82       end if;
  83
  84       if Target.Busy > 0 then
  85          raise Program_Error with
  86            "attempt to tamper with cursors (container is busy)";
  87       end if;
  88
  89       Tgt := Target.First;
  90       Src := Source.First;
  91       loop
  92          if Tgt = 0 then
  93             exit;
  94          end if;
  95
  96          if Src = 0 then
  97             exit;
  98          end if;
  99
 100          --  Per AI05-0022, the container implementation is required to detect
 101          --  element tampering by a generic actual subprogram.
 102
 103          begin
 104             BT := BT + 1;
 105             LT := LT + 1;
 106
 107             BS := BS + 1;
 108             LS := LS + 1;
 109
 110             if Is_Less (TN (Tgt), SN (Src)) then
 111                Compare := -1;
 112             elsif Is_Less (SN (Src), TN (Tgt)) then
 113                Compare := 1;
 114             else
 115                Compare := 0;
 116             end if;
 117
 118             BT := BT - 1;
 119             LT := LT - 1;
 120
 121             BS := BS - 1;
 122             LS := LS - 1;
 123          exception
 124             when others =>
 125                BT := BT - 1;
 126                LT := LT - 1;
 127
 128                BS := BS - 1;
 129                LS := LS - 1;
 130
 131                raise;
 132          end;
 133
 134          if Compare < 0 then
 135             Tgt := Tree_Operations.Next (Target, Tgt);
 136
 137          elsif Compare > 0 then
 138             Src := Tree_Operations.Next (Source, Src);
 139
 140          else
 141             declare
 142                X : constant Count_Type := Tgt;
 143             begin
 144                Tgt := Tree_Operations.Next (Target, Tgt);
 145
 146                Tree_Operations.Delete_Node_Sans_Free (Target, X);
 147                Tree_Operations.Free (Target, X);
 148             end;
 149
 150             Src := Tree_Operations.Next (Source, Src);
 151          end if;
 152       end loop;
 153    end Set_Difference;
 154
 155    function Set_Difference (Left, Right : Set_Type) return Set_Type is
 156    begin
 157       if Left'Address = Right'Address then
 158          return S : Set_Type (0);  -- Empty set
 159       end if;
 160
 161       if Left.Length = 0 then
 162          return S : Set_Type (0);  -- Empty set
 163       end if;
 164
 165       if Right.Length = 0 then
 166          return Copy (Left);
 167       end if;
 168
 169       return Result : Set_Type (Left.Length) do
 170          --  Per AI05-0022, the container implementation is required to detect
 171          --  element tampering by a generic actual subprogram.
 172
 173          declare
 174             BL : Natural renames Left'Unrestricted_Access.Busy;
 175             LL : Natural renames Left'Unrestricted_Access.Lock;
 176
 177             BR : Natural renames Right'Unrestricted_Access.Busy;
 178             LR : Natural renames Right'Unrestricted_Access.Lock;
 179
 180             L_Node : Count_Type;
 181             R_Node : Count_Type;
 182
 183             Dst_Node : Count_Type;
 184             pragma Warnings (Off, Dst_Node);
 185
 186          begin
 187             BL := BL + 1;
 188             LL := LL + 1;
 189
 190             BR := BR + 1;
 191             LR := LR + 1;
 192
 193             L_Node := Left.First;
 194             R_Node := Right.First;
 195             loop
 196                if L_Node = 0 then
 197                   exit;
 198                end if;
 199
 200                if R_Node = 0 then
 201                   while L_Node /= 0 loop
 202                      Insert_With_Hint
 203                        (Dst_Set  => Result,
 204                         Dst_Hint => 0,
 205                         Src_Node => Left.Nodes (L_Node),
 206                         Dst_Node => Dst_Node);
 207
 208                      L_Node := Tree_Operations.Next (Left, L_Node);
 209                   end loop;
 210
 211                   exit;
 212                end if;
 213
 214                if Is_Less (Left.Nodes (L_Node), Right.Nodes (R_Node)) then
 215                   Insert_With_Hint
 216                     (Dst_Set  => Result,
 217                      Dst_Hint => 0,
 218                      Src_Node => Left.Nodes (L_Node),
 219                      Dst_Node => Dst_Node);
 220
 221                   L_Node := Tree_Operations.Next (Left, L_Node);
 222
 223                elsif Is_Less (Right.Nodes (R_Node), Left.Nodes (L_Node)) then
 224                   R_Node := Tree_Operations.Next (Right, R_Node);
 225
 226                else
 227                   L_Node := Tree_Operations.Next (Left, L_Node);
 228                   R_Node := Tree_Operations.Next (Right, R_Node);
 229                end if;
 230             end loop;
 231
 232             BL := BL - 1;
 233             LL := LL - 1;
 234
 235             BR := BR - 1;
 236             LR := LR - 1;
 237          exception
 238             when others =>
 239                BL := BL - 1;
 240                LL := LL - 1;
 241
 242                BR := BR - 1;
 243                LR := LR - 1;
 244
 245                raise;
 246          end;
 247       end return;
 248    end Set_Difference;
 249
 250    ------------------
 251    -- Intersection --
 252    ------------------
 253
 254    procedure Set_Intersection
 255      (Target : in out Set_Type;
 256       Source : Set_Type)
 257    is
 258       BT : Natural renames Target.Busy;
 259       LT : Natural renames Target.Lock;
 260
 261       BS : Natural renames Source'Unrestricted_Access.Busy;
 262       LS : Natural renames Source'Unrestricted_Access.Lock;
 263
 264       Tgt : Count_Type;
 265       Src : Count_Type;
 266
 267       Compare : Integer;
 268
 269    begin
 270       if Target'Address = Source'Address then
 271          return;
 272       end if;
 273
 274       if Target.Busy > 0 then
 275          raise Program_Error with
 276            "attempt to tamper with cursors (container is busy)";
 277       end if;
 278
 279       if Source.Length = 0 then
 280          Tree_Operations.Clear_Tree (Target);
 281          return;
 282       end if;
 283
 284       Tgt := Target.First;
 285       Src := Source.First;
 286       while Tgt /= 0
 287         and then Src /= 0
 288       loop
 289          --  Per AI05-0022, the container implementation is required to detect
 290          --  element tampering by a generic actual subprogram.
 291
 292          begin
 293             BT := BT + 1;
 294             LT := LT + 1;
 295
 296             BS := BS + 1;
 297             LS := LS + 1;
 298
 299             if Is_Less (Target.Nodes (Tgt), Source.Nodes (Src)) then
 300                Compare := -1;
 301             elsif Is_Less (Source.Nodes (Src), Target.Nodes (Tgt)) then
 302                Compare := 1;
 303             else
 304                Compare := 0;
 305             end if;
 306
 307             BT := BT - 1;
 308             LT := LT - 1;
 309
 310             BS := BS - 1;
 311             LS := LS - 1;
 312          exception
 313             when others =>
 314                BT := BT - 1;
 315                LT := LT - 1;
 316
 317                BS := BS - 1;
 318                LS := LS - 1;
 319
 320                raise;
 321          end;
 322
 323          if Compare < 0 then
 324             declare
 325                X : constant Count_Type := Tgt;
 326             begin
 327                Tgt := Tree_Operations.Next (Target, Tgt);
 328
 329                Tree_Operations.Delete_Node_Sans_Free (Target, X);
 330                Tree_Operations.Free (Target, X);
 331             end;
 332
 333          elsif Compare > 0 then
 334             Src := Tree_Operations.Next (Source, Src);
 335
 336          else
 337             Tgt := Tree_Operations.Next (Target, Tgt);
 338             Src := Tree_Operations.Next (Source, Src);
 339          end if;
 340       end loop;
 341
 342       while Tgt /= 0 loop
 343          declare
 344             X : constant Count_Type := Tgt;
 345          begin
 346             Tgt := Tree_Operations.Next (Target, Tgt);
 347
 348             Tree_Operations.Delete_Node_Sans_Free (Target, X);
 349             Tree_Operations.Free (Target, X);
 350          end;
 351       end loop;
 352    end Set_Intersection;
 353
 354    function Set_Intersection (Left, Right : Set_Type) return Set_Type is
 355    begin
 356       if Left'Address = Right'Address then
 357          return Copy (Left);
 358       end if;
 359
 360       return Result : Set_Type (Count_Type'Min (Left.Length, Right.Length)) do
 361
 362          --  Per AI05-0022, the container implementation is required to detect
 363          --  element tampering by a generic actual subprogram.
 364
 365          declare
 366             BL : Natural renames Left'Unrestricted_Access.Busy;
 367             LL : Natural renames Left'Unrestricted_Access.Lock;
 368
 369             BR : Natural renames Right'Unrestricted_Access.Busy;
 370             LR : Natural renames Right'Unrestricted_Access.Lock;
 371
 372             L_Node : Count_Type;
 373             R_Node : Count_Type;
 374
 375             Dst_Node : Count_Type;
 376             pragma Warnings (Off, Dst_Node);
 377
 378          begin
 379             BL := BL + 1;
 380             LL := LL + 1;
 381
 382             BR := BR + 1;
 383             LR := LR + 1;
 384
 385             L_Node := Left.First;
 386             R_Node := Right.First;
 387             loop
 388                if L_Node = 0 then
 389                   exit;
 390                end if;
 391
 392                if R_Node = 0 then
 393                   exit;
 394                end if;
 395
 396                if Is_Less (Left.Nodes (L_Node), Right.Nodes (R_Node)) then
 397                   L_Node := Tree_Operations.Next (Left, L_Node);
 398
 399                elsif Is_Less (Right.Nodes (R_Node), Left.Nodes (L_Node)) then
 400                   R_Node := Tree_Operations.Next (Right, R_Node);
 401
 402                else
 403                   Insert_With_Hint
 404                     (Dst_Set  => Result,
 405                      Dst_Hint => 0,
 406                      Src_Node => Left.Nodes (L_Node),
 407                      Dst_Node => Dst_Node);
 408
 409                   L_Node := Tree_Operations.Next (Left, L_Node);
 410                   R_Node := Tree_Operations.Next (Right, R_Node);
 411                end if;
 412             end loop;
 413
 414             BL := BL - 1;
 415             LL := LL - 1;
 416
 417             BR := BR - 1;
 418             LR := LR - 1;
 419          exception
 420             when others =>
 421                BL := BL - 1;
 422                LL := LL - 1;
 423
 424                BR := BR - 1;
 425                LR := LR - 1;
 426
 427                raise;
 428          end;
 429       end return;
 430    end Set_Intersection;
 431
 432    ---------------
 433    -- Is_Subset --
 434    ---------------
 435
 436    function Set_Subset
 437      (Subset : Set_Type;
 438       Of_Set : Set_Type) return Boolean
 439    is
 440    begin
 441       if Subset'Address = Of_Set'Address then
 442          return True;
 443       end if;
 444
 445       if Subset.Length > Of_Set.Length then
 446          return False;
 447       end if;
 448
 449       --  Per AI05-0022, the container implementation is required to detect
 450       --  element tampering by a generic actual subprogram.
 451
 452       declare
 453          BL : Natural renames Subset'Unrestricted_Access.Busy;
 454          LL : Natural renames Subset'Unrestricted_Access.Lock;
 455
 456          BR : Natural renames Of_Set'Unrestricted_Access.Busy;
 457          LR : Natural renames Of_Set'Unrestricted_Access.Lock;
 458
 459          Subset_Node : Count_Type;
 460          Set_Node    : Count_Type;
 461
 462          Result : Boolean;
 463
 464       begin
 465          BL := BL + 1;
 466          LL := LL + 1;
 467
 468          BR := BR + 1;
 469          LR := LR + 1;
 470
 471          Subset_Node := Subset.First;
 472          Set_Node    := Of_Set.First;
 473          loop
 474             if Set_Node = 0 then
 475                Result := Subset_Node = 0;
 476                exit;
 477             end if;
 478
 479             if Subset_Node = 0 then
 480                Result := True;
 481                exit;
 482             end if;
 483
 484             if Is_Less (Subset.Nodes (Subset_Node),
 485                         Of_Set.Nodes (Set_Node))
 486             then
 487                Result := False;
 488                exit;
 489             end if;
 490
 491             if Is_Less (Of_Set.Nodes (Set_Node),
 492                         Subset.Nodes (Subset_Node))
 493             then
 494                Set_Node := Tree_Operations.Next (Of_Set, Set_Node);
 495             else
 496                Set_Node := Tree_Operations.Next (Of_Set, Set_Node);
 497                Subset_Node := Tree_Operations.Next (Subset, Subset_Node);
 498             end if;
 499          end loop;
 500
 501          BL := BL - 1;
 502          LL := LL - 1;
 503
 504          BR := BR - 1;
 505          LR := LR - 1;
 506
 507          return Result;
 508       exception
 509          when others =>
 510             BL := BL - 1;
 511             LL := LL - 1;
 512
 513             BR := BR - 1;
 514             LR := LR - 1;
 515
 516             raise;
 517       end;
 518    end Set_Subset;
 519
 520    -------------
 521    -- Overlap --
 522    -------------
 523
 524    function Set_Overlap (Left, Right : Set_Type) return Boolean is
 525    begin
 526       if Left'Address = Right'Address then
 527          return Left.Length /= 0;
 528       end if;
 529
 530       --  Per AI05-0022, the container implementation is required to detect
 531       --  element tampering by a generic actual subprogram.
 532
 533       declare
 534          BL : Natural renames Left'Unrestricted_Access.Busy;
 535          LL : Natural renames Left'Unrestricted_Access.Lock;
 536
 537          BR : Natural renames Right'Unrestricted_Access.Busy;
 538          LR : Natural renames Right'Unrestricted_Access.Lock;
 539
 540          L_Node : Count_Type;
 541          R_Node : Count_Type;
 542
 543          Result : Boolean;
 544
 545       begin
 546          BL := BL + 1;
 547          LL := LL + 1;
 548
 549          BR := BR + 1;
 550          LR := LR + 1;
 551
 552          L_Node := Left.First;
 553          R_Node := Right.First;
 554          loop
 555             if L_Node = 0
 556               or else R_Node = 0
 557             then
 558                Result := False;
 559                exit;
 560             end if;
 561
 562             if Is_Less (Left.Nodes (L_Node), Right.Nodes (R_Node)) then
 563                L_Node := Tree_Operations.Next (Left, L_Node);
 564
 565             elsif Is_Less (Right.Nodes (R_Node), Left.Nodes (L_Node)) then
 566                R_Node := Tree_Operations.Next (Right, R_Node);
 567
 568             else
 569                Result := True;
 570                exit;
 571             end if;
 572          end loop;
 573
 574          BL := BL - 1;
 575          LL := LL - 1;
 576
 577          BR := BR - 1;
 578          LR := LR - 1;
 579
 580          return Result;
 581       exception
 582          when others =>
 583             BL := BL - 1;
 584             LL := LL - 1;
 585
 586             BR := BR - 1;
 587             LR := LR - 1;
 588
 589             raise;
 590       end;
 591    end Set_Overlap;
 592
 593    --------------------------
 594    -- Symmetric_Difference --
 595    --------------------------
 596
 597    procedure Set_Symmetric_Difference
 598      (Target : in out Set_Type;
 599       Source : Set_Type)
 600    is
 601       BT : Natural renames Target.Busy;
 602       LT : Natural renames Target.Lock;
 603
 604       BS : Natural renames Source'Unrestricted_Access.Busy;
 605       LS : Natural renames Source'Unrestricted_Access.Lock;
 606
 607       Tgt : Count_Type;
 608       Src : Count_Type;
 609
 610       New_Tgt_Node : Count_Type;
 611       pragma Warnings (Off, New_Tgt_Node);
 612
 613       Compare : Integer;
 614
 615    begin
 616       if Target'Address = Source'Address then
 617          Tree_Operations.Clear_Tree (Target);
 618          return;
 619       end if;
 620
 621       Tgt := Target.First;
 622       Src := Source.First;
 623       loop
 624          if Tgt = 0 then
 625             while Src /= 0 loop
 626                Insert_With_Hint
 627                  (Dst_Set  => Target,
 628                   Dst_Hint => 0,
 629                   Src_Node => Source.Nodes (Src),
 630                   Dst_Node => New_Tgt_Node);
 631
 632                Src := Tree_Operations.Next (Source, Src);
 633             end loop;
 634
 635             return;
 636          end if;
 637
 638          if Src = 0 then
 639             return;
 640          end if;
 641
 642          --  Per AI05-0022, the container implementation is required to detect
 643          --  element tampering by a generic actual subprogram.
 644
 645          begin
 646             BT := BT + 1;
 647             LT := LT + 1;
 648
 649             BS := BS + 1;
 650             LS := LS + 1;
 651
 652             if Is_Less (Target.Nodes (Tgt), Source.Nodes (Src)) then
 653                Compare := -1;
 654             elsif Is_Less (Source.Nodes (Src), Target.Nodes (Tgt)) then
 655                Compare := 1;
 656             else
 657                Compare := 0;
 658             end if;
 659
 660             BT := BT - 1;
 661             LT := LT - 1;
 662
 663             BS := BS - 1;
 664             LS := LS - 1;
 665          exception
 666             when others =>
 667                BT := BT - 1;
 668                LT := LT - 1;
 669
 670                BS := BS - 1;
 671                LS := LS - 1;
 672
 673                raise;
 674          end;
 675
 676          if Compare < 0 then
 677             Tgt := Tree_Operations.Next (Target, Tgt);
 678
 679          elsif Compare > 0 then
 680             Insert_With_Hint
 681               (Dst_Set  => Target,
 682                Dst_Hint => Tgt,
 683                Src_Node => Source.Nodes (Src),
 684                Dst_Node => New_Tgt_Node);
 685
 686             Src := Tree_Operations.Next (Source, Src);
 687
 688          else
 689             declare
 690                X : constant Count_Type := Tgt;
 691             begin
 692                Tgt := Tree_Operations.Next (Target, Tgt);
 693
 694                Tree_Operations.Delete_Node_Sans_Free (Target, X);
 695                Tree_Operations.Free (Target, X);
 696             end;
 697
 698             Src := Tree_Operations.Next (Source, Src);
 699          end if;
 700       end loop;
 701    end Set_Symmetric_Difference;
 702
 703    function Set_Symmetric_Difference
 704      (Left, Right : Set_Type) return Set_Type
 705    is
 706    begin
 707       if Left'Address = Right'Address then
 708          return S : Set_Type (0);  -- Empty set
 709       end if;
 710
 711       if Right.Length = 0 then
 712          return Copy (Left);
 713       end if;
 714
 715       if Left.Length = 0 then
 716          return Copy (Right);
 717       end if;
 718
 719       return Result : Set_Type (Left.Length + Right.Length) do
 720
 721          --  Per AI05-0022, the container implementation is required to detect
 722          --  element tampering by a generic actual subprogram.
 723
 724          declare
 725             BL : Natural renames Left'Unrestricted_Access.Busy;
 726             LL : Natural renames Left'Unrestricted_Access.Lock;
 727
 728             BR : Natural renames Right'Unrestricted_Access.Busy;
 729             LR : Natural renames Right'Unrestricted_Access.Lock;
 730
 731             L_Node : Count_Type;
 732             R_Node : Count_Type;
 733
 734             Dst_Node : Count_Type;
 735             pragma Warnings (Off, Dst_Node);
 736
 737          begin
 738             BL := BL + 1;
 739             LL := LL + 1;
 740
 741             BR := BR + 1;
 742             LR := LR + 1;
 743
 744             L_Node := Left.First;
 745             R_Node := Right.First;
 746             loop
 747                if L_Node = 0 then
 748                   while R_Node /= 0 loop
 749                      Insert_With_Hint
 750                        (Dst_Set  => Result,
 751                         Dst_Hint => 0,
 752                         Src_Node => Right.Nodes (R_Node),
 753                         Dst_Node => Dst_Node);
 754
 755                      R_Node := Tree_Operations.Next (Right, R_Node);
 756                   end loop;
 757
 758                   exit;
 759                end if;
 760
 761                if R_Node = 0 then
 762                   while L_Node /= 0 loop
 763                      Insert_With_Hint
 764                        (Dst_Set  => Result,
 765                         Dst_Hint => 0,
 766                         Src_Node => Left.Nodes (L_Node),
 767                         Dst_Node => Dst_Node);
 768
 769                      L_Node := Tree_Operations.Next (Left, L_Node);
 770                   end loop;
 771
 772                   exit;
 773                end if;
 774
 775                if Is_Less (Left.Nodes (L_Node), Right.Nodes (R_Node)) then
 776                   Insert_With_Hint
 777                     (Dst_Set  => Result,
 778                      Dst_Hint => 0,
 779                      Src_Node => Left.Nodes (L_Node),
 780                      Dst_Node => Dst_Node);
 781
 782                   L_Node := Tree_Operations.Next (Left, L_Node);
 783
 784                elsif Is_Less (Right.Nodes (R_Node), Left.Nodes (L_Node)) then
 785                   Insert_With_Hint
 786                     (Dst_Set  => Result,
 787                      Dst_Hint => 0,
 788                      Src_Node => Right.Nodes (R_Node),
 789                      Dst_Node => Dst_Node);
 790
 791                   R_Node := Tree_Operations.Next (Right, R_Node);
 792
 793                else
 794                   L_Node := Tree_Operations.Next (Left, L_Node);
 795                   R_Node := Tree_Operations.Next (Right, R_Node);
 796                end if;
 797             end loop;
 798
 799             BL := BL - 1;
 800             LL := LL - 1;
 801
 802             BR := BR - 1;
 803             LR := LR - 1;
 804          exception
 805             when others =>
 806                BL := BL - 1;
 807                LL := LL - 1;
 808
 809                BR := BR - 1;
 810                LR := LR - 1;
 811
 812                raise;
 813          end;
 814       end return;
 815    end Set_Symmetric_Difference;
 816
 817    -----------
 818    -- Union --
 819    -----------
 820
 821    procedure Set_Union (Target : in out Set_Type; Source : Set_Type) is
 822       Hint : Count_Type := 0;
 823
 824       procedure Process (Node : Count_Type);
 825       pragma Inline (Process);
 826
 827       procedure Iterate is new Tree_Operations.Generic_Iteration (Process);
 828
 829       -------------
 830       -- Process --
 831       -------------
 832
 833       procedure Process (Node : Count_Type) is
 834       begin
 835          Insert_With_Hint
 836            (Dst_Set  => Target,
 837             Dst_Hint => Hint,
 838             Src_Node => Source.Nodes (Node),
 839             Dst_Node => Hint);
 840       end Process;
 841
 842    --  Start of processing for Union
 843
 844    begin
 845       if Target'Address = Source'Address then
 846          return;
 847       end if;
 848
 849       --  Per AI05-0022, the container implementation is required to detect
 850       --  element tampering by a generic actual subprogram.
 851
 852       declare
 853          BS : Natural renames Source'Unrestricted_Access.Busy;
 854          LS : Natural renames Source'Unrestricted_Access.Lock;
 855
 856       begin
 857          BS := BS + 1;
 858          LS := LS + 1;
 859
 860          --  Note that there's no way to decide a priori whether the target has
 861          --  enough capacity for the union with source. We cannot simply
 862          --  compare the sum of the existing lengths to the capacity of the
 863          --  target, because equivalent items from source are not included in
 864          --  the union.
 865
 866          Iterate (Source);
 867
 868          BS := BS - 1;
 869          LS := LS - 1;
 870       exception
 871          when others =>
 872             BS := BS - 1;
 873             LS := LS - 1;
 874
 875             raise;
 876       end;
 877    end Set_Union;
 878
 879    function Set_Union (Left, Right : Set_Type) return Set_Type is
 880    begin
 881       if Left'Address = Right'Address then
 882          return Copy (Left);
 883       end if;
 884
 885       if Left.Length = 0 then
 886          return Copy (Right);
 887       end if;
 888
 889       if Right.Length = 0 then
 890          return Copy (Left);
 891       end if;
 892
 893       return Result : Set_Type (Left.Length + Right.Length) do
 894          declare
 895             BL : Natural renames Left'Unrestricted_Access.Busy;
 896             LL : Natural renames Left'Unrestricted_Access.Lock;
 897
 898             BR : Natural renames Right'Unrestricted_Access.Busy;
 899             LR : Natural renames Right'Unrestricted_Access.Lock;
 900
 901          begin
 902             BL := BL + 1;
 903             LL := LL + 1;
 904
 905             BR := BR + 1;
 906             LR := LR + 1;
 907
 908             Assign (Target => Result, Source => Left);
 909
 910             Insert_Right : declare
 911                Hint : Count_Type := 0;
 912
 913                procedure Process (Node : Count_Type);
 914                pragma Inline (Process);
 915
 916                procedure Iterate is
 917                  new Tree_Operations.Generic_Iteration (Process);
 918
 919                -------------
 920                -- Process --
 921                -------------
 922
 923                procedure Process (Node : Count_Type) is
 924                begin
 925                   Insert_With_Hint
 926                     (Dst_Set  => Result,
 927                      Dst_Hint => Hint,
 928                      Src_Node => Right.Nodes (Node),
 929                      Dst_Node => Hint);
 930                end Process;
 931
 932             --  Start of processing for Insert_Right
 933
 934             begin
 935                Iterate (Right);
 936             end Insert_Right;
 937
 938             BL := BL - 1;
 939             LL := LL - 1;
 940
 941             BR := BR - 1;
 942             LR := LR - 1;
 943          exception
 944             when others =>
 945                BL := BL - 1;
 946                LL := LL - 1;
 947
 948                BR := BR - 1;
 949                LR := LR - 1;
 950
 951                raise;
 952          end;
 953       end return;
 954    end Set_Union;
 955
 956 end Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations;