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-2006, Free Software Foundation, Inc.         --
  11 --                                                                          --
  12 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  20 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  21 -- Boston, MA 02110-1301, USA.                                              --
  22 --                                                                          --
  23 -- As a special exception,  if other files  instantiate  generics from this --
  24 -- unit, or you link  this unit with other files  to produce an executable, --
  25 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  26 -- covered  by the  GNU  General  Public  License.  This exception does not --
  27 -- however invalidate  any other reasons why  the executable file  might be --
  28 -- covered by the  GNU Public License.                                      --
  29 --                                                                          --
  30 -- This unit was originally developed by Matthew J Heaney.                  --
  31 ------------------------------------------------------------------------------
  32
  33 with System; use type System.Address;
  34
  35 package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is
  36
  37    -----------------------
  38    -- Local Subprograms --
  39    -----------------------
  40
  41    procedure Clear (Tree : in out Tree_Type);
  42
  43    function Copy (Source : Tree_Type) return Tree_Type;
  44
  45    -----------
  46    -- Clear --
  47    -----------
  48
  49    procedure Clear (Tree : in out Tree_Type) is
  50       pragma Assert (Tree.Busy = 0);
  51       pragma Assert (Tree.Lock = 0);
  52
  53       Root : Node_Access := Tree.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
 149    begin
 150       if Left'Address = Right'Address then
 151          return Tree;  -- Empty set
 152       end if;
 153
 154       if Left.Length = 0 then
 155          return Tree;  -- Empty set
 156       end if;
 157
 158       if Right.Length = 0 then
 159          return Copy (Left);
 160       end if;
 161
 162       loop
 163          if L_Node = null then
 164             return Tree;
 165          end if;
 166
 167          if R_Node = null then
 168             while L_Node /= null loop
 169                Insert_With_Hint
 170                  (Dst_Tree => Tree,
 171                   Dst_Hint => null,
 172                   Src_Node => L_Node,
 173                   Dst_Node => Dst_Node);
 174
 175                L_Node := Tree_Operations.Next (L_Node);
 176
 177             end loop;
 178
 179             return Tree;
 180          end if;
 181
 182          if Is_Less (L_Node, R_Node) then
 183             Insert_With_Hint
 184               (Dst_Tree => Tree,
 185                Dst_Hint => null,
 186                Src_Node => L_Node,
 187                Dst_Node => Dst_Node);
 188
 189             L_Node := Tree_Operations.Next (L_Node);
 190
 191          elsif Is_Less (R_Node, L_Node) then
 192             R_Node := Tree_Operations.Next (R_Node);
 193
 194          else
 195             L_Node := Tree_Operations.Next (L_Node);
 196             R_Node := Tree_Operations.Next (R_Node);
 197          end if;
 198       end loop;
 199
 200    exception
 201       when others =>
 202          Delete_Tree (Tree.Root);
 203          raise;
 204    end Difference;
 205
 206    ------------------
 207    -- Intersection --
 208    ------------------
 209
 210    procedure Intersection
 211      (Target : in out Tree_Type;
 212       Source : Tree_Type)
 213    is
 214       Tgt : Node_Access := Target.First;
 215       Src : Node_Access := Source.First;
 216
 217    begin
 218       if Target'Address = Source'Address then
 219          return;
 220       end if;
 221
 222       if Target.Busy > 0 then
 223          raise Program_Error with
 224            "attempt to tamper with cursors (container is busy)";
 225       end if;
 226
 227       if Source.Length = 0 then
 228          Clear (Target);
 229          return;
 230       end if;
 231
 232       while Tgt /= null
 233         and then Src /= null
 234       loop
 235          if Is_Less (Tgt, Src) then
 236             declare
 237                X : Node_Access := Tgt;
 238             begin
 239                Tgt := Tree_Operations.Next (Tgt);
 240                Tree_Operations.Delete_Node_Sans_Free (Target, X);
 241                Free (X);
 242             end;
 243
 244          elsif Is_Less (Src, Tgt) then
 245             Src := Tree_Operations.Next (Src);
 246
 247          else
 248             Tgt := Tree_Operations.Next (Tgt);
 249             Src := Tree_Operations.Next (Src);
 250          end if;
 251       end loop;
 252
 253       while Tgt /= null loop
 254          declare
 255             X : Node_Access := Tgt;
 256          begin
 257             Tgt := Tree_Operations.Next (Tgt);
 258             Tree_Operations.Delete_Node_Sans_Free (Target, X);
 259             Free (X);
 260          end;
 261       end loop;
 262    end Intersection;
 263
 264    function Intersection (Left, Right : Tree_Type) return Tree_Type is
 265       Tree : Tree_Type;
 266
 267       L_Node : Node_Access := Left.First;
 268       R_Node : Node_Access := Right.First;
 269
 270       Dst_Node : Node_Access;
 271
 272    begin
 273       if Left'Address = Right'Address then
 274          return Copy (Left);
 275       end if;
 276
 277       loop
 278          if L_Node = null then
 279             return Tree;
 280          end if;
 281
 282          if R_Node = null then
 283             return Tree;
 284          end if;
 285
 286          if Is_Less (L_Node, R_Node) then
 287             L_Node := Tree_Operations.Next (L_Node);
 288
 289          elsif Is_Less (R_Node, L_Node) then
 290             R_Node := Tree_Operations.Next (R_Node);
 291
 292          else
 293             Insert_With_Hint
 294               (Dst_Tree => Tree,
 295                Dst_Hint => null,
 296                Src_Node => L_Node,
 297                Dst_Node => Dst_Node);
 298
 299             L_Node := Tree_Operations.Next (L_Node);
 300             R_Node := Tree_Operations.Next (R_Node);
 301          end if;
 302       end loop;
 303
 304    exception
 305       when others =>
 306          Delete_Tree (Tree.Root);
 307          raise;
 308    end Intersection;
 309
 310    ---------------
 311    -- Is_Subset --
 312    ---------------
 313
 314    function Is_Subset
 315      (Subset : Tree_Type;
 316       Of_Set : Tree_Type) return Boolean
 317    is
 318    begin
 319       if Subset'Address = Of_Set'Address then
 320          return True;
 321       end if;
 322
 323       if Subset.Length > Of_Set.Length then
 324          return False;
 325       end if;
 326
 327       declare
 328          Subset_Node : Node_Access := Subset.First;
 329          Set_Node    : Node_Access := Of_Set.First;
 330
 331       begin
 332          loop
 333             if Set_Node = null then
 334                return Subset_Node = null;
 335             end if;
 336
 337             if Subset_Node = null then
 338                return True;
 339             end if;
 340
 341             if Is_Less (Subset_Node, Set_Node) then
 342                return False;
 343             end if;
 344
 345             if Is_Less (Set_Node, Subset_Node) then
 346                Set_Node := Tree_Operations.Next (Set_Node);
 347             else
 348                Set_Node := Tree_Operations.Next (Set_Node);
 349                Subset_Node := Tree_Operations.Next (Subset_Node);
 350             end if;
 351          end loop;
 352       end;
 353    end Is_Subset;
 354
 355    -------------
 356    -- Overlap --
 357    -------------
 358
 359    function Overlap (Left, Right : Tree_Type) return Boolean is
 360       L_Node : Node_Access := Left.First;
 361       R_Node : Node_Access := Right.First;
 362
 363    begin
 364       if Left'Address = Right'Address then
 365          return Left.Length /= 0;
 366       end if;
 367
 368       loop
 369          if L_Node = null
 370            or else R_Node = null
 371          then
 372             return False;
 373          end if;
 374
 375          if Is_Less (L_Node, R_Node) then
 376             L_Node := Tree_Operations.Next (L_Node);
 377
 378          elsif Is_Less (R_Node, L_Node) then
 379             R_Node := Tree_Operations.Next (R_Node);
 380
 381          else
 382             return True;
 383          end if;
 384       end loop;
 385    end Overlap;
 386
 387    --------------------------
 388    -- Symmetric_Difference --
 389    --------------------------
 390
 391    procedure Symmetric_Difference
 392      (Target : in out Tree_Type;
 393       Source : Tree_Type)
 394    is
 395       Tgt : Node_Access := Target.First;
 396       Src : Node_Access := Source.First;
 397
 398       New_Tgt_Node : Node_Access;
 399
 400    begin
 401       if Target.Busy > 0 then
 402          raise Program_Error with
 403            "attempt to tamper with cursors (container is busy)";
 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 with
 570            "attempt to tamper with cursors (container is busy)";
 571       end if;
 572
 573       Iterate (Source);
 574    end Union;
 575
 576    function Union (Left, Right : Tree_Type) return Tree_Type is
 577    begin
 578       if Left'Address = Right'Address then
 579          return Copy (Left);
 580       end if;
 581
 582       if Left.Length = 0 then
 583          return Copy (Right);
 584       end if;
 585
 586       if Right.Length = 0 then
 587          return Copy (Left);
 588       end if;
 589
 590       declare
 591          Tree : Tree_Type := Copy (Left);
 592
 593          Hint : Node_Access;
 594
 595          procedure Process (Node : Node_Access);
 596          pragma Inline (Process);
 597
 598          procedure Iterate is
 599            new Tree_Operations.Generic_Iteration (Process);
 600
 601          -------------
 602          -- Process --
 603          -------------
 604
 605          procedure Process (Node : Node_Access) is
 606          begin
 607             Insert_With_Hint
 608               (Dst_Tree => Tree,
 609                Dst_Hint => Hint,
 610                Src_Node => Node,
 611                Dst_Node => Hint);
 612          end Process;
 613
 614       --  Start of processing for Union
 615
 616       begin
 617          Iterate (Right);
 618          return Tree;
 619
 620       exception
 621          when others =>
 622             Delete_Tree (Tree.Root);
 623             raise;
 624       end;
 625
 626    end Union;
 627
 628 end Ada.Containers.Red_Black_Trees.Generic_Set_Operations;