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