gcc/ada/a-cohase.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT LIBRARY COMPONENTS                          --
   4 --                                                                          --
   5 --                        ADA.CONTAINERS.HASHED_SETS                        --
   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 has originally being developed by Matthew J Heaney.            --
  34 ------------------------------------------------------------------------------
  35
  36 with Ada.Unchecked_Deallocation;
  37
  38 with Ada.Containers.Hash_Tables.Generic_Operations;
  39 pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Operations);
  40
  41 with Ada.Containers.Hash_Tables.Generic_Keys;
  42 pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys);
  43
  44 with System;  use type System.Address;
  45
  46 with Ada.Containers.Prime_Numbers;
  47
  48 with Ada.Finalization;  use Ada.Finalization;
  49
  50 package body Ada.Containers.Hashed_Sets is
  51
  52    type Node_Type is
  53       limited record
  54          Element : Element_Type;
  55          Next    : Node_Access;
  56       end record;
  57
  58    function Hash_Node
  59      (Node : Node_Access) return Hash_Type;
  60    pragma Inline (Hash_Node);
  61
  62    function Hash_Node
  63      (Node : Node_Access) return Hash_Type is
  64    begin
  65       return Hash (Node.Element);
  66    end Hash_Node;
  67
  68    function Next
  69      (Node : Node_Access) return Node_Access;
  70    pragma Inline (Next);
  71
  72    function Next
  73      (Node : Node_Access) return Node_Access is
  74    begin
  75       return Node.Next;
  76    end Next;
  77
  78    procedure Set_Next
  79      (Node : Node_Access;
  80       Next : Node_Access);
  81    pragma Inline (Set_Next);
  82
  83    procedure Set_Next
  84      (Node : Node_Access;
  85       Next : Node_Access) is
  86    begin
  87       Node.Next := Next;
  88    end Set_Next;
  89
  90    function Equivalent_Keys
  91      (Key  : Element_Type;
  92       Node : Node_Access) return Boolean;
  93    pragma Inline (Equivalent_Keys);
  94
  95    function Equivalent_Keys
  96      (Key  : Element_Type;
  97       Node : Node_Access) return Boolean is
  98    begin
  99       return Equivalent_Keys (Key, Node.Element);
 100    end Equivalent_Keys;
 101
 102    function Copy_Node
 103      (Source : Node_Access) return Node_Access;
 104    pragma Inline (Copy_Node);
 105
 106    function Copy_Node
 107      (Source : Node_Access) return Node_Access is
 108
 109       Target : constant Node_Access :=
 110         new Node_Type'(Element => Source.Element,
 111                        Next    => null);
 112    begin
 113       return Target;
 114    end Copy_Node;
 115
 116
 117    procedure Free is
 118       new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
 119
 120    package HT_Ops is
 121       new Hash_Tables.Generic_Operations
 122        (HT_Types          => HT_Types,
 123         Hash_Table_Type   => Set,
 124         Null_Node         => null,
 125         Hash_Node         => Hash_Node,
 126         Next              => Next,
 127         Set_Next          => Set_Next,
 128         Copy_Node         => Copy_Node,
 129         Free              => Free);
 130
 131    package Element_Keys is
 132       new Hash_Tables.Generic_Keys
 133        (HT_Types  => HT_Types,
 134         HT_Type   => Set,
 135         Null_Node => null,
 136         Next      => Next,
 137         Set_Next  => Set_Next,
 138         Key_Type  => Element_Type,
 139         Hash      => Hash,
 140         Equivalent_Keys => Equivalent_Keys);
 141
 142
 143    procedure Adjust (Container : in out Set) renames HT_Ops.Adjust;
 144
 145    procedure Finalize (Container : in out Set) renames HT_Ops.Finalize;
 146
 147
 148    function Find_Equal_Key
 149      (R_Set  : Set;
 150       L_Node : Node_Access) return Boolean;
 151
 152    function Find_Equal_Key
 153      (R_Set  : Set;
 154       L_Node : Node_Access) return Boolean is
 155
 156       R_Index : constant Hash_Type :=
 157         Element_Keys.Index (R_Set, L_Node.Element);
 158
 159       R_Node  : Node_Access := R_Set.Buckets (R_Index);
 160
 161    begin
 162
 163       loop
 164
 165          if R_Node = null then
 166             return False;
 167          end if;
 168
 169          if L_Node.Element = R_Node.Element then
 170             --  pragma Assert (Is_Equal_Key (L_Node.Element, R_Node.Element));
 171             return True;
 172          end if;
 173
 174          R_Node := Next (R_Node);
 175
 176       end loop;
 177
 178    end Find_Equal_Key;
 179
 180    function Is_Equal is
 181       new HT_Ops.Generic_Equal (Find_Equal_Key);
 182
 183    function "=" (Left, Right : Set) return Boolean renames Is_Equal;
 184
 185
 186    function Length (Container : Set) return Count_Type is
 187    begin
 188       return Container.Length;
 189    end Length;
 190
 191
 192    function Is_Empty (Container : Set) return Boolean is
 193    begin
 194       return Container.Length = 0;
 195    end Is_Empty;
 196
 197
 198    procedure Clear (Container : in out Set) renames HT_Ops.Clear;
 199
 200
 201    function Element (Position : Cursor) return Element_Type is
 202    begin
 203       return Position.Node.Element;
 204    end Element;
 205
 206
 207    procedure Query_Element
 208      (Position : in Cursor;
 209       Process  : not null access procedure (Element : in Element_Type)) is
 210    begin
 211       Process (Position.Node.Element);
 212    end Query_Element;
 213
 214
 215 --  TODO:
 216 --     procedure Replace_Element (Container : in out Set;
 217 --                                Position  : in     Node_Access;
 218 --                                By        : in     Element_Type) is
 219
 220 --        Node : Node_Access := Position;
 221
 222 --     begin
 223
 224 --        if Equivalent_Keys (Node.Element, By) then
 225
 226 --           begin
 227 --              Node.Element := By;
 228 --           exception
 229 --              when others =>
 230 --                 HT_Ops.Delete_Node_Sans_Free (Container, Node);
 231 --                 Free (Node);
 232 --                 raise;
 233 --           end;
 234
 235 --           return;
 236
 237 --        end if;
 238
 239 --        HT_Ops.Delete_Node_Sans_Free (Container, Node);
 240
 241 --        begin
 242 --           Node.Element := By;
 243 --        exception
 244 --           when others =>
 245 --              Free (Node);
 246 --              raise;
 247 --        end;
 248
 249 --        declare
 250 --           function New_Node (Next : Node_Access) return Node_Access;
 251 --           pragma Inline (New_Node);
 252
 253 --           function New_Node (Next : Node_Access) return Node_Access is
 254 --           begin
 255 --              Node.Next := Next;
 256 --              return Node;
 257 --           end New_Node;
 258
 259 --           procedure Insert is
 260 --              new Element_Keys.Generic_Conditional_Insert (New_Node);
 261
 262 --           Result  : Node_Access;
 263 --           Success : Boolean;
 264 --        begin
 265 --           Insert
 266 --             (HT      => Container,
 267 --              Key     => Node.Element,
 268 --              Node    => Result,
 269 --              Success => Success);
 270
 271 --           if not Success then
 272 --              Free (Node);
 273 --              raise Program_Error;
 274 --           end if;
 275
 276 --           pragma Assert (Result = Node);
 277 --        end;
 278
 279 --     end Replace_Element;
 280
 281
 282 --     procedure Replace_Element (Container : in out Set;
 283 --                                Position  : in     Cursor;
 284 --                                By        : in     Element_Type) is
 285 --     begin
 286
 287 --        if Position.Container = null then
 288 --           raise Constraint_Error;
 289 --        end if;
 290
 291 --        if Position.Container /= Set_Access'(Container'Unchecked_Access) then
 292 --           raise Program_Error;
 293 --        end if;
 294
 295 --        Replace_Element (Container, Position.Node, By);
 296
 297 --     end Replace_Element;
 298
 299
 300    procedure Move (Target : in out Set;
 301                    Source : in out Set) renames HT_Ops.Move;
 302
 303
 304    procedure Insert (Container : in out Set;
 305                      New_Item  : in     Element_Type;
 306                      Position  :    out Cursor;
 307                      Inserted  :    out Boolean) is
 308
 309       function New_Node (Next : Node_Access) return Node_Access;
 310       pragma Inline (New_Node);
 311
 312       function New_Node (Next : Node_Access) return Node_Access is
 313          Node : constant Node_Access := new Node_Type'(New_Item, Next);
 314       begin
 315          return Node;
 316       end New_Node;
 317
 318       procedure Insert is
 319         new Element_Keys.Generic_Conditional_Insert (New_Node);
 320
 321    begin
 322
 323       HT_Ops.Ensure_Capacity (Container, Container.Length + 1);
 324       Insert (Container, New_Item, Position.Node, Inserted);
 325       Position.Container := Container'Unchecked_Access;
 326
 327    end Insert;
 328
 329
 330    procedure Insert (Container : in out Set;
 331                      New_Item  : in     Element_Type) is
 332
 333       Position : Cursor;
 334       Inserted : Boolean;
 335
 336    begin
 337
 338       Insert (Container, New_Item, Position, Inserted);
 339
 340       if not Inserted then
 341          raise Constraint_Error;
 342       end if;
 343
 344    end Insert;
 345
 346
 347    procedure Replace (Container : in out Set;
 348                       New_Item  : in     Element_Type) is
 349
 350       X : Node_Access := Element_Keys.Find (Container, New_Item);
 351
 352    begin
 353
 354       if X = null then
 355          raise Constraint_Error;
 356       end if;
 357
 358       X.Element := New_Item;
 359
 360    end Replace;
 361
 362
 363    procedure Include (Container : in out Set;
 364                       New_Item  : in     Element_Type) is
 365
 366       Position : Cursor;
 367       Inserted : Boolean;
 368
 369    begin
 370
 371       Insert (Container, New_Item, Position, Inserted);
 372
 373       if not Inserted then
 374          Position.Node.Element := New_Item;
 375       end if;
 376
 377    end Include;
 378
 379
 380    procedure Delete (Container : in out Set;
 381                      Item      : in     Element_Type) is
 382
 383       X : Node_Access;
 384
 385    begin
 386
 387       Element_Keys.Delete_Key_Sans_Free (Container, Item, X);
 388
 389       if X = null then
 390          raise Constraint_Error;
 391       end if;
 392
 393       Free (X);
 394
 395    end Delete;
 396
 397
 398    procedure Exclude (Container : in out Set;
 399                       Item      : in     Element_Type) is
 400
 401       X : Node_Access;
 402
 403    begin
 404
 405       Element_Keys.Delete_Key_Sans_Free (Container, Item, X);
 406       Free (X);
 407
 408    end Exclude;
 409
 410
 411    procedure Delete (Container : in out Set;
 412                      Position  : in out Cursor) is
 413    begin
 414
 415       if Position = No_Element then
 416          return;
 417       end if;
 418
 419       if Position.Container /= Set_Access'(Container'Unchecked_Access) then
 420          raise Program_Error;
 421       end if;
 422
 423       HT_Ops.Delete_Node_Sans_Free (Container, Position.Node);
 424       Free (Position.Node);
 425
 426       Position.Container := null;
 427
 428    end Delete;
 429
 430
 431
 432    procedure Union (Target : in out Set;
 433                     Source : in     Set) is
 434
 435       procedure Process (Src_Node : in Node_Access);
 436
 437       procedure Process (Src_Node : in Node_Access) is
 438
 439          function New_Node (Next : Node_Access) return Node_Access;
 440          pragma Inline (New_Node);
 441
 442          function New_Node (Next : Node_Access) return Node_Access is
 443             Node : constant Node_Access :=
 444               new Node_Type'(Src_Node.Element, Next);
 445          begin
 446             return Node;
 447          end New_Node;
 448
 449          procedure Insert is
 450             new Element_Keys.Generic_Conditional_Insert (New_Node);
 451
 452          Tgt_Node : Node_Access;
 453          Success  : Boolean;
 454
 455       begin
 456
 457          Insert (Target, Src_Node.Element, Tgt_Node, Success);
 458
 459       end Process;
 460
 461       procedure Iterate is
 462          new HT_Ops.Generic_Iteration (Process);
 463
 464    begin
 465
 466       if Target'Address = Source'Address then
 467          return;
 468       end if;
 469
 470       HT_Ops.Ensure_Capacity (Target, Target.Length + Source.Length);
 471
 472       Iterate (Source);
 473
 474    end Union;
 475
 476
 477
 478    function Union (Left, Right : Set) return Set is
 479
 480       Buckets : HT_Types.Buckets_Access;
 481       Length  : Count_Type;
 482
 483    begin
 484
 485       if Left'Address = Right'Address then
 486          return Left;
 487       end if;
 488
 489       if Right.Length = 0 then
 490          return Left;
 491       end if;
 492
 493       if Left.Length = 0 then
 494          return Right;
 495       end if;
 496
 497       declare
 498          Size : constant Hash_Type :=
 499            Prime_Numbers.To_Prime (Left.Length + Right.Length);
 500       begin
 501          Buckets := new Buckets_Type (0 .. Size - 1);
 502       end;
 503
 504       declare
 505          procedure Process (L_Node : Node_Access);
 506
 507          procedure Process (L_Node : Node_Access) is
 508             I : constant Hash_Type :=
 509               Hash (L_Node.Element) mod Buckets'Length;
 510          begin
 511             Buckets (I) := new Node_Type'(L_Node.Element, Buckets (I));
 512          end Process;
 513
 514          procedure Iterate is
 515             new HT_Ops.Generic_Iteration (Process);
 516       begin
 517          Iterate (Left);
 518       exception
 519          when others =>
 520             HT_Ops.Free_Hash_Table (Buckets);
 521             raise;
 522       end;
 523
 524       Length := Left.Length;
 525
 526       declare
 527          procedure Process (Src_Node : Node_Access);
 528
 529          procedure Process (Src_Node : Node_Access) is
 530
 531             I : constant Hash_Type :=
 532               Hash (Src_Node.Element) mod Buckets'Length;
 533
 534             Tgt_Node : Node_Access := Buckets (I);
 535
 536          begin
 537
 538             while Tgt_Node /= null loop
 539
 540                if Equivalent_Keys (Src_Node.Element, Tgt_Node.Element) then
 541                   return;
 542                end if;
 543
 544                Tgt_Node := Next (Tgt_Node);
 545
 546             end loop;
 547
 548             Buckets (I) := new Node_Type'(Src_Node.Element, Buckets (I));
 549             Length := Length + 1;
 550
 551          end Process;
 552
 553          procedure Iterate is
 554             new HT_Ops.Generic_Iteration (Process);
 555       begin
 556          Iterate (Right);
 557       exception
 558          when others =>
 559             HT_Ops.Free_Hash_Table (Buckets);
 560             raise;
 561       end;
 562
 563       return (Controlled with Buckets, Length);
 564
 565    end Union;
 566
 567
 568    function Is_In
 569      (HT  : Set;
 570       Key : Node_Access) return Boolean;
 571    pragma Inline (Is_In);
 572
 573    function Is_In
 574      (HT  : Set;
 575       Key : Node_Access) return Boolean is
 576    begin
 577       return Element_Keys.Find (HT, Key.Element) /= null;
 578    end Is_In;
 579
 580
 581    procedure Intersection (Target : in out Set;
 582                            Source : in     Set) is
 583
 584       Tgt_Node : Node_Access;
 585
 586    begin
 587
 588       if Target'Address = Source'Address then
 589          return;
 590       end if;
 591
 592       if Source.Length = 0 then
 593          Clear (Target);
 594          return;
 595       end if;
 596
 597       --  TODO: optimize this to use an explicit
 598       --  loop instead of an active iterator
 599       --  (similar to how a passive iterator is
 600       --  implemented).
 601       --
 602       --  Another possibility is to test which
 603       --  set is smaller, and iterate over the
 604       --  smaller set.
 605
 606       Tgt_Node := HT_Ops.First (Target);
 607
 608       while Tgt_Node /= null loop
 609
 610          if Is_In (Source, Tgt_Node) then
 611
 612             Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
 613
 614          else
 615
 616             declare
 617                X : Node_Access := Tgt_Node;
 618             begin
 619                Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
 620                HT_Ops.Delete_Node_Sans_Free (Target, X);
 621                Free (X);
 622             end;
 623
 624          end if;
 625
 626       end loop;
 627
 628    end Intersection;
 629
 630
 631    function Intersection (Left, Right : Set) return Set is
 632
 633       Buckets : HT_Types.Buckets_Access;
 634       Length  : Count_Type;
 635
 636    begin
 637
 638       if Left'Address = Right'Address then
 639          return Left;
 640       end if;
 641
 642       Length := Count_Type'Min (Left.Length, Right.Length);
 643
 644       if Length = 0 then
 645          return Empty_Set;
 646       end if;
 647
 648       declare
 649          Size : constant Hash_Type := Prime_Numbers.To_Prime (Length);
 650       begin
 651          Buckets := new Buckets_Type (0 .. Size - 1);
 652       end;
 653
 654       Length := 0;
 655
 656       declare
 657          procedure Process (L_Node : Node_Access);
 658
 659          procedure Process (L_Node : Node_Access) is
 660          begin
 661             if Is_In (Right, L_Node) then
 662
 663                declare
 664                   I : constant Hash_Type :=
 665                     Hash (L_Node.Element) mod Buckets'Length;
 666                begin
 667                   Buckets (I) := new Node_Type'(L_Node.Element, Buckets (I));
 668                end;
 669
 670                Length := Length + 1;
 671
 672             end if;
 673          end Process;
 674
 675          procedure Iterate is
 676             new HT_Ops.Generic_Iteration (Process);
 677       begin
 678          Iterate (Left);
 679       exception
 680          when others =>
 681             HT_Ops.Free_Hash_Table (Buckets);
 682             raise;
 683       end;
 684
 685       return (Controlled with Buckets, Length);
 686
 687    end Intersection;
 688
 689
 690    procedure Difference (Target : in out Set;
 691                          Source : in     Set) is
 692
 693
 694       Tgt_Node : Node_Access;
 695
 696    begin
 697
 698       if Target'Address = Source'Address then
 699          Clear (Target);
 700          return;
 701       end if;
 702
 703       if Source.Length = 0 then
 704          return;
 705       end if;
 706
 707       --  TODO: As I noted above, this can be
 708       --  written in terms of a loop instead as
 709       --  active-iterator style, sort of like a
 710       --  passive iterator.
 711
 712       Tgt_Node := HT_Ops.First (Target);
 713
 714       while Tgt_Node /= null loop
 715
 716          if Is_In (Source, Tgt_Node) then
 717
 718             declare
 719                X : Node_Access := Tgt_Node;
 720             begin
 721                Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
 722                HT_Ops.Delete_Node_Sans_Free (Target, X);
 723                Free (X);
 724             end;
 725
 726          else
 727
 728             Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
 729
 730          end if;
 731
 732       end loop;
 733
 734    end Difference;
 735
 736
 737
 738    function Difference (Left, Right : Set) return Set is
 739
 740       Buckets : HT_Types.Buckets_Access;
 741       Length  : Count_Type;
 742
 743    begin
 744
 745       if Left'Address = Right'Address then
 746          return Empty_Set;
 747       end if;
 748
 749       if Left.Length = 0 then
 750          return Empty_Set;
 751       end if;
 752
 753       if Right.Length = 0 then
 754          return Left;
 755       end if;
 756
 757       declare
 758          Size : constant Hash_Type := Prime_Numbers.To_Prime (Left.Length);
 759       begin
 760          Buckets := new Buckets_Type (0 .. Size - 1);
 761       end;
 762
 763       Length := 0;
 764
 765       declare
 766          procedure Process (L_Node : Node_Access);
 767
 768          procedure Process (L_Node : Node_Access) is
 769          begin
 770             if not Is_In (Right, L_Node) then
 771
 772                declare
 773                   I : constant Hash_Type :=
 774                     Hash (L_Node.Element) mod Buckets'Length;
 775                begin
 776                   Buckets (I) := new Node_Type'(L_Node.Element, Buckets (I));
 777                end;
 778
 779                Length := Length + 1;
 780
 781             end if;
 782          end Process;
 783
 784          procedure Iterate is
 785             new HT_Ops.Generic_Iteration (Process);
 786       begin
 787          Iterate (Left);
 788       exception
 789          when others =>
 790             HT_Ops.Free_Hash_Table (Buckets);
 791             raise;
 792       end;
 793
 794       return (Controlled with Buckets, Length);
 795
 796    end Difference;
 797
 798
 799
 800    procedure Symmetric_Difference (Target : in out Set;
 801                                    Source : in     Set) is
 802    begin
 803
 804       if Target'Address = Source'Address then
 805          Clear (Target);
 806          return;
 807       end if;
 808
 809       HT_Ops.Ensure_Capacity (Target, Target.Length + Source.Length);
 810
 811       if Target.Length = 0 then
 812
 813          declare
 814             procedure Process (Src_Node : Node_Access);
 815
 816             procedure Process (Src_Node : Node_Access) is
 817                E : Element_Type renames Src_Node.Element;
 818                B : Buckets_Type renames Target.Buckets.all;
 819                I : constant Hash_Type := Hash (E) mod B'Length;
 820                N : Count_Type renames Target.Length;
 821             begin
 822                B (I) := new Node_Type'(E, B (I));
 823                N := N + 1;
 824             end Process;
 825
 826             procedure Iterate is
 827                new HT_Ops.Generic_Iteration (Process);
 828          begin
 829             Iterate (Source);
 830          end;
 831
 832       else
 833
 834          declare
 835             procedure Process (Src_Node : Node_Access);
 836
 837             procedure Process (Src_Node : Node_Access) is
 838                E : Element_Type renames Src_Node.Element;
 839                B : Buckets_Type renames Target.Buckets.all;
 840                I : constant Hash_Type := Hash (E) mod B'Length;
 841                N : Count_Type renames Target.Length;
 842             begin
 843                if B (I) = null then
 844
 845                   B (I) := new Node_Type'(E, null);
 846                   N := N + 1;
 847
 848                elsif Equivalent_Keys (E, B (I).Element) then
 849
 850                   declare
 851                      X : Node_Access := B (I);
 852                   begin
 853                      B (I) := B (I).Next;
 854                      N := N - 1;
 855                      Free (X);
 856                   end;
 857
 858                else
 859
 860                   declare
 861                      Prev : Node_Access := B (I);
 862                      Curr : Node_Access := Prev.Next;
 863                   begin
 864                      while Curr /= null loop
 865                         if Equivalent_Keys (E, Curr.Element) then
 866                            Prev.Next := Curr.Next;
 867                            N := N - 1;
 868                            Free (Curr);
 869                            return;
 870                         end if;
 871
 872                         Prev := Curr;
 873                         Curr := Prev.Next;
 874                      end loop;
 875
 876                      B (I) := new Node_Type'(E, B (I));
 877                      N := N + 1;
 878                   end;
 879
 880                end if;
 881             end Process;
 882
 883             procedure Iterate is
 884                new HT_Ops.Generic_Iteration (Process);
 885          begin
 886             Iterate (Source);
 887          end;
 888
 889       end if;
 890
 891    end Symmetric_Difference;
 892
 893
 894    function Symmetric_Difference (Left, Right : Set) return Set is
 895
 896       Buckets : HT_Types.Buckets_Access;
 897       Length  : Count_Type;
 898
 899    begin
 900
 901       if Left'Address = Right'Address then
 902          return Empty_Set;
 903       end if;
 904
 905       if Right.Length = 0 then
 906          return Left;
 907       end if;
 908
 909       if Left.Length = 0 then
 910          return Right;
 911       end if;
 912
 913       declare
 914          Size : constant Hash_Type :=
 915            Prime_Numbers.To_Prime (Left.Length + Right.Length);
 916       begin
 917          Buckets := new Buckets_Type (0 .. Size - 1);
 918       end;
 919
 920       Length := 0;
 921
 922       declare
 923          procedure Process (L_Node : Node_Access);
 924
 925          procedure Process (L_Node : Node_Access) is
 926          begin
 927             if not Is_In (Right, L_Node) then
 928                declare
 929                   E : Element_Type renames L_Node.Element;
 930                   I : constant Hash_Type := Hash (E) mod Buckets'Length;
 931                begin
 932                   Buckets (I) := new Node_Type'(E, Buckets (I));
 933                   Length := Length + 1;
 934                end;
 935             end if;
 936          end Process;
 937
 938          procedure Iterate is
 939             new HT_Ops.Generic_Iteration (Process);
 940       begin
 941          Iterate (Left);
 942       exception
 943          when others =>
 944             HT_Ops.Free_Hash_Table (Buckets);
 945             raise;
 946       end;
 947
 948       declare
 949          procedure Process (R_Node : Node_Access);
 950
 951          procedure Process (R_Node : Node_Access) is
 952          begin
 953             if not Is_In (Left, R_Node) then
 954                declare
 955                   E : Element_Type renames R_Node.Element;
 956                   I : constant Hash_Type := Hash (E) mod Buckets'Length;
 957                begin
 958                   Buckets (I) := new Node_Type'(E, Buckets (I));
 959                   Length := Length + 1;
 960                end;
 961             end if;
 962          end Process;
 963
 964          procedure Iterate is
 965             new HT_Ops.Generic_Iteration (Process);
 966       begin
 967          Iterate (Right);
 968       exception
 969          when others =>
 970             HT_Ops.Free_Hash_Table (Buckets);
 971             raise;
 972       end;
 973
 974       return (Controlled with Buckets, Length);
 975
 976    end Symmetric_Difference;
 977
 978
 979    function Is_Subset (Subset : Set;
 980                        Of_Set : Set) return Boolean is
 981
 982       Subset_Node : Node_Access;
 983
 984    begin
 985
 986       if Subset'Address = Of_Set'Address then
 987          return True;
 988       end if;
 989
 990       if Subset.Length > Of_Set.Length then
 991          return False;
 992       end if;
 993
 994       --  TODO: rewrite this to loop in the
 995       --  style of a passive iterator.
 996
 997       Subset_Node := HT_Ops.First (Subset);
 998
 999       while Subset_Node /= null loop
