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;
 100          end if;
 101
 102          Clear (Target);
 103          return;
 104       end if;
 105
 106       if Source.Length = 0 then
 107          return;
 108       end if;
 109
 110       if Target.Busy > 0 then
 111          raise Program_Error;
 112       end if;
 113
 114       loop
 115          if Tgt = null then
 116             return;
 117          end if;
 118
 119          if Src = null then
 120             return;
 121          end if;
 122
 123          if Is_Less (Tgt, Src) then
 124             Tgt := Tree_Operations.Next (Tgt);
 125
 126          elsif Is_Less (Src, Tgt) then
 127             Src := Tree_Operations.Next (Src);
 128
 129          else
 130             declare
 131                X : Node_Access := Tgt;
 132             begin
 133                Tgt := Tree_Operations.Next (Tgt);
 134                Tree_Operations.Delete_Node_Sans_Free (Target, X);
 135                Free (X);
 136             end;
 137
 138             Src := Tree_Operations.Next (Src);
 139          end if;
 140       end loop;
 141    end Difference;
 142
 143    function Difference (Left, Right : Tree_Type) return Tree_Type is
 144       Tree : Tree_Type;
 145
 146       L_Node : Node_Access := Left.First;
 147       R_Node : Node_Access := Right.First;
 148
 149       Dst_Node : Node_Access;
 150
 151    begin
 152       if Left'Address = Right'Address then
 153          return Tree;  -- Empty set
 154       end if;
 155
 156       if Left.Length = 0 then
 157          return Tree;  -- Empty set
 158       end if;
 159
 160       if Right.Length = 0 then
 161          return Copy (Left);
 162       end if;
 163
 164       loop
 165          if L_Node = null then
 166             return Tree;
 167          end if;
 168
 169          if R_Node = null then
 170             while L_Node /= null loop
 171                Insert_With_Hint
 172                  (Dst_Tree => Tree,
 173                   Dst_Hint => null,
 174                   Src_Node => L_Node,
 175                   Dst_Node => Dst_Node);
 176
 177                L_Node := Tree_Operations.Next (L_Node);
 178
 179             end loop;
 180
 181             return Tree;
 182          end if;
 183
 184          if Is_Less (L_Node, R_Node) then
 185             Insert_With_Hint
 186               (Dst_Tree => Tree,
 187                Dst_Hint => null,
 188                Src_Node => L_Node,
 189                Dst_Node => Dst_Node);
 190
 191             L_Node := Tree_Operations.Next (L_Node);
 192
 193          elsif Is_Less (R_Node, L_Node) then
 194             R_Node := Tree_Operations.Next (R_Node);
 195
 196          else
 197             L_Node := Tree_Operations.Next (L_Node);
 198             R_Node := Tree_Operations.Next (R_Node);
 199          end if;
 200       end loop;
 201
 202    exception
 203       when others =>
 204          Delete_Tree (Tree.Root);
 205          raise;
 206    end Difference;
 207
 208    ------------------
 209    -- Intersection --
 210    ------------------
 211
 212    procedure Intersection
 213      (Target : in out Tree_Type;
 214       Source : Tree_Type)
 215    is
 216       Tgt : Node_Access := Target.First;
 217       Src : Node_Access := Source.First;
 218
 219    begin
 220       if Target'Address = Source'Address then
 221          return;
 222       end if;
 223
 224       if Target.Busy > 0 then
 225          raise Program_Error;
 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
 273    begin
 274       if Left'Address = Right'Address then
 275          return Copy (Left);
 276       end if;
 277
 278       loop
 279          if L_Node = null then
 280             return Tree;
 281          end if;
 282
 283          if R_Node = null then
 284             return Tree;
 285          end if;
 286
 287          if Is_Less (L_Node, R_Node) then
 288             L_Node := Tree_Operations.Next (L_Node);
 289
 290          elsif Is_Less (R_Node, L_Node) then
 291             R_Node := Tree_Operations.Next (R_Node);
 292
 293          else
 294             Insert_With_Hint
 295               (Dst_Tree => Tree,
 296                Dst_Hint => null,
 297                Src_Node => L_Node,
 298                Dst_Node => Dst_Node);
 299
 300             L_Node := Tree_Operations.Next (L_Node);
 301             R_Node := Tree_Operations.Next (R_Node);
 302          end if;
 303       end loop;
 304
 305    exception
 306       when others =>
 307          Delete_Tree (Tree.Root);
 308          raise;
 309    end Intersection;
 310
 311    ---------------
 312    -- Is_Subset --
 313    ---------------
 314
 315    function Is_Subset
 316      (Subset : Tree_Type;
 317       Of_Set : Tree_Type) return Boolean
 318    is
 319    begin
 320       if Subset'Address = Of_Set'Address then
 321          return True;
 322       end if;
 323
 324       if Subset.Length > Of_Set.Length then
 325          return False;
 326       end if;
 327
 328       declare
 329          Subset_Node : Node_Access := Subset.First;
 330          Set_Node    : Node_Access := Of_Set.First;
 331
 332       begin
 333          loop
 334             if Set_Node = null then
 335                return Subset_Node = null;
 336             end if;
 337
 338             if Subset_Node = null then
 339                return True;
 340             end if;
 341
 342             if Is_Less (Subset_Node, Set_Node) then
 343                return False;
 344             end if;
 345
 346             if Is_Less (Set_Node, Subset_Node) then
 347                Set_Node := Tree_Operations.Next (Set_Node);
 348             else
 349                Set_Node := Tree_Operations.Next (Set_Node);
 350                Subset_Node := Tree_Operations.Next (Subset_Node);
 351             end if;
 352          end loop;
 353       end;
 354    end Is_Subset;
 355
 356    -------------
 357    -- Overlap --
 358    -------------
 359
 360    function Overlap (Left, Right : Tree_Type) return Boolean is
 361       L_Node : Node_Access := Left.First;
 362       R_Node : Node_Access := Right.First;
 363
 364    begin
 365       if Left'Address = Right'Address then
 366          return Left.Length /= 0;
 367       end if;
 368
 369       loop
 370          if L_Node = null
 371            or else R_Node = null
 372          then
 373             return False;
 374          end if;
 375
 376          if Is_Less (L_Node, R_Node) then
 377             L_Node := Tree_Operations.Next (L_Node);
 378
 379          elsif Is_Less (R_Node, L_Node) then
 380             R_Node := Tree_Operations.Next (R_Node);
 381
 382          else
 383             return True;
 384          end if;
 385       end loop;
 386    end Overlap;
 387
 388    --------------------------
 389    -- Symmetric_Difference --
 390    --------------------------
 391
 392    procedure Symmetric_Difference
 393      (Target : in out Tree_Type;
 394       Source : Tree_Type)
 395    is
 396       Tgt : Node_Access := Target.First;
 397       Src : Node_Access := Source.First;
 398
 399       New_Tgt_Node : Node_Access;
 400
 401    begin
 402       if Target.Busy > 0 then
 403          raise Program_Error;
 404       end if;
 405
 406       if Target'Address = Source'Address then
 407          Clear (Target);
 408          return;
 409       end if;
 410
 411       loop
 412          if Tgt = null then
 413             while Src /= null loop
 414                Insert_With_Hint
 415                  (Dst_Tree => Target,
 416                   Dst_Hint => null,
 417                   Src_Node => Src,
 418                   Dst_Node => New_Tgt_Node);
 419
 420                Src := Tree_Operations.Next (Src);
 421             end loop;
 422
 423             return;
 424          end if;
 425
 426          if Src = null then
 427             return;
 428          end if;
 429
 430          if Is_Less (Tgt, Src) then
 431             Tgt := Tree_Operations.Next (Tgt);
 432
 433          elsif Is_Less (Src, Tgt) then
 434             Insert_With_Hint
 435               (Dst_Tree => Target,
 436                Dst_Hint => Tgt,
 437                Src_Node => Src,
 438                Dst_Node => New_Tgt_Node);
 439
 440             Src := Tree_Operations.Next (Src);
 441
 442          else
 443             declare
 444                X : Node_Access := Tgt;
 445             begin
 446                Tgt := Tree_Operations.Next (Tgt);
 447                Tree_Operations.Delete_Node_Sans_Free (Target, X);
 448                Free (X);
 449             end;
 450
 451             Src := Tree_Operations.Next (Src);
 452          end if;
 453       end loop;
 454    end Symmetric_Difference;
 455
 456    function Symmetric_Difference (Left, Right : Tree_Type) return Tree_Type is
 457       Tree : Tree_Type;
 458
 459       L_Node : Node_Access := Left.First;
 460       R_Node : Node_Access := Right.First;
 461
 462       Dst_Node : Node_Access;
 463
 464    begin
 465       if Left'Address = Right'Address then
 466          return Tree;  -- Empty set
 467       end if;
 468
 469       if Right.Length = 0 then
 470          return Copy (Left);
 471       end if;
 472
 473       if Left.Length = 0 then
 474          return Copy (Right);
 475       end if;
 476
 477       loop
 478          if L_Node = null then
 479             while R_Node /= null loop
 480                Insert_With_Hint
 481                  (Dst_Tree => Tree,
 482                   Dst_Hint => null,
 483                   Src_Node => R_Node,
 484                   Dst_Node => Dst_Node);
 485                R_Node := Tree_Operations.Next (R_Node);
 486             end loop;
 487
 488             return Tree;
 489          end if;
 490
 491          if R_Node = null then
 492             while L_Node /= null loop
 493                Insert_With_Hint
 494                  (Dst_Tree => Tree,
 495                   Dst_Hint => null,
 496                   Src_Node => L_Node,
 497                   Dst_Node => Dst_Node);
 498
 499                L_Node := Tree_Operations.Next (L_Node);
 500             end loop;
 501
 502             return Tree;
 503          end if;
 504
 505          if Is_Less (L_Node, R_Node) then
 506             Insert_With_Hint
 507               (Dst_Tree => Tree,
 508                Dst_Hint => null,
 509                Src_Node => L_Node,
 510                Dst_Node => Dst_Node);
 511
 512             L_Node := Tree_Operations.Next (L_Node);
 513
 514          elsif Is_Less (R_Node, L_Node) then
 515             Insert_With_Hint
 516               (Dst_Tree => Tree,
 517                Dst_Hint => null,
 518                Src_Node => R_Node,
 519                Dst_Node => Dst_Node);
 520
 521             R_Node := Tree_Operations.Next (R_Node);
 522
 523          else
 524             L_Node := Tree_Operations.Next (L_Node);
 525             R_Node := Tree_Operations.Next (R_Node);
 526          end if;
 527       end loop;
 528
 529    exception
 530       when others =>
 531          Delete_Tree (Tree.Root);
 532          raise;
 533    end Symmetric_Difference;
 534
 535    -----------
 536    -- Union --
 537    -----------
 538
 539    procedure Union (Target : in out Tree_Type; Source : Tree_Type)
 540    is
 541       Hint : Node_Access;
 542
 543       procedure Process (Node : Node_Access);
 544       pragma Inline (Process);
 545
 546       procedure Iterate is new Tree_Operations.Generic_Iteration (Process);
 547
 548       -------------
 549       -- Process --
 550       -------------
 551
 552       procedure Process (Node : Node_Access) is
 553       begin
 554          Insert_With_Hint
 555            (Dst_Tree => Target,
 556             Dst_Hint => Hint,
 557             Src_Node => Node,
 558             Dst_Node => Hint);
 559       end Process;
 560
 561    --  Start of processing for Union
 562
 563    begin
 564       if Target'Address = Source'Address then
 565          return;
 566       end if;
 567
 568       if Target.Busy > 0 then
 569          raise Program_Error;
 570       end if;
 571
 572       Iterate (Source);
 573    end Union;
 574
 575    function Union (Left, Right : Tree_Type) return Tree_Type is
 576    begin
 577       if Left'Address = Right'Address then
 578          return Copy (Left);
 579       end if;
 580
 581       if Left.Length = 0 then
 582          return Copy (Right);
 583       end if;
 584
 585       if Right.Length = 0 then
 586          return Copy (Left);
 587       end if;
 588
 589       declare
 590          Tree : Tree_Type := Copy (Left);
 591
 592          Hint : Node_Access;
 593
 594          procedure Process (Node : Node_Access);
 595          pragma Inline (Process);
 596
 597          procedure Iterate is
 598            new Tree_Operations.Generic_Iteration (Process);
 599
 600          -------------
 601          -- Process --
 602          -------------
 603
 604          procedure Process (Node : Node_Access) is
 605          begin
 606             Insert_With_Hint
 607               (Dst_Tree => Tree,
 608                Dst_Hint => Hint,
 609                Src_Node => Node,
 610                Dst_Node => Hint);
 611          end Process;
 612
 613       --  Start of processing for Union
 614
 615       begin
 616          Iterate (Right);
 617          return Tree;
 618
 619       exception
 620          when others =>
 621             Delete_Tree (Tree.Root);
 622             raise;
 623       end;
 624
 625    end Union;
 626
 627 end Ada.Containers.Red_Black_Trees.Generic_Set_Operations;