gcc/ada/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-2007, 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 2,  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.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- This unit was originally developed by Matthew J Heaney.                  --
  30 ------------------------------------------------------------------------------
  31
  32 with System; use type System.Address;
  33
  34 package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is
  35
  36    -----------------------
  37    -- Local Subprograms --
  38    -----------------------
  39
  40    procedure Clear (Tree : in out Tree_Type);
  41
  42    function Copy (Source : Tree_Type) return Tree_Type;
  43
  44    -----------
  45    -- Clear --
  46    -----------
  47
  48    procedure Clear (Tree : in out Tree_Type) is
  49       pragma Assert (Tree.Busy = 0);
  50       pragma Assert (Tree.Lock = 0);
  51
  52       Root : Node_Access := Tree.Root;
  53       pragma Warnings (Off, Root);
  54
  55    begin
  56       Tree.Root := null;
  57       Tree.First := null;
  58       Tree.Last := null;
  59       Tree.Length := 0;
  60
  61       Delete_Tree (Root);
  62    end Clear;
  63
  64    ----------
  65    -- Copy --
  66    ----------
  67
  68    function Copy (Source : Tree_Type) return Tree_Type is
  69       Target : Tree_Type;
  70
  71    begin
  72       if Source.Length = 0 then
  73          return Target;
  74       end if;
  75
  76       Target.Root := Copy_Tree (Source.Root);
  77       Target.First := Tree_Operations.Min (Target.Root);
  78       Target.Last := Tree_Operations.Max (Target.Root);
  79       Target.Length := Source.Length;
  80
  81       return Target;
  82    end Copy;
  83
  84    ----------------
  85    -- Difference --
  86    ----------------
  87
  88    procedure Difference (Target : in out Tree_Type; Source : Tree_Type) is
  89       Tgt : Node_Access := Target.First;
  90       Src : Node_Access := Source.First;
  91
  92    begin
  93       if Target'Address = Source'Address then
  94          if Target.Busy > 0 then
  95             raise Program_Error with
  96               "attempt to tamper with cursors (container is busy)";
  97          end if;
  98
  99          Clear (Target);
 100          return;
 101       end if;
 102
 103       if Source.Length = 0 then
 104          return;
 105       end if;
 106
 107       if Target.Busy > 0 then
 108          raise Program_Error with
 109            "attempt to tamper with cursors (container is busy)";
 110       end if;
 111
 112       loop
 113          if Tgt = null then
 114             return;
 115          end if;
 116
 117          if Src = null then
 118             return;
 119          end if;
 120
 121          if Is_Less (Tgt, Src) then
 122             Tgt := Tree_Operations.Next (Tgt);
 123
 124          elsif Is_Less (Src, Tgt) then
 125             Src := Tree_Operations.Next (Src);
 126
 127          else
 128             declare
 129                X : Node_Access := Tgt;
 130             begin
 131                Tgt := Tree_Operations.Next (Tgt);
 132                Tree_Operations.Delete_Node_Sans_Free (Target, X);
 133                Free (X);
 134             end;
 135
 136             Src := Tree_Operations.Next (Src);
 137          end if;
 138       end loop;
 139    end Difference;
 140
 141    function Difference (Left, Right : Tree_Type) return Tree_Type is
 142       Tree : Tree_Type;
 143
 144       L_Node : Node_Access := Left.First;
 145       R_Node : Node_Access := Right.First;
 146
 147       Dst_Node : Node_Access;
 148       pragma Warnings (Off, Dst_Node);
 149
 150    begin
 151       if Left'Address = Right'Address then
 152          return Tree;  -- Empty set
 153       end if;
 154
 155       if Left.Length = 0 then
 156          return Tree;  -- Empty set
 157       end if;
 158
 159       if Right.Length = 0 then
 160          return Copy (Left);
 161       end if;
 162
 163       loop
 164          if L_Node = null then
 165             return Tree;
 166          end if;
 167
 168          if R_Node = null then
 169             while L_Node /= null loop
 170                Insert_With_Hint
 171                  (Dst_Tree => Tree,
 172                   Dst_Hint => null,
 173                   Src_Node => L_Node,
 174                   Dst_Node => Dst_Node);
 175
 176                L_Node := Tree_Operations.Next (L_Node);
 177
 178             end loop;
 179
 180             return Tree;
 181          end if;
 182
 183          if Is_Less (L_Node, R_Node) then
 184             Insert_With_Hint
 185               (Dst_Tree => Tree,
 186                Dst_Hint => null,
 187                Src_Node => L_Node,
 188                Dst_Node => Dst_Node);
 189
 190             L_Node := Tree_Operations.Next (L_Node);
 191
 192          elsif Is_Less (R_Node, L_Node) then
 193             R_Node := Tree_Operations.Next (R_Node);
 194
 195          else
 196             L_Node := Tree_Operations.Next (L_Node);
 197             R_Node := Tree_Operations.Next (R_Node);
 198          end if;
 199       end loop;
 200
 201    exception
 202       when others =>
 203          Delete_Tree (Tree.Root);
 204          raise;
 205    end Difference;
 206
 207    ------------------
 208    -- Intersection --
 209    ------------------
 210
 211    procedure Intersection
 212      (Target : in out Tree_Type;
 213       Source : Tree_Type)
 214    is
 215       Tgt : Node_Access := Target.First;
 216       Src : Node_Access := Source.First;
 217
 218    begin
 219       if Target'Address = Source'Address then
 220          return;
 221       end if;
 222
 223       if Target.Busy > 0 then
 224          raise Program_Error with
 225            "attempt to tamper with cursors (container is busy)";
 226       end if;
 227
 228       if Source.Length = 0 then
 229          Clear (Target);
 230          return;
 231       end if;
 232
 233       while Tgt /= null
 234         and then Src /= null
 235       loop
 236          if Is_Less (Tgt, Src) then
 237             declare
 238                X : Node_Access := Tgt;
 239             begin
 240                Tgt := Tree_Operations.Next (Tgt);
 241                Tree_Operations.Delete_Node_Sans_Free (Target, X);
 242                Free (X);
 243             end;
 244
 245          elsif Is_Less (Src, Tgt) then
 246             Src := Tree_Operations.Next (Src);
 247
 248          else
 249             Tgt := Tree_Operations.Next (Tgt);
 250             Src := Tree_Operations.Next (Src);
 251          end if;
 252       end loop;
 253
 254       while Tgt /= null loop
 255          declare
 256             X : Node_Access := Tgt;
 257          begin
 258             Tgt := Tree_Operations.Next (Tgt);
 259             Tree_Operations.Delete_Node_Sans_Free (Target, X);
 260             Free (X);
 261          end;
 262       end loop;
 263    end Intersection;
 264
 265    function Intersection (Left, Right : Tree_Type) return Tree_Type is
 266       Tree : Tree_Type;
 267
 268       L_Node : Node_Access := Left.First;
 269       R_Node : Node_Access := Right.First;
 270
 271       Dst_Node : Node_Access;
 272       pragma Warnings (Off, Dst_Node);
 273
 274    begin
 275       if Left'Address = Right'Address then
 276          return Copy (Left);
 277       end if;
 278
 279       loop
 280          if L_Node = null then
 281             return Tree;
 282          end if;
 283
 284          if R_Node = null then
 285             return Tree;
 286          end if;
 287
 288          if Is_Less (L_Node, R_Node) then
 289             L_Node := Tree_Operations.Next (L_Node);
 290
 291          elsif Is_Less (R_Node, L_Node) then
 292             R_Node := Tree_Operations.Next (R_Node);
 293
 294          else
 295             Insert_With_Hint
 296               (Dst_Tree => Tree,
 297                Dst_Hint => null,
 298                Src_Node => L_Node,
 299                Dst_Node => Dst_Node);
 300
 301             L_Node := Tree_Operations.Next (L_Node);
 302             R_Node := Tree_Operations.Next (R_Node);
 303          end if;
 304       end loop;
 305
 306    exception
 307       when others =>
 308          Delete_Tree (Tree.Root);
 309          raise;
 310    end Intersection;
 311
 312    ---------------
 313    -- Is_Subset --
 314    ---------------
 315
 316    function Is_Subset
 317      (Subset : Tree_Type;
 318       Of_Set : Tree_Type) return Boolean
 319    is
 320    begin
 321       if Subset'Address = Of_Set'Address then
 322          return True;
 323       end if;
 324
 325       if Subset.Length > Of_Set.Length then
 326          return False;
 327       end if;
 328
 329       declare
 330          Subset_Node : Node_Access := Subset.First;
 331          Set_Node    : Node_Access := Of_Set.First;
 332
 333       begin
 334          loop
 335             if Set_Node = null then
 336                return Subset_Node = null;
 337             end if;
 338
 339             if Subset_Node = null then
 340                return True;
 341             end if;
 342
 343             if Is_Less (Subset_Node, Set_Node) then
 344                return False;
 345             end if;
 346
 347             if Is_Less (Set_Node, Subset_Node) then
 348                Set_Node := Tree_Operations.Next (Set_Node);
 349             else
 350                Set_Node := Tree_Operations.Next (Set_Node);
 351                Subset_Node := Tree_Operations.Next (Subset_Node);
 352             end if;
 353          end loop;
 354       end;
 355    end Is_Subset;
 356
 357    -------------
 358    -- Overlap --
 359    -------------
 360
 361    function Overlap (Left, Right : Tree_Type) return Boolean is
 362       L_Node : Node_Access := Left.First;
 363       R_Node : Node_Access := Right.First;
 364
 365    begin
 366       if Left'Address = Right'Address then
 367          return Left.Length /= 0;
 368       end if;
 369
 370       loop
 371          if L_Node = null
 372            or else R_Node = null
 373          then
 374             return False;
 375          end if;
 376
 377          if Is_Less (L_Node, R_Node) then
 378             L_Node := Tree_Operations.Next (L_Node);
 379
 380          elsif Is_Less (R_Node, L_Node) then
 381             R_Node := Tree_Operations.Next (R_Node);
 382
 383          else
 384             return True;
 385          end if;
 386       end loop;
 387    end Overlap;
 388
 389    --------------------------
 390    -- Symmetric_Difference --
 391    --------------------------
 392
 393    procedure Symmetric_Difference
 394      (Target : in out Tree_Type;
 395       Source : Tree_Type)
 396    is
 397       Tgt : Node_Access := Target.First;
 398       Src : Node_Access := Source.First;
 399
 400       New_Tgt_Node : Node_Access;
 401       pragma Warnings (Off, New_Tgt_Node);
 402
 403    begin
 404       if Target.Busy > 0 then
 405          raise Program_Error with
 406            "attempt to tamper with cursors (container is busy)";
 407       end if;
 408
 409       if Target'Address = Source'Address then
 410          Clear (Target);
 411          return;
 412       end if;
 413
 414       loop
 415          if Tgt = null then
 416             while Src /= null loop
 417                Insert_With_Hint
 418                  (Dst_Tree => Target,
 419                   Dst_Hint => null,
 420                   Src_Node => Src,
 421                   Dst_Node => New_Tgt_Node);
 422
 423                Src := Tree_Operations.Next (Src);
 424             end loop;
 425
 426             return;
 427          end if;
 428
 429          if Src = null then
 430             return;
 431          end if;
 432
 433          if Is_Less (Tgt, Src) then
 434             Tgt := Tree_Operations.Next (Tgt);
 435
 436          elsif Is_Less (Src, Tgt) then
 437             Insert_With_Hint
 438               (Dst_Tree => Target,
 439                Dst_Hint => Tgt,
 440                Src_Node => Src,
 441                Dst_Node => New_Tgt_Node);
 442
 443             Src := Tree_Operations.Next (Src);
 444
 445          else
 446             declare
 447                X : Node_Access := Tgt;
 448             begin
 449                Tgt := Tree_Operations.Next (Tgt);
 450                Tree_Operations.Delete_Node_Sans_Free (Target, X);
 451                Free (X);
 452             end;
 453
 454             Src := Tree_Operations.Next (Src);
 455          end if;
 456       end loop;
 457    end Symmetric_Difference;
 458
 459    function Symmetric_Difference (Left, Right : Tree_Type) return Tree_Type is
 460       Tree : Tree_Type;
 461
 462       L_Node : Node_Access := Left.First;
 463       R_Node : Node_Access := Right.First;
 464
 465       Dst_Node : Node_Access;
 466       pragma Warnings (Off, Dst_Node);
 467
 468    begin
 469       if Left'Address = Right'Address then
 470          return Tree;  -- Empty set
 471       end if;
 472
 473       if Right.Length = 0 then
 474          return Copy (Left);
 475       end if;
 476
 477       if Left.Length = 0 then
 478          return Copy (Right);
 479       end if;
 480
 481       loop
 482          if L_Node = null then
 483             while R_Node /= null loop
 484                Insert_With_Hint
 485                  (Dst_Tree => Tree,
 486                   Dst_Hint => null,
 487                   Src_Node => R_Node,
 488                   Dst_Node => Dst_Node);
 489                R_Node := Tree_Operations.Next (R_Node);
 490             end loop;
 491
 492             return Tree;
 493          end if;
 494
 495          if R_Node = null then
 496             while L_Node /= null loop
 497                Insert_With_Hint
 498                  (Dst_Tree => Tree,
 499                   Dst_Hint => null,
 500                   Src_Node => L_Node,
 501                   Dst_Node => Dst_Node);
 502
 503                L_Node := Tree_Operations.Next (L_Node);
 504             end loop;
 505
 506             return Tree;
 507          end if;
 508
 509          if Is_Less (L_Node, R_Node) then
 510             Insert_With_Hint
 511               (Dst_Tree => Tree,
 512                Dst_Hint => null,
 513                Src_Node => L_Node,
 514                Dst_Node => Dst_Node);
 515
 516             L_Node := Tree_Operations.Next (L_Node);
 517
 518          elsif Is_Less (R_Node, L_Node) then
 519             Insert_With_Hint
 520               (Dst_Tree => Tree,
 521                Dst_Hint => null,
 522                Src_Node => R_Node,
 523                Dst_Node => Dst_Node);
 524
 525             R_Node := Tree_Operations.Next (R_Node);
 526
 527          else
 528             L_Node := Tree_Operations.Next (L_Node);
 529             R_Node := Tree_Operations.Next (R_Node);
 530          end if;
 531       end loop;
 532
 533    exception
 534       when others =>
 535          Delete_Tree (Tree.Root);
 536          raise;
 537    end Symmetric_Difference;
 538
 539    -----------
 540    -- Union --
 541    -----------
 542
 543    procedure Union (Target : in out Tree_Type; Source : Tree_Type)
 544    is
 545       Hint : Node_Access;
 546
 547       procedure Process (Node : Node_Access);
 548       pragma Inline (Process);
 549
 550       procedure Iterate is new Tree_Operations.Generic_Iteration (Process);
 551
 552       -------------
 553       -- Process --
 554       -------------
 555
 556       procedure Process (Node : Node_Access) is
 557       begin
 558          Insert_With_Hint
 559            (Dst_Tree => Target,
 560             Dst_Hint => Hint,
 561             Src_Node => Node,
 562             Dst_Node => Hint);
 563       end Process;
 564
 565    --  Start of processing for Union
 566
 567    begin
 568       if Target'Address = Source'Address then
 569          return;
 570       end if;
 571
 572       if Target.Busy > 0 then
 573          raise Program_Error with
 574            "attempt to tamper with cursors (container is busy)";
 575       end if;
 576
 577       Iterate (Source);
 578    end Union;
 579
 580    function Union (Left, Right : Tree_Type) return Tree_Type is
 581    begin
 582       if Left'Address = Right'Address then
 583          return Copy (Left);
 584       end if;
 585
 586       if Left.Length = 0 then
 587          return Copy (Right);
 588       end if;
 589
 590       if Right.Length = 0 then
 591          return Copy (Left);
 592       end if;
 593
 594       declare
 595          Tree : Tree_Type := Copy (Left);
 596
 597          Hint : Node_Access;
 598
 599          procedure Process (Node : Node_Access);
 600          pragma Inline (Process);
 601
 602          procedure Iterate is
 603            new Tree_Operations.Generic_Iteration (Process);
 604
 605          -------------
 606          -- Process --
 607          -------------
 608
 609          procedure Process (Node : Node_Access) is
 610          begin
 611             Insert_With_Hint
 612               (Dst_Tree => Tree,
 613                Dst_Hint => Hint,
 614                Src_Node => Node,
 615                Dst_Node => Hint);
 616          end Process;
 617
 618       --  Start of processing for Union
 619
 620       begin
 621          Iterate (Right);
 622          return Tree;
 623
 624       exception
 625          when others =>
 626             Delete_Tree (Tree.Root);
 627             raise;
 628       end;
 629
 630    end Union;
 631
 632 end Ada.Containers.Red_Black_Trees.Generic_Set_Operations;