gcc/ada/a-cohase.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT LIBRARY COMPONENTS                          --
   4 --                                                                          --
   5 --           A D A . C O N T A I N E R S . H A S H E D _ S E T S            --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 2004-2005 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,  51  Franklin  Street,  Fifth  Floor, --
  24 -- Boston, MA 02110-1301, 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 Ada.Containers.Prime_Numbers;
  45
  46 with System; use type System.Address;
  47
  48 package body Ada.Containers.Hashed_Sets is
  49
  50    -----------------------
  51    -- Local Subprograms --
  52    -----------------------
  53
  54    function Copy_Node (Source : Node_Access) return Node_Access;
  55    pragma Inline (Copy_Node);
  56
  57    function Equivalent_Keys
  58      (Key  : Element_Type;
  59       Node : Node_Access) return Boolean;
  60    pragma Inline (Equivalent_Keys);
  61
  62    function Find_Equal_Key
  63      (R_HT   : Hash_Table_Type;
  64       L_Node : Node_Access) return Boolean;
  65
  66    function Find_Equivalent_Key
  67      (R_HT   : Hash_Table_Type;
  68       L_Node : Node_Access) return Boolean;
  69
  70    function Hash_Node (Node : Node_Access) return Hash_Type;
  71    pragma Inline (Hash_Node);
  72
  73    function Is_In
  74      (HT  : Hash_Table_Type;
  75       Key : Node_Access) return Boolean;
  76    pragma Inline (Is_In);
  77
  78    function Next (Node : Node_Access) return Node_Access;
  79    pragma Inline (Next);
  80
  81    function Read_Node (Stream : access Root_Stream_Type'Class)
  82      return Node_Access;
  83    pragma Inline (Read_Node);
  84
  85    procedure Replace_Element
  86      (HT      : in out Hash_Table_Type;
  87       Node    : Node_Access;
  88       Element : Element_Type);
  89
  90    procedure Set_Next (Node : Node_Access; Next : Node_Access);
  91    pragma Inline (Set_Next);
  92
  93    procedure Write_Node
  94      (Stream : access Root_Stream_Type'Class;
  95       Node   : Node_Access);
  96    pragma Inline (Write_Node);
  97
  98    --------------------------
  99    -- Local Instantiations --
 100    --------------------------
 101
 102    procedure Free is
 103       new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
 104
 105    package HT_Ops is
 106       new Hash_Tables.Generic_Operations
 107        (HT_Types  => HT_Types,
 108         Hash_Node => Hash_Node,
 109         Next      => Next,
 110         Set_Next  => Set_Next,
 111         Copy_Node => Copy_Node,
 112         Free      => Free);
 113
 114    package Element_Keys is
 115       new Hash_Tables.Generic_Keys
 116        (HT_Types  => HT_Types,
 117         Next      => Next,
 118         Set_Next  => Set_Next,
 119         Key_Type  => Element_Type,
 120         Hash      => Hash,
 121         Equivalent_Keys => Equivalent_Keys);
 122
 123    function Is_Equal is
 124       new HT_Ops.Generic_Equal (Find_Equal_Key);
 125
 126    function Is_Equivalent is
 127       new HT_Ops.Generic_Equal (Find_Equivalent_Key);
 128
 129    procedure Read_Nodes is
 130       new HT_Ops.Generic_Read (Read_Node);
 131
 132    procedure Write_Nodes is
 133       new HT_Ops.Generic_Write (Write_Node);
 134
 135    ---------
 136    -- "=" --
 137    ---------
 138
 139    function "=" (Left, Right : Set) return Boolean is
 140    begin
 141       return Is_Equal (Left.HT, Right.HT);
 142    end "=";
 143
 144    ------------
 145    -- Adjust --
 146    ------------
 147
 148    procedure Adjust (Container : in out Set) is
 149    begin
 150       HT_Ops.Adjust (Container.HT);
 151    end Adjust;
 152
 153    --------------
 154    -- Capacity --
 155    --------------
 156
 157    function Capacity (Container : Set) return Count_Type is
 158    begin
 159       return HT_Ops.Capacity (Container.HT);
 160    end Capacity;
 161
 162    -----------
 163    -- Clear --
 164    -----------
 165
 166    procedure Clear (Container : in out Set) is
 167    begin
 168       HT_Ops.Clear (Container.HT);
 169    end Clear;
 170
 171    --------------
 172    -- Contains --
 173    --------------
 174
 175    function Contains (Container : Set; Item : Element_Type) return Boolean is
 176    begin
 177       return Find (Container, Item) /= No_Element;
 178    end Contains;
 179
 180    ---------------
 181    -- Copy_Node --
 182    ---------------
 183
 184    function Copy_Node (Source : Node_Access) return Node_Access is
 185    begin
 186       return new Node_Type'(Element => Source.Element, Next => null);
 187    end Copy_Node;
 188
 189    ------------
 190    -- Delete --
 191    ------------
 192
 193    procedure Delete
 194      (Container : in out Set;
 195       Item      : Element_Type)
 196    is
 197       X : Node_Access;
 198
 199    begin
 200       Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X);
 201
 202       if X = null then
 203          raise Constraint_Error;
 204       end if;
 205
 206       Free (X);
 207    end Delete;
 208
 209    procedure Delete
 210      (Container : in out Set;
 211       Position  : in out Cursor)
 212    is
 213    begin
 214       if Position.Node = null then
 215          raise Constraint_Error;
 216       end if;
 217
 218       if Position.Container /= Set_Access'(Container'Unchecked_Access) then
 219          raise Program_Error;
 220       end if;
 221
 222       if Container.HT.Busy > 0 then
 223          raise Program_Error;
 224       end if;
 225
 226       HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node);
 227
 228       Free (Position.Node);
 229
 230       Position.Container := null;
 231    end Delete;
 232
 233    ----------------
 234    -- Difference --
 235    ----------------
 236
 237    procedure Difference
 238      (Target : in out Set;
 239       Source : Set)
 240    is
 241       Tgt_Node : Node_Access;
 242
 243    begin
 244       if Target'Address = Source'Address then
 245          Clear (Target);
 246          return;
 247       end if;
 248
 249       if Source.Length = 0 then
 250          return;
 251       end if;
 252
 253       if Target.HT.Busy > 0 then
 254          raise Program_Error;
 255       end if;
 256
 257       --  TODO: This can be written in terms of a loop instead as
 258       --  active-iterator style, sort of like a passive iterator.
 259
 260       Tgt_Node := HT_Ops.First (Target.HT);
 261       while Tgt_Node /= null loop
 262          if Is_In (Source.HT, Tgt_Node) then
 263             declare
 264                X : Node_Access := Tgt_Node;
 265             begin
 266                Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
 267                HT_Ops.Delete_Node_Sans_Free (Target.HT, X);
 268                Free (X);
 269             end;
 270
 271          else
 272             Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
 273          end if;
 274       end loop;
 275    end Difference;
 276
 277    function Difference (Left, Right : Set) return Set is
 278       Buckets : HT_Types.Buckets_Access;
 279       Length  : Count_Type;
 280
 281    begin
 282       if Left'Address = Right'Address then
 283          return Empty_Set;
 284       end if;
 285
 286       if Left.Length = 0 then
 287          return Empty_Set;
 288       end if;
 289
 290       if Right.Length = 0 then
 291          return Left;
 292       end if;
 293
 294       declare
 295          Size : constant Hash_Type := Prime_Numbers.To_Prime (Left.Length);
 296       begin
 297          Buckets := new Buckets_Type (0 .. Size - 1);
 298       end;
 299
 300       Length := 0;
 301
 302       Iterate_Left : declare
 303          procedure Process (L_Node : Node_Access);
 304
 305          procedure Iterate is
 306             new HT_Ops.Generic_Iteration (Process);
 307
 308          -------------
 309          -- Process --
 310          -------------
 311
 312          procedure Process (L_Node : Node_Access) is
 313          begin
 314             if not Is_In (Right.HT, L_Node) then
 315                declare
 316                   J : constant Hash_Type :=
 317                         Hash (L_Node.Element) mod Buckets'Length;
 318
 319                   Bucket : Node_Access renames Buckets (J);
 320
 321                begin
 322                   Bucket := new Node_Type'(L_Node.Element, Bucket);
 323                end;
 324
 325                Length := Length + 1;
 326             end if;
 327          end Process;
 328
 329       --  Start of processing for Iterate_Left
 330
 331       begin
 332          Iterate (Left.HT);
 333       exception
 334          when others =>
 335             HT_Ops.Free_Hash_Table (Buckets);
 336             raise;
 337       end Iterate_Left;
 338
 339       return (Controlled with HT => (Buckets, Length, 0, 0));
 340    end Difference;
 341
 342    -------------
 343    -- Element --
 344    -------------
 345
 346    function Element (Position : Cursor) return Element_Type is
 347    begin
 348       return Position.Node.Element;
 349    end Element;
 350
 351    ---------------------
 352    -- Equivalent_Sets --
 353    ---------------------
 354
 355    function Equivalent_Sets (Left, Right : Set) return Boolean is
 356    begin
 357       return Is_Equivalent (Left.HT, Right.HT);
 358    end Equivalent_Sets;
 359
 360    -------------------------
 361    -- Equivalent_Elements --
 362    -------------------------
 363
 364    function Equivalent_Elements (Left, Right : Cursor)
 365      return Boolean is
 366    begin
 367       return Equivalent_Elements (Left.Node.Element, Right.Node.Element);
 368    end Equivalent_Elements;
 369
 370    function Equivalent_Elements (Left : Cursor; Right : Element_Type)
 371      return Boolean is
 372    begin
 373       return Equivalent_Elements (Left.Node.Element, Right);
 374    end Equivalent_Elements;
 375
 376    function Equivalent_Elements (Left : Element_Type; Right : Cursor)
 377      return Boolean is
 378    begin
 379       return Equivalent_Elements (Left, Right.Node.Element);
 380    end Equivalent_Elements;
 381
 382    ---------------------
 383    -- Equivalent_Keys --
 384    ---------------------
 385
 386    function Equivalent_Keys (Key : Element_Type; Node : Node_Access)
 387      return Boolean is
 388    begin
 389       return Equivalent_Elements (Key, Node.Element);
 390    end Equivalent_Keys;
 391
 392    -------------
 393    -- Exclude --
 394    -------------
 395
 396    procedure Exclude
 397      (Container : in out Set;
 398       Item      : Element_Type)
 399    is
 400       X : Node_Access;
 401    begin
 402       Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X);
 403       Free (X);
 404    end Exclude;
 405
 406    --------------
 407    -- Finalize --
 408    --------------
 409
 410    procedure Finalize (Container : in out Set) is
 411    begin
 412       HT_Ops.Finalize (Container.HT);
 413    end Finalize;
 414
 415    ----------
 416    -- Find --
 417    ----------
 418
 419    function Find
 420      (Container : Set;
 421       Item      : Element_Type) return Cursor
 422    is
 423       Node : constant Node_Access := Element_Keys.Find (Container.HT, Item);
 424
 425    begin
 426       if Node = null then
 427          return No_Element;
 428       end if;
 429
 430       return Cursor'(Container'Unrestricted_Access, Node);
 431    end Find;
 432
 433    --------------------
 434    -- Find_Equal_Key --
 435    --------------------
 436
 437    function Find_Equal_Key
 438      (R_HT   : Hash_Table_Type;
 439       L_Node : Node_Access) return Boolean
 440    is
 441       R_Index : constant Hash_Type :=
 442                   Element_Keys.Index (R_HT, L_Node.Element);
 443
 444       R_Node  : Node_Access := R_HT.Buckets (R_Index);
 445
 446    begin
 447       loop
 448          if R_Node = null then
 449             return False;
 450          end if;
 451
 452          if L_Node.Element = R_Node.Element then
 453             return True;
 454          end if;
 455
 456          R_Node := Next (R_Node);
 457       end loop;
 458    end Find_Equal_Key;
 459
 460    -------------------------
 461    -- Find_Equivalent_Key --
 462    -------------------------
 463
 464    function Find_Equivalent_Key
 465      (R_HT   : Hash_Table_Type;
 466       L_Node : Node_Access) return Boolean
 467    is
 468       R_Index : constant Hash_Type :=
 469                   Element_Keys.Index (R_HT, L_Node.Element);
 470
 471       R_Node  : Node_Access := R_HT.Buckets (R_Index);
 472
 473    begin
 474       loop
 475          if R_Node = null then
 476             return False;
 477          end if;
 478
 479          if Equivalent_Elements (L_Node.Element, R_Node.Element) then
 480             return True;
 481          end if;
 482
 483          R_Node := Next (R_Node);
 484       end loop;
 485    end Find_Equivalent_Key;
 486
 487    -----------
 488    -- First --
 489    -----------
 490
 491    function First (Container : Set) return Cursor is
 492       Node : constant Node_Access := HT_Ops.First (Container.HT);
 493
 494    begin
 495       if Node = null then
 496          return No_Element;
 497       end if;
 498
 499       return Cursor'(Container'Unrestricted_Access, Node);
 500    end First;
 501
 502    -----------------
 503    -- Has_Element --
 504    -----------------
 505
 506    function Has_Element (Position : Cursor) return Boolean is
 507    begin
 508       if Position.Node = null then
 509          pragma Assert (Position.Container = null);
 510          return False;
 511       end if;
 512
 513       return True;
 514    end Has_Element;
 515
 516    ---------------
 517    -- Hash_Node --
 518    ---------------
 519
 520    function Hash_Node (Node : Node_Access) return Hash_Type is
 521    begin
 522       return Hash (Node.Element);
 523    end Hash_Node;
 524
 525    -------------
 526    -- Include --
 527    -------------
 528
 529    procedure Include
 530      (Container : in out Set;
 531       New_Item  : Element_Type)
 532    is
 533       Position : Cursor;
 534       Inserted : Boolean;
 535
 536    begin
 537       Insert (Container, New_Item, Position, Inserted);
 538
 539       if not Inserted then
 540          if Container.HT.Lock > 0 then
 541             raise Program_Error;
 542          end if;
 543
 544          Position.Node.Element := New_Item;
 545       end if;
 546    end Include;
 547
 548    ------------
 549    -- Insert --
 550    ------------
 551
 552    procedure Insert
 553      (Container : in out Set;
 554       New_Item  : Element_Type;
 555       Position  : out Cursor;
 556       Inserted  : out Boolean)
 557    is
 558       function New_Node (Next : Node_Access) return Node_Access;
 559       pragma Inline (New_Node);
 560
 561       procedure Local_Insert is
 562         new Element_Keys.Generic_Conditional_Insert (New_Node);
 563
 564       --------------
 565       -- New_Node --
 566       --------------
 567
 568       function New_Node (Next : Node_Access) return Node_Access is
 569          Node : constant Node_Access := new Node_Type'(New_Item, Next);
 570       begin
 571          return Node;
 572       end New_Node;
 573
 574       HT : Hash_Table_Type renames Container.HT;
 575
 576    --  Start of processing for Insert
 577
 578    begin
 579       if HT.Length >= HT_Ops.Capacity (HT) then
 580
 581          --  TODO:
 582          --  Perform the insertion first, and then reserve
 583          --  capacity, but only if the insertion succeeds and
 584          --  the (new) length is greater then current capacity.
 585          --  END TODO.
 586
 587          HT_Ops.Reserve_Capacity (HT, HT.Length + 1);
 588       end if;
 589
 590       Local_Insert (HT, New_Item, Position.Node, Inserted);
 591       Position.Container := Container'Unchecked_Access;
 592    end Insert;
 593
 594    procedure Insert
 595      (Container : in out Set;
 596       New_Item  : Element_Type)
 597    is
 598       Position : Cursor;
 599       Inserted : Boolean;
 600
 601    begin
 602       Insert (Container, New_Item, Position, Inserted);
 603
 604       if not Inserted then
 605          raise Constraint_Error;
 606       end if;
 607    end Insert;
 608
 609    ------------------
 610    -- Intersection --
 611    ------------------
 612
 613    procedure Intersection
 614      (Target : in out Set;
 615       Source : Set)
 616    is
 617       Tgt_Node : Node_Access;
 618
 619    begin
 620       if Target'Address = Source'Address then
 621          return;
 622       end if;
 623
 624       if Source.Length = 0 then
 625          Clear (Target);
 626          return;
 627       end if;
 628
 629       if Target.HT.Busy > 0 then
 630          raise Program_Error;
 631       end if;
 632
 633       --  TODO: optimize this to use an explicit
 634       --  loop instead of an active iterator
 635       --  (similar to how a passive iterator is
 636       --  implemented).
 637       --
 638       --  Another possibility is to test which
 639       --  set is smaller, and iterate over the
 640       --  smaller set.
 641
 642       Tgt_Node := HT_Ops.First (Target.HT);
 643       while Tgt_Node /= null loop
 644          if Is_In (Source.HT, Tgt_Node) then
 645             Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
 646
 647          else
 648             declare
 649                X : Node_Access := Tgt_Node;
 650             begin
 651                Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
 652                HT_Ops.Delete_Node_Sans_Free (Target.HT, X);
 653                Free (X);
 654             end;
 655          end if;
 656       end loop;
 657    end Intersection;
 658
 659    function Intersection (Left, Right : Set) return Set is
 660       Buckets : HT_Types.Buckets_Access;
 661       Length  : Count_Type;
 662
 663    begin
 664       if Left'Address = Right'Address then
 665          return Left;
 666       end if;
 667
 668       Length := Count_Type'Min (Left.Length, Right.Length);
 669
 670       if Length = 0 then
 671          return Empty_Set;
 672       end if;
 673
 674       declare
 675          Size : constant Hash_Type := Prime_Numbers.To_Prime (Length);
 676       begin
 677          Buckets := new Buckets_Type (0 .. Size - 1);
 678       end;
 679
 680       Length := 0;
 681
 682       Iterate_Left : declare
 683          procedure Process (L_Node : Node_Access);
 684
 685          procedure Iterate is
 686             new HT_Ops.Generic_Iteration (Process);
 687
 688          -------------
 689          -- Process --
 690          -------------
 691
 692          procedure Process (L_Node : Node_Access) is
 693          begin
 694             if Is_In (Right.HT, L_Node) then
 695                declare
 696                   J : constant Hash_Type :=
 697                         Hash (L_Node.Element) mod Buckets'Length;
 698
 699                   Bucket : Node_Access renames Buckets (J);
 700
 701                begin
 702                   Bucket := new Node_Type'(L_Node.Element, Bucket);
 703                end;
 704
 705                Length := Length + 1;
 706             end if;
 707          end Process;
 708
 709       --  Start of processing for Iterate_Left
 710
 711       begin
 712          Iterate (Left.HT);
 713       exception
 714          when others =>
 715             HT_Ops.Free_Hash_Table (Buckets);
 716             raise;
 717       end Iterate_Left;
 718
 719       return (Controlled with HT => (Buckets, Length, 0, 0));
 720    end Intersection;
 721
 722    --------------
 723    -- Is_Empty --
 724    --------------
 725
 726    function Is_Empty (Container : Set) return Boolean is
 727    begin
 728       return Container.Length = 0;
 729    end Is_Empty;
 730
 731    -----------
 732    -- Is_In --
 733    -----------
 734
 735    function Is_In (HT : Hash_Table_Type; Key : Node_Access) return Boolean is
 736    begin
 737       return Element_Keys.Find (HT, Key.Element) /= null;
 738    end Is_In;
 739
 740    ---------------
 741    -- Is_Subset --
 742    ---------------
 743
 744    function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is
 745       Subset_Node : Node_Access;
 746
 747    begin
 748       if Subset'Address = Of_Set'Address then
 749          return True;
 750       end if;
 751
 752       if Subset.Length > Of_Set.Length then
 753          return False;
 754       end if;
 755
 756       --  TODO: rewrite this to loop in the
 757       --  style of a passive iterator.
 758
 759       Subset_Node := HT_Ops.First (Subset.HT);
 760       while Subset_Node /= null loop
 761          if not Is_In (Of_Set.HT, Subset_Node) then
 762             return False;
 763          end if;
 764          Subset_Node := HT_Ops.Next (Subset.HT, Subset_Node);
 765       end loop;
 766
 767       return True;
 768    end Is_Subset;
 769
 770    -------------
 771    -- Iterate --
 772    -------------
 773
 774    procedure Iterate
 775      (Container : Set;
 776       Process   : not null access procedure (Position : Cursor))
 777    is
 778       procedure Process_Node (Node : Node_Access);
 779       pragma Inline (Process_Node);
 780
 781       procedure Iterate is
 782          new HT_Ops.Generic_Iteration (Process_Node);
 783
 784       ------------------
 785       -- Process_Node --
 786       ------------------
 787
 788       procedure Process_Node (Node : Node_Access) is
 789       begin
 790          Process (Cursor'(Container'Unrestricted_Access, Node));
 791       end Process_Node;
 792
 793       HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT;
 794       B  : Natural renames HT.Busy;
 795
 796    --  Start of processing for Iterate
 797
 798    begin
 799       B := B + 1;
 800
 801       begin
 802          Iterate (HT);
 803       exception
 804          when others =>
 805             B := B - 1;
 806             raise;
 807       end;
 808
 809       B := B - 1;
 810    end Iterate;
 811
 812    ------------
 813    -- Length --
 814    ------------
 815
 816    function Length (Container : Set) return Count_Type is
 817    begin
 818       return Container.HT.Length;
 819    end Length;
 820
 821    ----------
 822    -- Move --
 823    ----------
 824
 825    procedure Move (Target : in out Set; Source : in out Set) is
 826    begin
 827       HT_Ops.Move (Target => Target.HT, Source => Source.HT);
 828    end Move;
 829
 830    ----------
 831    -- Next --
 832    ----------
 833
 834    function Next (Node : Node_Access) return Node_Access is
 835    begin
 836       return Node.Next;
 837    end Next;
 838
 839    function Next (Position : Cursor) return Cursor is
 840    begin
 841       if Position.Node = null then
 842          pragma Assert (Position.Container = null);
 843          return No_Element;
 844       end if;
 845
 846       declare
 847          HT   : Hash_Table_Type renames Position.Container.HT;
 848          Node : constant Node_Access := HT_Ops.Next (HT, Position.Node);
 849
 850       begin
 851          if Node = null then
 852             return No_Element;
 853          end if;
 854
 855          return Cursor'(Position.Container, Node);
 856       end;
 857    end Next;
 858
 859    procedure Next (Position : in out Cursor) is
 860    begin
 861       Position := Next (Position);
 862    end Next;
 863
 864    -------------
 865    -- Overlap --
 866    -------------
 867
 868    function Overlap (Left, Right : Set) return Boolean is
 869       Left_Node : Node_Access;
 870
 871    begin
 872       if Right.Length = 0 then
 873          return False;
 874       end if;
 875
 876       if Left'Address = Right'Address then
 877          return True;
 878       end if;
 879
 880       Left_Node := HT_Ops.First (Left.HT);
 881       while Left_Node /= null loop
 882          if Is_In (Right.HT, Left_Node) then
 883             return True;
 884          end if;
 885          Left_Node := HT_Ops.Next (Left.HT, Left_Node);
 886       end loop;
 887
 888       return False;
 889    end Overlap;
 890
 891    -------------------
 892    -- Query_Element --
 893    -------------------
 894
 895    procedure Query_Element
 896      (Position : Cursor;
 897       Process  : not null access procedure (Element : Element_Type))
 898    is
 899       E : Element_Type renames Position.Node.Element;
 900
 901       HT : Hash_Table_Type renames Position.Container.HT;
 902
 903       B : Natural renames HT.Busy;
 904       L : Natural renames HT.Lock;
 905
 906    begin
 907       B := B + 1;
 908       L := L + 1;
 909
 910       begin
 911          Process (E);
 912       exception
 913          when others =>
 914             L := L - 1;
 915             B := B - 1;
 916             raise;
 917       end;
 918
 919       L := L - 1;
 920       B := B - 1;
 921    end Query_Element;
 922
 923    ----------
 924    -- Read --
 925    ----------
 926
 927    procedure Read
 928      (Stream    : access Root_Stream_Type'Class;
 929       Container :    out Set)
 930    is
 931    begin
 932       Read_Nodes (Stream, Container.HT);
 933    end Read;
 934
 935    ---------------
 936    -- Read_Node --
 937    ---------------
 938
 939    function Read_Node (Stream : access Root_Stream_Type'Class)
 940      return Node_Access
 941    is
 942       Node : Node_Access := new Node_Type;
 943
 944    begin
 945       Element_Type'Read (Stream, Node.Element);
 946       return Node;
 947    exception
 948       when others =>
 949          Free (Node);
 950          raise;
 951    end Read_Node;
 952
 953    -------------
 954    -- Replace --
 955    -------------
 956
 957    procedure Replace
 958      (Container : in out Set;    --  TODO: need ruling from ARG
 959       New_Item  : Element_Type)
 960    is
 961       Node : constant Node_Access :=
 962                Element_Keys.Find (Container.HT, New_Item);
 963
 964    begin
 965       if Node = null then
 966          raise Constraint_Error;
 967       end if;
 968
 969       if Container.HT.Lock > 0 then
 970          raise Program_Error;
 971       end if;
 972
 973       Node.Element := New_Item;
 974    end Replace;
 975
 976    ---------------------
 977    -- Replace_Element --
 978    ---------------------
 979
 980    procedure Replace_Element
 981      (HT      : in out Hash_Table_Type;
 982       Node    : Node_Access;
 983       Element : Element_Type)
 984    is
 985    begin
 986       if Equivalent_Elements (Node.Element, Element) then
 987          pragma Assert (Hash (Node.Element) = Hash (Element));
 988
 989          if HT.Lock > 0 then
 990             raise Program_Error;
 991          end if;
 992
 993          Node.Element := Element;  --  Note that this assignment can fail
 994          return;
 995       end if;
 996
 997       if HT.Busy > 0 then
 998          raise Program_Error;
 999       end if;
1000
1001       HT_Ops.Delete_Node_Sans_Free (HT, Node);
1002
1003       Insert_New_Element : declare
1004          function New_Node (Next : Node_Access) return Node_Access;
1005          pragma Inline (New_Node);
1006
1007          procedure Local_Insert is
1008             new Element_Keys.Generic_Conditional_Insert (New_Node);
1009
1010          --------------
1011          -- New_Node --
1012          --------------
1013
1014          function New_Node (Next : Node_Access) return Node_Access is
1015          begin
1016             Node.Element := Element;  -- Note that this assignment can fail
1017             Node.Next := Next;
1018             return Node;
1019          end New_Node;
1020
1021          Result   : Node_Access;
1022          Inserted : Boolean;
1023
1024       --  Start of processing for Insert_New_Element
1025
1026       begin
1027          Local_Insert
1028            (HT       => HT,
1029             Key      => Element,
1030             Node     => Result,
1031             Inserted => Inserted);
1032
1033          if Inserted then
1034             pragma Assert (Result = Node);
1035             return;
1036          end if;
1037       exception
1038          when others =>
1039             null;   --  Assignment must have failed
1040       end Insert_New_Element;
1041
1042       Reinsert_Old_Element : declare
1043          function New_Node (Next : Node_Access) return Node_Access;
1044          pragma Inline (New_Node);
1045
1046          procedure Local_Insert is
1047             new Element_Keys.Generic_Conditional_Insert (New_Node);
1048
1049          --------------
1050          -- New_Node --
1051          --------------
1052
1053          function New_Node (Next : Node_Access) return Node_Access is
1054          begin
1055             Node.Next := Next;
1056             return Node;
1057          end New_Node;
1058
1059          Result   : Node_Access;
1060          Inserted : Boolean;
1061
1062       --  Start of processing for Reinsert_Old_Element
1063
1064       begin
1065          Local_Insert
1066            (HT       => HT,
1067             Key      => Node.Element,
1068             Node     => Result,
1069             Inserted => Inserted);
1070       exception
1071          when others =>
1072             null;
1073       end Reinsert_Old_Element;
1074
1075       raise Program_Error;
1076    end Replace_Element;
1077
1078    procedure Replace_Element
1079      (Container : Set;
1080       Position  : Cursor;
1081       By        : Element_Type)
1082    is
1083       HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT;
1084
1085    begin
1086       if Position.Node = null then
1087          raise Constraint_Error;
1088       end if;
1089
1090       if Position.Container /= Set_Access'(Container'Unrestricted_Access) then
1091          raise Program_Error;
1092       end if;
1093
1094       Replace_Element (HT, Position.Node, By);
1095    end Replace_Element;
1096
1097    ----------------------
1098    -- Reserve_Capacity --
1099    ----------------------
1100
1101    procedure Reserve_Capacity
1102      (Container : in out Set;
1103       Capacity  : Count_Type)
1104    is
1105    begin
1106       HT_Ops.Reserve_Capacity (Container.HT, Capacity);
1107    end Reserve_Capacity;
1108
1109    --------------
1110    -- Set_Next --
1111    --------------
1112
1113    procedure Set_Next (Node : Node_Access; Next : Node_Access) is
1114    begin
1115       Node.Next := Next;
1116    end Set_Next;
1117
1118    --------------------------
1119    -- Symmetric_Difference --
1120    --------------------------
1121
1122    procedure Symmetric_Difference
1123      (Target : in out Set;
1124       Source : Set)
1125    is
1126    begin
1127       if Target'Address = Source'Address then
1128          Clear (Target);
1129          return;
1130       end if;
1131
1132       if Target.HT.Busy > 0 then
1133          raise Program_Error;
1134       end if;
1135
1136       declare
1137          N : constant Count_Type := Target.Length + Source.Length;
1138       begin
1139          if N > HT_Ops.Capacity (Target.HT) then
1140             HT_Ops.Reserve_Capacity (Target.HT, N);
1141          end if;
1142       end;
1143
1144       if Target.Length = 0 then
1145          Iterate_Source_When_Empty_Target : declare
1146             procedure Process (Src_Node : Node_Access);
1147
1148             procedure Iterate is
1149                new HT_Ops.Generic_Iteration (Process);
1150
1151             -------------
1152             -- Process --
1153             -------------
1154
1155             procedure Process (Src_Node : Node_Access) is
1156                E : Element_Type renames Src_Node.Element;
1157                B : Buckets_Type renames Target.HT.Buckets.all;
1158                J : constant Hash_Type := Hash (E) mod B'Length;
1159                N : Count_Type renames Target.HT.Length;
1160
1161             begin
1162                B (J) := new Node_Type'(E, B (J));
1163                N := N + 1;
1164             end Process;
1165
1166          --  Start of processing for Iterate_Source_When_Empty_Target
1167
1168          begin
1169             Iterate (Source.HT);
1170          end Iterate_Source_When_Empty_Target;
1171
1172       else
1173          Iterate_Source : declare
1174             procedure Process (Src_Node : Node_Access);
1175
1176             procedure Iterate is
1177                new HT_Ops.Generic_Iteration (Process);
1178
1179             -------------
1180             -- Process --
1181             -------------
1182
1183             procedure Process (Src_Node : Node_Access) is
1184                E : Element_Type renames Src_Node.Element;
1185                B : Buckets_Type renames Target.HT.Buckets.all;
1186                J : constant Hash_Type := Hash (E) mod B'Length;
1187                N : Count_Type renames Target.HT.Length;
1188
1189             begin
1190                if B (J) = null then
1191                   B (J) := new Node_Type'(E, null);
1192                   N := N + 1;
1193
1194                elsif Equivalent_Elements (E, B (J).Element) then
1195                   declare
1196                      X : Node_Access := B (J);
1197                   begin
1198                      B (J) := B (J).Next;
1199                      N := N - 1;
1200                      Free (X);
1201                   end;
1202
1203                else
1204                   declare
1205                      Prev : Node_Access := B (J);
1206                      Curr : Node_Access := Prev.Next;
1207
1208                   begin
1209                      while Curr /= null loop
1210                         if Equivalent_Elements (E, Curr.Element) then
1211                            Prev.Next := Curr.Next;
1212                            N := N - 1;
1213                            Free (Curr);
1214                            return;
1215                         end if;
1216
1217                         Prev := Curr;
1218                         Curr := Prev.Next;
1219                      end loop;
1220
1221                      B (J) := new Node_Type'(E, B (J));
1222                      N := N + 1;
1223                   end;
1224                end if;
1225             end Process;
1226
1227          --  Start of processing for Iterate_Source
1228
1229          begin
1230             Iterate (Source.HT);
1231          end Iterate_Source;
1232       end if;
1233    end Symmetric_Difference;
1234
1235    function Symmetric_Difference (Left, Right : Set) return Set is
1236       Buckets : HT_Types.Buckets_Access;
1237       Length  : Count_Type;
1238
1239    begin
1240       if Left'Address = Right'Address then
1241          return Empty_Set;
1242       end if;
1243
1244       if Right.Length = 0 then
1245          return Left;
1246       end if;
1247
1248       if Left.Length = 0 then
1249          return Right;
1250       end if;
1251
1252       declare
1253          Size : constant Hash_Type :=
1254                   Prime_Numbers.To_Prime (Left.Length + Right.Length);
1255       begin
1256          Buckets := new Buckets_Type (0 .. Size - 1);
1257       end;
1258
1259       Length := 0;
1260
1261       Iterate_Left : declare
1262          procedure Process (L_Node : Node_Access);
1263
1264          procedure Iterate is
1265             new HT_Ops.Generic_Iteration (Process);
1266
1267          -------------
1268          -- Process --
1269          -------------
1270
1271          procedure Process (L_Node : Node_Access) is
1272          begin
1273             if not Is_In (Right.HT, L_Node) then
1274                declare
1275                   E : Element_Type renames L_Node.Element;
1276                   J : constant Hash_Type := Hash (E) mod Buckets'Length;
1277
1278                begin
1279                   Buckets (J) := new Node_Type'(E, Buckets (J));
1280                   Length := Length + 1;
1281                end;
1282             end if;
1283          end Process;
1284
1285       --  Start of processing for Iterate_Left
1286
1287       begin
1288          Iterate (Left.HT);
1289       exception
1290          when others =>
1291             HT_Ops.Free_Hash_Table (Buckets);
1292             raise;
1293       end Iterate_Left;
1294
1295       Iterate_Right : declare
1296          procedure Process (R_Node : Node_Access);
1297
1298          procedure Iterate is
1299             new HT_Ops.Generic_Iteration (Process);
1300
1301          -------------
1302          -- Process --
1303          -------------
1304
1305          procedure Process (R_Node : Node_Access) is
1306          begin
1307             if not Is_In (Left.HT, R_Node) then
1308                declare
1309                   E : Element_Type renames R_Node.Element;
1310                   J : constant Hash_Type := Hash (E) mod Buckets'Length;
1311
1312                begin
1313                   Buckets (J) := new Node_Type'(E, Buckets (J));
1314                   Length := Length + 1;
1315                end;
1316             end if;
1317          end Process;
1318
1319       --  Start of processing for Iterate_Right
1320
1321       begin
1322          Iterate (Right.HT);
1323       exception
1324          when others =>
1325             HT_Ops.Free_Hash_Table (Buckets);
1326             raise;
1327       end Iterate_Right;
1328
1329       return (Controlled with HT => (Buckets, Length, 0, 0));
1330    end Symmetric_Difference;
1331
1332    -----------
1333    -- Union --
1334    -----------
1335
1336    procedure Union
1337      (Target : in out Set;
1338       Source : Set)
1339    is
1340       procedure Process (Src_Node : Node_Access);
1341
1342       procedure Iterate is
1343          new HT_Ops.Generic_Iteration (Process);
1344
1345       -------------
1346       -- Process --
1347       -------------
1348
1349       procedure Process (Src_Node : Node_Access) is
1350          function New_Node (Next : Node_Access) return Node_Access;
1351          pragma Inline (New_Node);
1352
1353          procedure Insert is
1354             new Element_Keys.Generic_Conditional_Insert (New_Node);
1355
1356          --------------
1357          -- New_Node --
1358          --------------
1359
1360          function New_Node (Next : Node_Access) return Node_Access is
1361             Node : constant Node_Access :=
1362                      new Node_Type'(Src_Node.Element, Next);
1363          begin
1364             return Node;
1365          end New_Node;
1366
1367          Tgt_Node : Node_Access;
1368          Success  : Boolean;
1369
1370       --  Start of processing for Process
1371
1372       begin
1373          Insert (Target.HT, Src_Node.Element, Tgt_Node, Success);
1374       end Process;
1375
1376    --  Start of processing for Union
1377
1378    begin
1379       if Target'Address = Source'Address then
1380          return;
1381       end if;
1382
1383       if Target.HT.Busy > 0 then
1384          raise Program_Error;
1385       end if;
1386
1387       declare
1388          N : constant Count_Type := Target.Length + Source.Length;
1389       begin
1390          if N > HT_Ops.Capacity (Target.HT) then
1391             HT_Ops.Reserve_Capacity (Target.HT, N);
1392          end if;
1393       end;
1394
1395       Iterate (Source.HT);
1396    end Union;
1397
1398    function Union (Left, Right : Set) return Set is
1399       Buckets : HT_Types.Buckets_Access;
1400       Length  : Count_Type;
1401
1402    begin
1403       if Left'Address = Right'Address then
1404          return Left;
1405       end if;
1406
1407       if Right.Length = 0 then
1408          return Left;
1409       end if;
1410
1411       if Left.Length = 0 then
1412          return Right;
1413       end if;
1414
1415       declare
1416          Size : constant Hash_Type :=
1417                   Prime_Numbers.To_Prime (Left.Length + Right.Length);
1418       begin
1419          Buckets := new Buckets_Type (0 .. Size - 1);
1420       end;
1421
1422       Iterate_Left : declare
1423          procedure Process (L_Node : Node_Access);
1424
1425          procedure Iterate is
1426             new HT_Ops.Generic_Iteration (Process);
1427
1428          -------------
1429          -- Process --
1430          -------------
1431
1432          procedure Process (L_Node : Node_Access) is
1433             J : constant Hash_Type :=
1434                   Hash (L_Node.Element) mod Buckets'Length;
1435
1436          begin
1437             Buckets (J) := new Node_Type'(L_Node.Element, Buckets (J));
1438          end Process;
1439
1440       --  Start of processing for Iterate_Left
1441
1442       begin
1443          Iterate (Left.HT);
1444       exception
1445          when others =>
1446             HT_Ops.Free_Hash_Table (Buckets);
1447             raise;
1448       end Iterate_Left;
1449
1450       Length := Left.Length;
1451
1452       Iterate_Right : declare
1453          procedure Process (Src_Node : Node_Access);
1454
1455          procedure Iterate is
1456             new HT_Ops.Generic_Iteration (Process);
1457
1458          -------------
1459          -- Process --
1460          -------------
1461
1462          procedure Process (Src_Node : Node_Access) is
1463             J : constant Hash_Type :=
1464                   Hash (Src_Node.Element) mod Buckets'Length;
1465
1466             Tgt_Node : Node_Access := Buckets (J);
1467
1468          begin
1469             while Tgt_Node /= null loop
1470                if Equivalent_Elements (Src_Node.Element, Tgt_Node.Element) then
1471                   return;
1472                end if;
1473
1474                Tgt_Node := Next (Tgt_Node);
1475             end loop;
1476
1477             Buckets (J) := new Node_Type'(Src_Node.Element, Buckets (J));
1478             Length := Length + 1;
1479          end Process;
1480
1481       --  Start of processing for Iterate_Right
1482
1483       begin
1484          Iterate (Right.HT);
1485       exception
1486          when others =>
1487             HT_Ops.Free_Hash_Table (Buckets);
1488             raise;
1489       end Iterate_Right;
1490
1491       return (Controlled with HT => (Buckets, Length, 0, 0));
1492    end Union;
1493
1494    -----------
1495    -- Write --
1496    -----------
1497
1498    procedure Write
1499      (Stream    : access Root_Stream_Type'Class;
1500       Container : Set)
1501    is
1502    begin
1503       Write_Nodes (Stream, Container.HT);
1504    end Write;
1505
1506    ----------------
1507    -- Write_Node --
1508    ----------------
1509
1510    procedure Write_Node
1511      (Stream : access Root_Stream_Type'Class;
1512       Node   : Node_Access)
1513    is
1514    begin
1515       Element_Type'Write (Stream, Node.Element);
1516    end Write_Node;
1517
1518    package body Generic_Keys is
1519
1520       -----------------------
1521       -- Local Subprograms --
1522       -----------------------
1523
1524       function Equivalent_Key_Node
1525         (Key  : Key_Type;
1526          Node : Node_Access) return Boolean;
1527       pragma Inline (Equivalent_Key_Node);
1528
1529       --------------------------
1530       -- Local Instantiations --
1531       --------------------------
1532
1533       package Key_Keys is
1534          new Hash_Tables.Generic_Keys
1535           (HT_Types  => HT_Types,
1536            Next      => Next,
1537            Set_Next  => Set_Next,
1538            Key_Type  => Key_Type,
1539            Hash      => Hash,
1540            Equivalent_Keys => Equivalent_Key_Node);
1541
1542       --------------
1543       -- Contains --
1544       --------------
1545
1546       function Contains
1547         (Container : Set;
1548          Key       : Key_Type) return Boolean
1549       is
1550       begin
1551          return Find (Container, Key) /= No_Element;
1552       end Contains;
1553
1554       ------------
1555       -- Delete --
1556       ------------
1557
1558       procedure Delete
1559         (Container : in out Set;
1560          Key       : Key_Type)
1561       is
1562          X : Node_Access;
1563
1564       begin
1565          Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X);
1566
1567          if X = null then
1568             raise Constraint_Error;
1569          end if;
1570
1571          Free (X);
1572       end Delete;
1573
1574       -------------
1575       -- Element --
1576       -------------
1577
1578       function Element
1579         (Container : Set;
1580          Key       : Key_Type) return Element_Type
1581       is
1582          Node : constant Node_Access := Key_Keys.Find (Container.HT, Key);
1583
1584       begin
1585          return Node.Element;
1586       end Element;
1587
1588       -------------------------
1589       -- Equivalent_Key_Node --
1590       -------------------------
1591
1592       function Equivalent_Key_Node
1593         (Key  : Key_Type;
1594          Node : Node_Access) return Boolean
1595       is
1596       begin
1597          return Equivalent_Keys (Key, Node.Element);
1598       end Equivalent_Key_Node;
1599
1600       ---------------------
1601       -- Equivalent_Keys --
1602       ---------------------
1603
1604       function Equivalent_Keys
1605         (Left  : Cursor;
1606          Right : Key_Type) return Boolean is
1607       begin
1608          return Equivalent_Keys (Right, Left.Node.Element);
1609       end Equivalent_Keys;
1610
1611       function Equivalent_Keys
1612         (Left  : Key_Type;
1613          Right : Cursor) return Boolean is
1614       begin
1615          return Equivalent_Keys (Left, Right.Node.Element);
1616       end Equivalent_Keys;
1617
1618       -------------
1619       -- Exclude --
1620       -------------
1621
1622       procedure Exclude
1623         (Container : in out Set;
1624          Key       : Key_Type)
1625       is
1626          X : Node_Access;
1627       begin
1628          Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X);
1629          Free (X);
1630       end Exclude;
1631
1632       ----------
1633       -- Find --
1634       ----------
1635
1636       function Find
1637         (Container : Set;
1638          Key       : Key_Type) return Cursor
1639       is
1640          Node : constant Node_Access :=
1641                   Key_Keys.Find (Container.HT, Key);
1642
1643       begin
1644          if Node = null then
1645             return No_Element;
1646          end if;
1647
1648          return Cursor'(Container'Unrestricted_Access, Node);
1649       end Find;
1650
1651       ---------
1652       -- Key --
1653       ---------
1654
1655       function Key (Position : Cursor) return Key_Type is
1656       begin
1657          return Key (Position.Node.Element);
1658       end Key;
1659
1660       -------------
1661       -- Replace --
1662       -------------
1663
1664       procedure Replace
1665         (Container : in out Set;
1666          Key       : Key_Type;
1667          New_Item  : Element_Type)
1668       is
1669          Node : constant Node_Access :=
1670                   Key_Keys.Find (Container.HT, Key);
1671
1672       begin
1673          if Node = null then
1674             raise Constraint_Error;
1675          end if;
1676
1677          Replace_Element (Container.HT, Node, New_Item);
1678       end Replace;
1679
1680       -----------------------------------
1681       -- Update_Element_Preserving_Key --
1682       -----------------------------------
1683
1684       procedure Update_Element_Preserving_Key
1685         (Container : in out Set;
1686          Position  : Cursor;
1687          Process   : not null access
1688                        procedure (Element : in out Element_Type))
1689       is
1690          HT : Hash_Table_Type renames Container.HT;
1691
1692       begin
1693          if Position.Node = null then
1694             raise Constraint_Error;
1695          end if;
1696
1697          if Position.Container /= Set_Access'(Container'Unchecked_Access) then
1698             raise Program_Error;
1699          end if;
1700
1701          declare
1702             E : Element_Type renames Position.Node.Element;
1703             K : Key_Type renames Key (E);
1704
1705             B : Natural renames HT.Busy;
1706             L : Natural renames HT.Lock;
1707
1708          begin
1709             B := B + 1;
1710             L := L + 1;
1711
1712             begin
1713                Process (E);
1714             exception
1715                when others =>
1716                   L := L - 1;
1717                   B := B - 1;
1718                   raise;
1719             end;
1720
1721             L := L - 1;
1722             B := B - 1;
1723
1724             if Equivalent_Keys (K, E) then
1725                pragma Assert (Hash (K) = Hash (E));
1726                return;
1727             end if;
1728          end;
1729
1730          declare
1731             X : Node_Access := Position.Node;
1732          begin
1733             HT_Ops.Delete_Node_Sans_Free (HT, X);
1734             Free (X);
1735          end;
1736
1737          raise Program_Error;
1738       end Update_Element_Preserving_Key;
1739
1740    end Generic_Keys;
1741
1742 end Ada.Containers.Hashed_Sets;