gcc/ada/a-rbtgso.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT LIBRARY COMPONENTS                          --
   4 --                                                                          --
   5 --       A D A . C O N T A I N E R S . R E D _ B L A C K _ T R E E S .      --
   6 --               G E N E R I C _ S E T _ O P E R A T I O N S                --
   7 --                                                                          --
   8 --                                 B o d y                                  --
   9 --                                                                          --
  10 --          Copyright (C) 2004-2005, Free Software Foundation, Inc.         --
  11 --                                                                          --
  12 -- This specification is derived from the Ada Reference Manual for use with --
  13 -- GNAT. The copyright notice above, and the license provisions that follow --
  14 -- apply solely to the  contents of the part following the private keyword. --
  15 --                                                                          --
  16 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  17 -- terms of the  GNU General Public License as published  by the Free Soft- --
  18 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  19 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  20 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  21 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  22 -- for  more details.  You should have  received  a copy of the GNU General --
  23 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  24 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  25 -- Boston, MA 02110-1301, USA.                                              --
  26 --                                                                          --
  27 -- As a special exception,  if other files  instantiate  generics from this --
  28 -- unit, or you link  this unit with other files  to produce an executable, --
  29 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  30 -- covered  by the  GNU  General  Public  License.  This exception does not --
  31 -- however invalidate  any other reasons why  the executable file  might be --
  32 -- covered by the  GNU Public License.                                      --
  33 --                                                                          --
  34 -- This unit was originally developed by Matthew J Heaney.                  --
  35 ------------------------------------------------------------------------------
  36
  37 with System; use type System.Address;
  38
  39 package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is
  40
  41    -----------------------
  42    -- Local Subprograms --
  43    -----------------------
  44
  45    procedure Clear (Tree : in out Tree_Type);
  46
  47    function Copy (Source : Tree_Type) return Tree_Type;
  48
  49    -----------
  50    -- Clear --
  51    -----------
  52
  53    procedure Clear (Tree : in out Tree_Type) is
  54       pragma Assert (Tree.Busy = 0);
  55       pragma Assert (Tree.Lock = 0);
  56
  57       Root : Node_Access := Tree.Root;
  58
  59    begin
  60       Tree.Root := null;
  61       Tree.First := null;
  62       Tree.Last := null;
  63       Tree.Length := 0;
  64
  65       Delete_Tree (Root);
  66    end Clear;
  67
  68    ----------
  69    -- Copy --
  70    ----------
  71
  72    function Copy (Source : Tree_Type) return Tree_Type is
  73       Target : Tree_Type;
  74
  75    begin
  76       if Source.Length = 0 then
  77          return Target;
  78       end if;
  79
  80       Target.Root := Copy_Tree (Source.Root);
  81       Target.First := Tree_Operations.Min (Target.Root);
  82       Target.Last := Tree_Operations.Max (Target.Root);
  83       Target.Length := Source.Length;
  84
  85       return Target;
  86    end Copy;
  87
  88    ----------------
  89    -- Difference --
  90    ----------------
  91
  92    procedure Difference (Target : in out Tree_Type; Source : Tree_Type) is
  93       Tgt : Node_Access := Target.First;
  94       Src : Node_Access := Source.First;
  95
  96    begin
  97       if Target'Address = Source'Address then
  98          if Target.Busy > 0 then
  99             raise Program_Error with
 100               "attempt to tamper with cursors (container is busy)";
 101          end if;
 102
 103          Clear (Target);
 104          return;
 105       end if;
 106
 107       if Source.Length = 0 then
 108          return;
 109       end if;
 110
 111       if Target.Busy > 0 then
 112          raise Program_Error with
 113            "attempt to tamper with cursors (container is busy)";
 114       end if;
 115
 116       loop
 117          if Tgt = null then
 118             return;
 119          end if;
 120
 121          if Src = null then
 122             return;
 123          end if;
 124
 125          if Is_Less (Tgt, Src) then
 126             Tgt := Tree_Operations.Next (Tgt);
 127
 128          elsif Is_Less (Src, Tgt) then
 129             Src := Tree_Operations.Next (Src);
 130
 131          else
 132             declare
 133                X : Node_Access := Tgt;
 134             begin
 135                Tgt := Tree_Operations.Next (Tgt);
 136                Tree_Operations.Delete_Node_Sans_Free (Target, X);
 137                Free (X);
 138             end;
 139
 140             Src := Tree_Operations.Next (Src);
 141          end if;
 142       end loop;
 143    end Difference;
 144
 145    function Difference (Left, Right : Tree_Type) return Tree_Type is
 146       Tree : Tree_Type;
 147
 148       L_Node : Node_Access := Left.First;
 149       R_Node : Node_Access := Right.First;
 150
 151       Dst_Node : Node_Access;
 152
 153    begin
 154       if Left'Address = Right'Address then
 155          return Tree;  -- Empty set
 156       end if;
 157
 158       if Left.Length = 0 then
 159          return Tree;  -- Empty set
 160       end if;
 161
 162       if Right.Length = 0 then
 163          return Copy (Left);
 164       end if;
 165
 166       loop
 167          if L_Node = null then
 168             return Tree;
 169          end if;
 170
 171          if R_Node = null then
 172             while L_Node /= null loop
 173                Insert_With_Hint
 174                  (Dst_Tree => Tree,
 175                   Dst_Hint => null,
 176                   Src_Node => L_Node,
 177                   Dst_Node => Dst_Node);
 178
 179                L_Node := Tree_Operations.Next (L_Node);
 180
 181             end loop;
 182
 183             return Tree;
 184          end if;
 185
 186          if Is_Less (L_Node, R_Node) then
 187             Insert_With_Hint
 188               (Dst_Tree => Tree,
 189                Dst_Hint => null,
 190                Src_Node => L_Node,
 191                Dst_Node => Dst_Node);
 192
 193             L_Node := Tree_Operations.Next (L_Node);
 194
 195          elsif Is_Less (R_Node, L_Node) then
 196             R_Node := Tree_Operations.Next (R_Node);
 197
 198          else
 199             L_Node := Tree_Operations.Next (L_Node);
 200             R_Node := Tree_Operations.Next (R_Node);
 201          end if;
 202       end loop;
 203
 204    exception
 205       when others =>
 206          Delete_Tree (Tree.Root);
 207          raise;
 208    end Difference;
 209
 210    ------------------
 211    -- Intersection --
 212    ------------------
 213
 214    procedure Intersection
 215      (Target : in out Tree_Type;
 216       Source : Tree_Type)
 217    is
 218       Tgt : Node_Access := Target.First;
 219       Src : Node_Access := Source.First;
 220
 221    begin
 222       if Target'Address = Source'Address then
 223          return;
 224       end if;
 225
 226       if Target.Busy > 0 then
 227          raise Program_Error with
 228            "attempt to tamper with cursors (container is busy)";
 229       end if;
 230
 231       if Source.Length = 0 then
 232          Clear (Target);
 233          return;
 234       end if;
 235
 236       while Tgt /= null
 237         and then Src /= null
 238       loop
 239          if Is_Less (Tgt, Src) then
 240             declare
 241                X : Node_Access := Tgt;
 242             begin
 243                Tgt := Tree_Operations.Next (Tgt);
 244                Tree_Operations.Delete_Node_Sans_Free (Target, X);
 245                Free (X);
 246             end;
 247
 248          elsif Is_Less (Src, Tgt) then
 249             Src := Tree_Operations.Next (Src);
 250
 251          else
 252             Tgt := Tree_Operations.Next (Tgt);
 253             Src := Tree_Operations.Next (Src);
 254          end if;
 255       end loop;
 256
 257       while Tgt /= null loop
 258          declare
 259             X : Node_Access := Tgt;
 260          begin
 261             Tgt := Tree_Operations.Next (Tgt);
 262             Tree_Operations.Delete_Node_Sans_Free (Target, X);
 263             Free (X);
 264          end;
 265       end loop;
 266    end Intersection;
 267
 268    function Intersection (Left, Right : Tree_Type) return Tree_Type is
 269       Tree : Tree_Type;
 270
 271       L_Node : Node_Access := Left.First;
 272       R_Node : Node_Access := Right.First;
 273
 274       Dst_Node : Node_Access;
 275
 276    begin
 277       if Left'Address = Right'Address then
 278          return Copy (Left);
 279       end if;
 280
 281       loop
 282          if L_Node = null then
 283             return Tree;
 284          end if;
 285
 286          if R_Node = null then
 287             return Tree;
 288          end if;
 289
 290          if Is_Less (L_Node, R_Node) then
 291             L_Node := Tree_Operations.Next (L_Node);
 292
 293          elsif Is_Less (R_Node, L_Node) then
 294             R_Node := Tree_Operations.Next (R_Node);
 295
 296          else
 297             Insert_With_Hint
 298               (Dst_Tree => Tree,
 299                Dst_Hint => null,
 300                Src_Node => L_Node,
 301                Dst_Node => Dst_Node);
 302
 303             L_Node := Tree_Operations.Next (L_Node);
 304             R_Node := Tree_Operations.Next (R_Node);
 305          end if;
 306       end loop;
 307
 308    exception
 309       when others =>
 310          Delete_Tree (Tree.Root);
 311          raise;
 312    end Intersection;
 313
 314    ---------------
 315    -- Is_Subset --
 316    ---------------
 317
 318    function Is_Subset
 319      (Subset : Tree_Type;
 320       Of_Set : Tree_Type) return Boolean
 321    is
 322    begin
 323       if Subset'Address = Of_Set'Address then
 324          return True;
 325       end if;
 326
 327       if Subset.Length > Of_Set.Length then
 328          return False;
 329       end if;
 330
 331       declare
 332          Subset_Node : Node_Access := Subset.First;
 333          Set_Node    : Node_Access := Of_Set.First;
 334
 335       begin
 336          loop
 337             if Set_Node = null then
 338                return Subset_Node = null;
 339             end if;
 340
 341             if Subset_Node = null then
 342                return True;
 343             end if;
 344
 345             if Is_Less (Subset_Node, Set_Node) then
 346                return False;
 347             end if;
 348
 349             if Is_Less (Set_Node, Subset_Node) then
 350                Set_Node := Tree_Operations.Next (Set_Node);
 351             else
 352                Set_Node := Tree_Operations.Next (Set_Node);
 353                Subset_Node := Tree_Operations.Next (Subset_Node);
 354             end if;
 355          end loop;
 356       end;
 357    end Is_Subset;
 358
 359    -------------
 360    -- Overlap --
 361    -------------
 362
 363    function Overlap (Left, Right : Tree_Type) return Boolean is
 364       L_Node : Node_Access := Left.First;
 365       R_Node : Node_Access := Right.First;
 366
 367    begin
 368       if Left'Address = Right'Address then
 369          return Left.Length /= 0;
 370       end if;
 371
 372       loop
 373          if L_Node = null
 374            or else R_Node = null
 375          then
 376             return False;
 377          end if;
 378
 379          if Is_Less (L_Node, R_Node) then
 380             L_Node := Tree_Operations.Next (L_Node);
 381
 382          elsif Is_Less (R_Node, L_Node) then
 383             R_Node := Tree_Operations.Next (R_Node);
 384
 385          else
 386             return True;
 387          end if;
 388       end loop;
 389    end Overlap;
 390
 391    --------------------------
 392    -- Symmetric_Difference --
 393    --------------------------
 394
 395    procedure Symmetric_Difference
 396      (Target : in out Tree_Type;
 397       Source : Tree_Type)
 398    is
 399       Tgt : Node_Access := Target.First;
 400       Src : Node_Access := Source.First;
 401
 402       New_Tgt_Node : Node_Access;
 403
 404    begin
 405       if Target.Busy > 0 then
 406          raise Program_Error with
 407            "attempt to tamper with cursors (container is busy)";
 408       end if;
 409
 410       if Target'Address = Source'Address then
 411          Clear (Target);
 412          return;
 413       end if;
 414
 415       loop
 416          if Tgt = null then
 417             while Src /= null loop
 418                Insert_With_Hint
 419                  (Dst_Tree => Target,
 420                   Dst_Hint => null,
 421                   Src_Node => Src,
 422                   Dst_Node => New_Tgt_Node);
 423
 424                Src := Tree_Operations.Next (Src);
 425             end loop;
 426
 427             return;
 428          end if;
 429
 430          if Src = null then
 431             return;
 432          end if;
 433
 434          if Is_Less (Tgt, Src) then
 435             Tgt := Tree_Operations.Next (Tgt);
 436
 437          elsif Is_Less (Src, Tgt) then
 438             Insert_With_Hint
 439               (Dst_Tree => Target,
 440                Dst_Hint => Tgt,
 441                Src_Node => Src,
 442                Dst_Node => New_Tgt_Node);
 443
 444             Src := Tree_Operations.Next (Src);
 445
 446          else
 447             declare
 448                X : Node_Access := Tgt;
 449             begin
 450                Tgt := Tree_Operations.Next (Tgt);
 451                Tree_Operations.Delete_Node_Sans_Free (Target, X);
 452                Free (X);
 453             end;
 454
 455             Src := Tree_Operations.Next (Src);
 456          end if;
 457       end loop;
 458    end Symmetric_Difference;
 459
 460    function Symmetric_Difference (Left, Right : Tree_Type) return Tree_Type is
 461       Tree : Tree_Type;
 462
 463       L_Node : Node_Access := Left.First;
 464       R_Node : Node_Access := Right.First;
 465
 466       Dst_Node : Node_Access;
 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;