1000          if not Is_In (Of_Set, Subset_Node) then
1001             return False;
1002          end if;
1003
1004          Subset_Node := HT_Ops.Next (Subset, Subset_Node);
1005       end loop;
1006
1007       return True;
1008
1009    end Is_Subset;
1010
1011
1012    function Overlap (Left, Right : Set) return Boolean is
1013
1014       Left_Node : Node_Access;
1015
1016    begin
1017
1018       if Right.Length = 0 then
1019          return False;
1020       end if;
1021
1022       if Left'Address = Right'Address then
1023          return True;
1024       end if;
1025
1026       Left_Node := HT_Ops.First (Left);
1027
1028       while Left_Node /= null loop
1029          if Is_In (Right, Left_Node) then
1030             return True;
1031          end if;
1032
1033          Left_Node := HT_Ops.Next (Left, Left_Node);
1034       end loop;
1035
1036       return False;
1037
1038    end Overlap;
1039
1040
1041    function Find (Container : Set;
1042                   Item      : Element_Type) return Cursor is
1043
1044       Node : constant Node_Access := Element_Keys.Find (Container, Item);
1045
1046    begin
1047
1048       if Node = null then
1049          return No_Element;
1050       end if;
1051
1052       return Cursor'(Container'Unchecked_Access, Node);
1053
1054    end Find;
1055
1056
1057    function Contains (Container : Set;
1058                       Item      : Element_Type) return Boolean is
1059    begin
1060       return Find (Container, Item) /= No_Element;
1061    end Contains;
1062
1063
1064
1065    function First (Container : Set) return Cursor is
1066       Node : constant Node_Access := HT_Ops.First (Container);
1067    begin
1068       if Node = null then
1069          return No_Element;
1070       end if;
1071
1072       return Cursor'(Container'Unchecked_Access, Node);
1073    end First;
1074
1075
1076 --     function First_Element (Container : Set) return Element_Type is
1077 --        Node : constant Node_Access := HT_Ops.First (Container);
1078 --     begin
1079 --        return Node.Element;
1080 --     end First_Element;
1081
1082
1083    function Next (Position : Cursor) return Cursor is
1084    begin
1085       if Position.Container = null
1086         or else Position.Node = null
1087       then
1088          return No_Element;
1089       end if;
1090
1091       declare
1092          S : Set renames Position.Container.all;
1093          Node : constant Node_Access := HT_Ops.Next (S, Position.Node);
1094       begin
1095          if Node = null then
1096             return No_Element;
1097          end if;
1098
1099          return Cursor'(Position.Container, Node);
1100       end;
1101    end Next;
1102
1103
1104    procedure Next (Position : in out Cursor) is
1105    begin
1106       Position := Next (Position);
1107    end Next;
1108
1109
1110    function Has_Element (Position : Cursor) return Boolean is
1111    begin
1112       if Position.Container = null then
1113          return False;
1114       end if;
1115
1116       if Position.Node = null then
1117          return False;
1118       end if;
1119
1120       return True;
1121    end Has_Element;
1122
1123
1124    function Equivalent_Keys (Left, Right : Cursor)
1125      return Boolean is
1126    begin
1127       return Equivalent_Keys (Left.Node.Element, Right.Node.Element);
1128    end Equivalent_Keys;
1129
1130
1131    function Equivalent_Keys (Left  : Cursor;
1132                              Right : Element_Type)
1133     return Boolean is
1134    begin
1135       return Equivalent_Keys (Left.Node.Element, Right);
1136    end Equivalent_Keys;
1137
1138
1139    function Equivalent_Keys (Left  : Element_Type;
1140                              Right : Cursor)
1141     return Boolean is
1142    begin
1143       return Equivalent_Keys (Left, Right.Node.Element);
1144    end Equivalent_Keys;
1145
1146
1147    procedure Iterate
1148      (Container : in Set;
1149       Process   : not null access procedure (Position : in Cursor)) is
1150
1151       procedure Process_Node (Node : in Node_Access);
1152       pragma Inline (Process_Node);
1153
1154       procedure Process_Node (Node : in Node_Access) is
1155       begin
1156          Process (Cursor'(Container'Unchecked_Access, Node));
1157       end Process_Node;
1158
1159       procedure Iterate is
1160          new HT_Ops.Generic_Iteration (Process_Node);
1161    begin
1162       Iterate (Container);
1163    end Iterate;
1164
1165
1166    function Capacity (Container : Set) return Count_Type
1167      renames HT_Ops.Capacity;
1168
1169    procedure Reserve_Capacity
1170      (Container : in out Set;
1171       Capacity  : in     Count_Type)
1172      renames HT_Ops.Ensure_Capacity;
1173
1174
1175    procedure Write_Node
1176      (Stream : access Root_Stream_Type'Class;
1177       Node   : in     Node_Access);
1178    pragma Inline (Write_Node);
1179
1180    procedure Write_Node
1181      (Stream : access Root_Stream_Type'Class;
1182       Node   : in     Node_Access) is
1183    begin
1184       Element_Type'Write (Stream, Node.Element);
1185    end Write_Node;
1186
1187    procedure Write_Nodes is
1188       new HT_Ops.Generic_Write (Write_Node);
1189
1190    procedure Write
1191      (Stream    : access Root_Stream_Type'Class;
1192       Container : in     Set) renames Write_Nodes;
1193
1194
1195    function Read_Node (Stream : access Root_Stream_Type'Class)
1196      return Node_Access;
1197    pragma Inline (Read_Node);
1198
1199    function Read_Node (Stream : access Root_Stream_Type'Class)
1200      return Node_Access is
1201
1202       Node : Node_Access := new Node_Type;
1203    begin
1204       Element_Type'Read (Stream, Node.Element);
1205       return Node;
1206    exception
1207       when others =>
1208          Free (Node);
1209          raise;
1210    end Read_Node;
1211
1212    procedure Read_Nodes is
1213       new HT_Ops.Generic_Read (Read_Node);
1214
1215    procedure Read
1216      (Stream    : access Root_Stream_Type'Class;
1217       Container :    out Set) renames Read_Nodes;
1218
1219
1220    package body Generic_Keys is
1221
1222       function Equivalent_Keys (Left  : Cursor;
1223                                 Right : Key_Type)
1224         return Boolean is
1225       begin
1226          return Equivalent_Keys (Right, Left.Node.Element);
1227       end Equivalent_Keys;
1228
1229       function Equivalent_Keys (Left  : Key_Type;
1230                                 Right : Cursor)
1231         return Boolean is
1232       begin
1233          return Equivalent_Keys (Left, Right.Node.Element);
1234       end Equivalent_Keys;
1235
1236       function Equivalent_Keys
1237         (Key  : Key_Type;
1238          Node : Node_Access) return Boolean;
1239       pragma Inline (Equivalent_Keys);
1240
1241       function Equivalent_Keys
1242         (Key  : Key_Type;
1243          Node : Node_Access) return Boolean is
1244       begin
1245          return Equivalent_Keys (Key, Node.Element);
1246       end Equivalent_Keys;
1247
1248       package Key_Keys is
1249          new Hash_Tables.Generic_Keys
1250           (HT_Types  => HT_Types,
1251            HT_Type   => Set,
1252            Null_Node => null,
1253            Next      => Next,
1254            Set_Next  => Set_Next,
1255            Key_Type  => Key_Type,
1256            Hash      => Hash,
1257            Equivalent_Keys => Equivalent_Keys);
1258
1259
1260       function Find (Container : Set;
1261                      Key       : Key_Type)
1262          return Cursor is
1263
1264          Node : constant Node_Access :=
1265            Key_Keys.Find (Container, Key);
1266
1267       begin
1268
1269          if Node = null then
1270             return No_Element;
1271          end if;
1272
1273          return Cursor'(Container'Unchecked_Access, Node);
1274
1275       end Find;
1276
1277
1278       function Contains (Container : Set;
1279                          Key       : Key_Type) return Boolean is
1280       begin
1281          return Find (Container, Key) /= No_Element;
1282       end Contains;
1283
1284
1285       function Element (Container : Set;
1286                         Key       : Key_Type)
1287         return Element_Type is
1288
1289          Node : constant Node_Access := Key_Keys.Find (Container, Key);
1290       begin
1291          return Node.Element;
1292       end Element;
1293
1294
1295       function Key (Position : Cursor) return Key_Type is
1296       begin
1297          return Key (Position.Node.Element);
1298       end Key;
1299
1300
1301 --  TODO:
1302 --        procedure Replace (Container : in out Set;
1303 --                           Key       : in     Key_Type;
1304 --                           New_Item  : in     Element_Type) is
1305
1306 --           Node : constant Node_Access :=
1307 --             Key_Keys.Find (Container, Key);
1308
1309 --        begin
1310
1311 --           if Node = null then
1312 --              raise Constraint_Error;
1313 --           end if;
1314
1315 --           Replace_Element (Container, Node, New_Item);
1316
1317 --        end Replace;
1318
1319
1320       procedure Delete (Container : in out Set;
1321                         Key       : in     Key_Type) is
1322
1323          X : Node_Access;
1324
1325       begin
1326
1327          Key_Keys.Delete_Key_Sans_Free (Container, Key, X);
1328
1329          if X = null then
1330             raise Constraint_Error;
1331          end if;
1332
1333          Free (X);
1334
1335       end Delete;
1336
1337
1338       procedure Exclude (Container : in out Set;
1339                          Key       : in     Key_Type) is
1340
1341          X : Node_Access;
1342
1343       begin
1344
1345          Key_Keys.Delete_Key_Sans_Free (Container, Key, X);
1346          Free (X);
1347
1348       end Exclude;
1349
1350
1351       procedure Checked_Update_Element
1352         (Container : in out Set;
1353          Position  : in     Cursor;
1354          Process   : not null access
1355            procedure (Element : in out Element_Type)) is
1356
1357       begin
1358
1359          if Position.Container = null then
1360             raise Constraint_Error;
1361          end if;
1362
1363          if Position.Container /= Set_Access'(Container'Unchecked_Access) then
1364             raise Program_Error;
1365          end if;
1366
1367          declare
1368             Old_Key : Key_Type renames Key (Position.Node.Element);
1369          begin
1370             Process (Position.Node.Element);
1371
1372             if Equivalent_Keys (Old_Key, Position.Node.Element) then
1373                return;
1374             end if;
1375          end;
1376
1377          declare
1378             function New_Node (Next : Node_Access) return Node_Access;
1379             pragma Inline (New_Node);
1380
1381             function New_Node (Next : Node_Access) return Node_Access is
1382             begin
1383                Position.Node.Next := Next;
1384                return Position.Node;
1385             end New_Node;
1386
1387             procedure Insert is
1388                new Key_Keys.Generic_Conditional_Insert (New_Node);
1389
1390             Result  : Node_Access;
1391             Success : Boolean;
1392          begin
1393             HT_Ops.Delete_Node_Sans_Free (Container, Position.Node);
1394
1395             Insert
1396               (HT      => Container,
1397                Key     => Key (Position.Node.Element),
1398                Node    => Result,
1399                Success => Success);
1400
1401             if not Success then
1402                declare
1403                   X : Node_Access := Position.Node;
1404                begin
1405                   Free (X);
1406                end;
1407
1408                raise Program_Error;
1409             end if;
1410
1411             pragma Assert (Result = Position.Node);
1412          end;
1413
1414       end Checked_Update_Element;
1415
1416    end Generic_Keys;
1417
1418 end Ada.Containers.Hashed_Sets;