gcc/ada/a-cihase.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT LIBRARY COMPONENTS                          --
   4 --                                                                          --
   5 --                  ADA.CONTAINERS.INDEFINITE_HASHED_SETS                   --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 2004-2011, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- This unit was originally developed by Matthew J Heaney.                  --
  28 ------------------------------------------------------------------------------
  29
  30 with Ada.Unchecked_Deallocation;
  31
  32 with Ada.Containers.Hash_Tables.Generic_Operations;
  33 pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Operations);
  34
  35 with Ada.Containers.Hash_Tables.Generic_Keys;
  36 pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys);
  37
  38 with Ada.Containers.Prime_Numbers;
  39 with System; use type System.Address;
  40
  41 package body Ada.Containers.Indefinite_Hashed_Sets is
  42
  43    type Iterator is new Limited_Controlled and
  44      Set_Iterator_Interfaces.Forward_Iterator with
  45    record
  46       Container : Set_Access;
  47    end record;
  48
  49    overriding procedure Finalize (Object : in out Iterator);
  50
  51    overriding function First (Object : Iterator) return Cursor;
  52
  53    overriding function Next
  54      (Object   : Iterator;
  55       Position : Cursor) return Cursor;
  56
  57    -----------------------
  58    -- Local Subprograms --
  59    -----------------------
  60
  61    procedure Assign (Node : Node_Access; Item : Element_Type);
  62    pragma Inline (Assign);
  63
  64    function Copy_Node (Source : Node_Access) return Node_Access;
  65    pragma Inline (Copy_Node);
  66
  67    function Equivalent_Keys
  68      (Key  : Element_Type;
  69       Node : Node_Access) return Boolean;
  70    pragma Inline (Equivalent_Keys);
  71
  72    function Find_Equal_Key
  73      (R_HT   : Hash_Table_Type;
  74       L_Node : Node_Access) return Boolean;
  75
  76    function Find_Equivalent_Key
  77      (R_HT   : Hash_Table_Type;
  78       L_Node : Node_Access) return Boolean;
  79
  80    procedure Free (X : in out Node_Access);
  81
  82    function Hash_Node (Node : Node_Access) return Hash_Type;
  83    pragma Inline (Hash_Node);
  84
  85    procedure Insert
  86      (HT       : in out Hash_Table_Type;
  87       New_Item : Element_Type;
  88       Node     : out Node_Access;
  89       Inserted : out Boolean);
  90
  91    function Is_In (HT  : Hash_Table_Type; Key : Node_Access) return Boolean;
  92    pragma Inline (Is_In);
  93
  94    function Next (Node : Node_Access) return Node_Access;
  95    pragma Inline (Next);
  96
  97    function Read_Node (Stream : not null access Root_Stream_Type'Class)
  98      return Node_Access;
  99    pragma Inline (Read_Node);
 100
 101    procedure Set_Next (Node : Node_Access; Next : Node_Access);
 102    pragma Inline (Set_Next);
 103
 104    function Vet (Position : Cursor) return Boolean;
 105
 106    procedure Write_Node
 107      (Stream : not null access Root_Stream_Type'Class;
 108       Node   : Node_Access);
 109    pragma Inline (Write_Node);
 110
 111    --------------------------
 112    -- Local Instantiations --
 113    --------------------------
 114
 115    procedure Free_Element is
 116      new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
 117
 118    package HT_Ops is new Hash_Tables.Generic_Operations
 119      (HT_Types  => HT_Types,
 120       Hash_Node => Hash_Node,
 121       Next      => Next,
 122       Set_Next  => Set_Next,
 123       Copy_Node => Copy_Node,
 124       Free      => Free);
 125
 126    package Element_Keys is new Hash_Tables.Generic_Keys
 127      (HT_Types        => HT_Types,
 128       Next            => Next,
 129       Set_Next        => Set_Next,
 130       Key_Type        => Element_Type,
 131       Hash            => Hash,
 132       Equivalent_Keys => Equivalent_Keys);
 133
 134    function Is_Equal is
 135       new HT_Ops.Generic_Equal (Find_Equal_Key);
 136
 137    function Is_Equivalent is
 138       new HT_Ops.Generic_Equal (Find_Equivalent_Key);
 139
 140    procedure Read_Nodes is
 141       new HT_Ops.Generic_Read (Read_Node);
 142
 143    procedure Replace_Element is
 144       new Element_Keys.Generic_Replace_Element (Hash_Node, Assign);
 145
 146    procedure Write_Nodes is
 147      new HT_Ops.Generic_Write (Write_Node);
 148
 149    ---------
 150    -- "=" --
 151    ---------
 152
 153    function "=" (Left, Right : Set) return Boolean is
 154    begin
 155       return Is_Equal (Left.HT, Right.HT);
 156    end "=";
 157
 158    ------------
 159    -- Adjust --
 160    ------------
 161
 162    procedure Adjust (Container : in out Set) is
 163    begin
 164       HT_Ops.Adjust (Container.HT);
 165    end Adjust;
 166
 167    ------------
 168    -- Assign --
 169    ------------
 170
 171    procedure Assign (Node : Node_Access; Item : Element_Type) is
 172       X : Element_Access := Node.Element;
 173    begin
 174       Node.Element := new Element_Type'(Item);
 175       Free_Element (X);
 176    end Assign;
 177
 178    procedure Assign (Target : in out Set; Source : Set) is
 179    begin
 180       if Target'Address = Source'Address then
 181          return;
 182       end if;
 183
 184       Target.Clear;
 185       Target.Union (Source);
 186    end Assign;
 187
 188    --------------
 189    -- Capacity --
 190    --------------
 191
 192    function Capacity (Container : Set) return Count_Type is
 193    begin
 194       return HT_Ops.Capacity (Container.HT);
 195    end Capacity;
 196
 197    -----------
 198    -- Clear --
 199    -----------
 200
 201    procedure Clear (Container : in out Set) is
 202    begin
 203       HT_Ops.Clear (Container.HT);
 204    end Clear;
 205
 206    --------------
 207    -- Contains --
 208    --------------
 209
 210    function Contains (Container : Set; Item : Element_Type) return Boolean is
 211    begin
 212       return Find (Container, Item) /= No_Element;
 213    end Contains;
 214
 215    ----------
 216    -- Copy --
 217    ----------
 218
 219    function Copy
 220      (Source   : Set;
 221       Capacity : Count_Type := 0) return Set
 222    is
 223       C : Count_Type;
 224
 225    begin
 226       if Capacity = 0 then
 227          C := Source.Length;
 228
 229       elsif Capacity >= Source.Length then
 230          C := Capacity;
 231
 232       else
 233          raise Capacity_Error
 234            with "Requested capacity is less than Source length";
 235       end if;
 236
 237       return Target : Set do
 238          Target.Reserve_Capacity (C);
 239          Target.Assign (Source);
 240       end return;
 241    end Copy;
 242
 243    ---------------
 244    -- Copy_Node --
 245    ---------------
 246
 247    function Copy_Node (Source : Node_Access) return Node_Access is
 248       E : Element_Access := new Element_Type'(Source.Element.all);
 249    begin
 250       return new Node_Type'(Element => E, Next => null);
 251    exception
 252       when others =>
 253          Free_Element (E);
 254          raise;
 255    end Copy_Node;
 256
 257    ------------
 258    -- Delete --
 259    ------------
 260
 261    procedure Delete
 262      (Container : in out Set;
 263       Item      : Element_Type)
 264    is
 265       X : Node_Access;
 266
 267    begin
 268       Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X);
 269
 270       if X = null then
 271          raise Constraint_Error with "attempt to delete element not in set";
 272       end if;
 273
 274       Free (X);
 275    end Delete;
 276
 277    procedure Delete
 278      (Container : in out Set;
 279       Position  : in out Cursor)
 280    is
 281    begin
 282       if Position.Node = null then
 283          raise Constraint_Error with "Position cursor equals No_Element";
 284       end if;
 285
 286       if Position.Node.Element = null then
 287          raise Program_Error with "Position cursor is bad";
 288       end if;
 289
 290       if Position.Container /= Container'Unrestricted_Access then
 291          raise Program_Error with "Position cursor designates wrong set";
 292       end if;
 293
 294       if Container.HT.Busy > 0 then
 295          raise Program_Error with
 296            "attempt to tamper with cursors (set is busy)";
 297       end if;
 298
 299       pragma Assert (Vet (Position), "Position cursor is bad");
 300
 301       HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node);
 302
 303       Free (Position.Node);
 304       Position.Container := null;
 305    end Delete;
 306
 307    ----------------
 308    -- Difference --
 309    ----------------
 310
 311    procedure Difference
 312      (Target : in out Set;
 313       Source : Set)
 314    is
 315       Tgt_Node : Node_Access;
 316
 317    begin
 318       if Target'Address = Source'Address then
 319          Clear (Target);
 320          return;
 321       end if;
 322
 323       if Source.HT.Length = 0 then
 324          return;
 325       end if;
 326
 327       if Target.HT.Busy > 0 then
 328          raise Program_Error with
 329            "attempt to tamper with cursors (set is busy)";
 330       end if;
 331
 332       if Source.HT.Length < Target.HT.Length then
 333          declare
 334             Src_Node : Node_Access;
 335
 336          begin
 337             Src_Node := HT_Ops.First (Source.HT);
 338             while Src_Node /= null loop
 339                Tgt_Node := Element_Keys.Find (Target.HT, Src_Node.Element.all);
 340
 341                if Tgt_Node /= null then
 342                   HT_Ops.Delete_Node_Sans_Free (Target.HT, Tgt_Node);
 343                   Free (Tgt_Node);
 344                end if;
 345
 346                Src_Node := HT_Ops.Next (Source.HT, Src_Node);
 347             end loop;
 348          end;
 349
 350       else
 351          Tgt_Node := HT_Ops.First (Target.HT);
 352          while Tgt_Node /= null loop
 353             if Is_In (Source.HT, Tgt_Node) then
 354                declare
 355                   X : Node_Access := Tgt_Node;
 356                begin
 357                   Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
 358                   HT_Ops.Delete_Node_Sans_Free (Target.HT, X);
 359                   Free (X);
 360                end;
 361
 362             else
 363                Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
 364             end if;
 365          end loop;
 366       end if;
 367    end Difference;
 368
 369    function Difference (Left, Right : Set) return Set is
 370       Buckets : HT_Types.Buckets_Access;
 371       Length  : Count_Type;
 372
 373    begin
 374       if Left'Address = Right'Address then
 375          return Empty_Set;
 376       end if;
 377
 378       if Left.Length = 0 then
 379          return Empty_Set;
 380       end if;
 381
 382       if Right.Length = 0 then
 383          return Left;
 384       end if;
 385
 386       declare
 387          Size : constant Hash_Type := Prime_Numbers.To_Prime (Left.Length);
 388       begin
 389          Buckets := HT_Ops.New_Buckets (Length => Size);
 390       end;
 391
 392       Length := 0;
 393
 394       Iterate_Left : declare
 395          procedure Process (L_Node : Node_Access);
 396
 397          procedure Iterate is
 398             new HT_Ops.Generic_Iteration (Process);
 399
 400          -------------
 401          -- Process --
 402          -------------
 403
 404          procedure Process (L_Node : Node_Access) is
 405          begin
 406             if not Is_In (Right.HT, L_Node) then
 407                declare
 408                   Src    : Element_Type renames L_Node.Element.all;
 409                   Indx   : constant Hash_Type := Hash (Src) mod Buckets'Length;
 410                   Bucket : Node_Access renames Buckets (Indx);
 411                   Tgt    : Element_Access := new Element_Type'(Src);
 412                begin
 413                   Bucket := new Node_Type'(Tgt, Bucket);
 414                exception
 415                   when others =>
 416                      Free_Element (Tgt);
 417                      raise;
 418                end;
 419
 420                Length := Length + 1;
 421             end if;
 422          end Process;
 423
 424       --  Start of processing for Iterate_Left
 425
 426       begin
 427          Iterate (Left.HT);
 428       exception
 429          when others =>
 430             HT_Ops.Free_Hash_Table (Buckets);
 431             raise;
 432       end Iterate_Left;
 433
 434       return (Controlled with HT => (Buckets, Length, 0, 0));
 435    end Difference;
 436
 437    -------------
 438    -- Element --
 439    -------------
 440
 441    function Element (Position : Cursor) return Element_Type is
 442    begin
 443       if Position.Node = null then
 444          raise Constraint_Error with "Position cursor of equals No_Element";
 445       end if;
 446
 447       if Position.Node.Element = null then  --  handle dangling reference
 448          raise Program_Error with "Position cursor is bad";
 449       end if;
 450
 451       pragma Assert (Vet (Position), "bad cursor in function Element");
 452
 453       return Position.Node.Element.all;
 454    end Element;
 455
 456    ---------------------
 457    -- Equivalent_Sets --
 458    ---------------------
 459
 460    function Equivalent_Sets (Left, Right : Set) return Boolean is
 461    begin
 462       return Is_Equivalent (Left.HT, Right.HT);
 463    end Equivalent_Sets;
 464
 465    -------------------------
 466    -- Equivalent_Elements --
 467    -------------------------
 468
 469    function Equivalent_Elements (Left, Right : Cursor) return Boolean is
 470    begin
 471       if Left.Node = null then
 472          raise Constraint_Error with
 473            "Left cursor of Equivalent_Elements equals No_Element";
 474       end if;
 475
 476       if Right.Node = null then
 477          raise Constraint_Error with
 478            "Right cursor of Equivalent_Elements equals No_Element";
 479       end if;
 480
 481       if Left.Node.Element = null then
 482          raise Program_Error with
 483            "Left cursor of Equivalent_Elements is bad";
 484       end if;
 485
 486       if Right.Node.Element = null then
 487          raise Program_Error with
 488            "Right cursor of Equivalent_Elements is bad";
 489       end if;
 490
 491       pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Elements");
 492       pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Elements");
 493
 494       return Equivalent_Elements
 495                (Left.Node.Element.all,
 496                 Right.Node.Element.all);
 497    end Equivalent_Elements;
 498
 499    function Equivalent_Elements
 500      (Left  : Cursor;
 501       Right : Element_Type) return Boolean
 502    is
 503    begin
 504       if Left.Node = null then
 505          raise Constraint_Error with
 506            "Left cursor of Equivalent_Elements equals No_Element";
 507       end if;
 508
 509       if Left.Node.Element = null then
 510          raise Program_Error with
 511            "Left cursor of Equivalent_Elements is bad";
 512       end if;
 513
 514       pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Elements");
 515
 516       return Equivalent_Elements (Left.Node.Element.all, Right);
 517    end Equivalent_Elements;
 518
 519    function Equivalent_Elements
 520      (Left  : Element_Type;
 521       Right : Cursor) return Boolean
 522    is
 523    begin
 524       if Right.Node = null then
 525          raise Constraint_Error with
 526            "Right cursor of Equivalent_Elements equals No_Element";
 527       end if;
 528
 529       if Right.Node.Element = null then
 530          raise Program_Error with
 531            "Right cursor of Equivalent_Elements is bad";
 532       end if;
 533
 534       pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Elements");
 535
 536       return Equivalent_Elements (Left, Right.Node.Element.all);
 537    end Equivalent_Elements;
 538
 539    ---------------------
 540    -- Equivalent_Keys --
 541    ---------------------
 542
 543    function Equivalent_Keys
 544      (Key  : Element_Type;
 545       Node : Node_Access) return Boolean
 546    is
 547    begin
 548       return Equivalent_Elements (Key, Node.Element.all);
 549    end Equivalent_Keys;
 550
 551    -------------
 552    -- Exclude --
 553    -------------
 554
 555    procedure Exclude
 556      (Container : in out Set;
 557       Item      : Element_Type)
 558    is
 559       X : Node_Access;
 560    begin
 561       Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X);
 562       Free (X);
 563    end Exclude;
 564
 565    --------------
 566    -- Finalize --
 567    --------------
 568
 569    procedure Finalize (Container : in out Set) is
 570    begin
 571       HT_Ops.Finalize (Container.HT);
 572    end Finalize;
 573
 574    procedure Finalize (Object : in out Iterator) is
 575    begin
 576       if Object.Container /= null then
 577          declare
 578             B : Natural renames Object.Container.all.HT.Busy;
 579
 580          begin
 581             B := B - 1;
 582          end;
 583       end if;
 584    end Finalize;
 585
 586    ----------
 587    -- Find --
 588    ----------
 589
 590    function Find
 591      (Container : Set;
 592       Item      : Element_Type) return Cursor
 593    is
 594       Node : constant Node_Access := Element_Keys.Find (Container.HT, Item);
 595    begin
 596       return (if Node = null then No_Element
 597               else Cursor'(Container'Unrestricted_Access, Node));
 598    end Find;
 599
 600    --------------------
 601    -- Find_Equal_Key --
 602    --------------------
 603
 604    function Find_Equal_Key
 605      (R_HT   : Hash_Table_Type;
 606       L_Node : Node_Access) return Boolean
 607    is
 608       R_Index : constant Hash_Type :=
 609                   Element_Keys.Index (R_HT, L_Node.Element.all);
 610
 611       R_Node  : Node_Access := R_HT.Buckets (R_Index);
 612
 613    begin
 614       loop
 615          if R_Node = null then
 616             return False;
 617          end if;
 618
 619          if L_Node.Element.all = R_Node.Element.all then
 620             return True;
 621          end if;
 622
 623          R_Node := Next (R_Node);
 624       end loop;
 625    end Find_Equal_Key;
 626
 627    -------------------------
 628    -- Find_Equivalent_Key --
 629    -------------------------
 630
 631    function Find_Equivalent_Key
 632      (R_HT   : Hash_Table_Type;
 633       L_Node : Node_Access) return Boolean
 634    is
 635       R_Index : constant Hash_Type :=
 636                   Element_Keys.Index (R_HT, L_Node.Element.all);
 637
 638       R_Node  : Node_Access := R_HT.Buckets (R_Index);
 639
 640    begin
 641       loop
 642          if R_Node = null then
 643             return False;
 644          end if;
 645
 646          if Equivalent_Elements (L_Node.Element.all, R_Node.Element.all) then
 647             return True;
 648          end if;
 649
 650          R_Node := Next (R_Node);
 651       end loop;
 652    end Find_Equivalent_Key;
 653
 654    -----------
 655    -- First --
 656    -----------
 657
 658    function First (Container : Set) return Cursor is
 659       Node : constant Node_Access := HT_Ops.First (Container.HT);
 660    begin
 661       return (if Node = null then No_Element
 662               else Cursor'(Container'Unrestricted_Access, Node));
 663    end First;
 664
 665    function First (Object : Iterator) return Cursor is
 666    begin
 667       return Object.Container.First;
 668    end First;
 669
 670    ----------
 671    -- Free --
 672    ----------
 673
 674    procedure Free (X : in out Node_Access) is
 675       procedure Deallocate is
 676          new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
 677
 678    begin
 679       if X = null then
 680          return;
 681       end if;
 682
 683       X.Next := X;  --  detect mischief (in Vet)
 684
 685       begin
 686          Free_Element (X.Element);
 687       exception
 688          when others =>
 689             X.Element := null;
 690             Deallocate (X);
 691             raise;
 692       end;
 693
 694       Deallocate (X);
 695    end Free;
 696
 697    -----------------
 698    -- Has_Element --
 699    -----------------
 700
 701    function Has_Element (Position : Cursor) return Boolean is
 702    begin
 703       pragma Assert (Vet (Position), "bad cursor in Has_Element");
 704       return Position.Node /= null;
 705    end Has_Element;
 706
 707    ---------------
 708    -- Hash_Node --
 709    ---------------
 710
 711    function Hash_Node (Node : Node_Access) return Hash_Type is
 712    begin
 713       return Hash (Node.Element.all);
 714    end Hash_Node;
 715
 716    -------------
 717    -- Include --
 718    -------------
 719
 720    procedure Include
 721      (Container : in out Set;
 722       New_Item  : Element_Type)
 723    is
 724       Position : Cursor;
 725       Inserted : Boolean;
 726
 727       X : Element_Access;
 728
 729    begin
 730       Insert (Container, New_Item, Position, Inserted);
 731
 732       if not Inserted then
 733          if Container.HT.Lock > 0 then
 734             raise Program_Error with
 735               "attempt to tamper with elements (set is locked)";
 736          end if;
 737
 738          X := Position.Node.Element;
 739
 740          Position.Node.Element := new Element_Type'(New_Item);
 741
 742          Free_Element (X);
 743       end if;
 744    end Include;
 745
 746    ------------
 747    -- Insert --
 748    ------------
 749
 750    procedure Insert
 751      (Container : in out Set;
 752       New_Item  : Element_Type;
 753       Position  : out Cursor;
 754       Inserted  : out Boolean)
 755    is
 756    begin
 757       Insert (Container.HT, New_Item, Position.Node, Inserted);
 758       Position.Container := Container'Unchecked_Access;
 759    end Insert;
 760
 761    procedure Insert
 762      (Container : in out Set;
 763       New_Item  : Element_Type)
 764    is
 765       Position : Cursor;
 766       pragma Unreferenced (Position);
 767
 768       Inserted : Boolean;
 769
 770    begin
 771       Insert (Container, New_Item, Position, Inserted);
 772
 773       if not Inserted then
 774          raise Constraint_Error with
 775            "attempt to insert element already in set";
 776       end if;
 777    end Insert;
 778
 779    procedure Insert
 780      (HT       : in out Hash_Table_Type;
 781       New_Item : Element_Type;
 782       Node     : out Node_Access;
 783       Inserted : out Boolean)
 784    is
 785       function New_Node (Next : Node_Access) return Node_Access;
 786       pragma Inline (New_Node);
 787
 788       procedure Local_Insert is
 789          new Element_Keys.Generic_Conditional_Insert (New_Node);
 790
 791       --------------
 792       -- New_Node --
 793       --------------
 794
 795       function New_Node (Next : Node_Access) return Node_Access is
 796          Element : Element_Access := new Element_Type'(New_Item);
 797       begin
 798          return new Node_Type'(Element, Next);
 799       exception
 800          when others =>
 801             Free_Element (Element);
 802             raise;
 803       end New_Node;
 804
 805    --  Start of processing for Insert
 806
 807    begin
 808       if HT_Ops.Capacity (HT) = 0 then
 809          HT_Ops.Reserve_Capacity (HT, 1);
 810       end if;
 811
 812       Local_Insert (HT, New_Item, Node, Inserted);
 813
 814       if Inserted
 815         and then HT.Length > HT_Ops.Capacity (HT)
 816       then
 817          HT_Ops.Reserve_Capacity (HT, HT.Length);
 818       end if;
 819    end Insert;
 820
 821    ------------------
 822    -- Intersection --
 823    ------------------
 824
 825    procedure Intersection
 826      (Target : in out Set;
 827       Source : Set)
 828    is
 829       Tgt_Node : Node_Access;
 830
 831    begin
 832       if Target'Address = Source'Address then
 833          return;
 834       end if;
 835
 836       if Source.Length = 0 then
 837          Clear (Target);
 838          return;
 839       end if;
 840
 841       if Target.HT.Busy > 0 then
 842          raise Program_Error with
 843            "attempt to tamper with cursors (set is busy)";
 844       end if;
 845
 846       Tgt_Node := HT_Ops.First (Target.HT);
 847       while Tgt_Node /= null loop
 848          if Is_In (Source.HT, Tgt_Node) then
 849             Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
 850
 851          else
 852             declare
 853                X : Node_Access := Tgt_Node;
 854             begin
 855                Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
 856                HT_Ops.Delete_Node_Sans_Free (Target.HT, X);
 857                Free (X);
 858             end;
 859          end if;
 860       end loop;
 861    end Intersection;
 862
 863    function Intersection (Left, Right : Set) return Set is
 864       Buckets : HT_Types.Buckets_Access;
 865       Length  : Count_Type;
 866
 867    begin
 868       if Left'Address = Right'Address then
 869          return Left;
 870       end if;
 871
 872       Length := Count_Type'Min (Left.Length, Right.Length);
 873
 874       if Length = 0 then
 875          return Empty_Set;
 876       end if;
 877
 878       declare
 879          Size : constant Hash_Type := Prime_Numbers.To_Prime (Length);
 880       begin
 881          Buckets := HT_Ops.New_Buckets (Length => Size);
 882       end;
 883
 884       Length := 0;
 885
 886       Iterate_Left : declare
 887          procedure Process (L_Node : Node_Access);
 888
 889          procedure Iterate is
 890             new HT_Ops.Generic_Iteration (Process);
 891
 892          -------------
 893          -- Process --
 894          -------------
 895
 896          procedure Process (L_Node : Node_Access) is
 897          begin
 898             if Is_In (Right.HT, L_Node) then
 899                declare
 900                   Src : Element_Type renames L_Node.Element.all;
 901
 902                   Indx : constant Hash_Type := Hash (Src) mod Buckets'Length;
 903
 904                   Bucket : Node_Access renames Buckets (Indx);
 905
 906                   Tgt : Element_Access := new Element_Type'(Src);
 907
 908                begin
 909                   Bucket := new Node_Type'(Tgt, Bucket);
 910                exception
 911                   when others =>
 912                      Free_Element (Tgt);
 913                      raise;
 914                end;
 915
 916                Length := Length + 1;
 917             end if;
 918          end Process;
 919
 920       --  Start of processing for Iterate_Left
 921
 922       begin
 923          Iterate (Left.HT);
 924       exception
 925          when others =>
 926             HT_Ops.Free_Hash_Table (Buckets);
 927             raise;
 928       end Iterate_Left;
 929
 930       return (Controlled with HT => (Buckets, Length, 0, 0));
 931    end Intersection;
 932
 933    --------------
 934    -- Is_Empty --
 935    --------------
 936
 937    function Is_Empty (Container : Set) return Boolean is
 938    begin
 939       return Container.HT.Length = 0;
 940    end Is_Empty;
 941
 942    -----------
 943    -- Is_In --
 944    -----------
 945
 946    function Is_In (HT  : Hash_Table_Type; Key : Node_Access) return Boolean is
 947    begin
 948       return Element_Keys.Find (HT, Key.Element.all) /= null;
 949    end Is_In;
 950
 951    ---------------
 952    -- Is_Subset --
 953    ---------------
 954
 955    function Is_Subset
 956      (Subset : Set;
 957       Of_Set : Set) return Boolean
 958    is
 959       Subset_Node : Node_Access;
 960
 961    begin
 962       if Subset'Address = Of_Set'Address then
 963          return True;
 964       end if;
 965
 966       if Subset.Length > Of_Set.Length then
 967          return False;
 968       end if;
 969
 970       Subset_Node := HT_Ops.First (Subset.HT);
 971       while Subset_Node /= null loop
 972          if not Is_In (Of_Set.HT, Subset_Node) then
 973             return False;
 974          end if;
 975
 976          Subset_Node := HT_Ops.Next (Subset.HT, Subset_Node);
 977       end loop;
 978
 979       return True;
 980    end Is_Subset;
 981
 982    -------------
 983    -- Iterate --
 984    -------------
 985
 986    procedure Iterate
 987      (Container : Set;
 988       Process   : not null access procedure (Position : Cursor))
 989    is
 990       procedure Process_Node (Node : Node_Access);
 991       pragma Inline (Process_Node);
 992
 993       procedure Iterate is
 994          new HT_Ops.Generic_Iteration (Process_Node);
 995
 996       ------------------
 997       -- Process_Node --
 998       ------------------
 999
1000       procedure Process_Node (Node : Node_Access) is
1001       begin
1002          Process (Cursor'(Container'Unrestricted_Access, Node));
1003       end Process_Node;
1004
1005       B : Natural renames Container'Unrestricted_Access.all.HT.Busy;
1006
1007    --  Start of processing for Iterate
1008
1009    begin
1010       B := B + 1;
1011
1012       begin
1013          Iterate (Container.HT);
1014       exception
1015          when others =>
1016             B := B - 1;
1017             raise;
1018       end;
1019
1020       B := B - 1;
1021    end Iterate;
1022
1023    function Iterate (Container : Set)
1024      return Set_Iterator_Interfaces.Forward_Iterator'Class
1025    is
1026       B : Natural renames Container'Unrestricted_Access.all.HT.Busy;
1027
1028    begin
1029       return It : constant Iterator :=
1030                     Iterator'(Limited_Controlled with
1031                                 Container => Container'Unrestricted_Access)
1032       do
1033          B := B + 1;
1034       end return;
1035    end Iterate;
1036
1037    ------------
1038    -- Length --
1039    ------------
1040
1041    function Length (Container : Set) return Count_Type is
1042    begin
1043       return Container.HT.Length;
1044    end Length;
1045
1046    ----------
1047    -- Move --
1048    ----------
1049
1050    procedure Move (Target : in out Set; Source : in out Set) is
1051    begin
1052       HT_Ops.Move (Target => Target.HT, Source => Source.HT);
1053    end Move;
1054
1055    ----------
1056    -- Next --
1057    ----------
1058
1059    function Next (Node : Node_Access) return Node_Access is
1060    begin
1061       return Node.Next;
1062    end Next;
1063
1064    function Next (Position : Cursor) return Cursor is
1065    begin
1066       if Position.Node = null then
1067          return No_Element;
1068       end if;
1069
1070       if Position.Node.Element = null then
1071          raise Program_Error with "bad cursor in Next";
1072       end if;
1073
1074       pragma Assert (Vet (Position), "bad cursor in Next");
1075
1076       declare
1077          HT   : Hash_Table_Type renames Position.Container.HT;
1078          Node : constant Node_Access := HT_Ops.Next (HT, Position.Node);
1079       begin
1080          return (if Node = null then No_Element
1081                  else Cursor'(Position.Container, Node));
1082       end;
1083    end Next;
1084
1085    procedure Next (Position : in out Cursor) is
1086    begin
1087       Position := Next (Position);
1088    end Next;
1089
1090    function Next
1091      (Object   : Iterator;
1092       Position : Cursor) return Cursor
1093    is
1094    begin
1095       if Position.Container = null then
1096          return No_Element;
1097       end if;
1098
1099       if Position.Container /= Object.Container then
1100          raise Program_Error with
1101            "Position cursor of Next designates wrong set";
1102       end if;
1103
1104       return Next (Position);
1105    end Next;
1106
1107    -------------
1108    -- Overlap --
1109    -------------
1110
1111    function Overlap (Left, Right : Set) return Boolean is
1112       Left_Node : Node_Access;
1113
1114    begin
1115       if Right.Length = 0 then
1116          return False;
1117       end if;
1118
1119       if Left'Address = Right'Address then
1120          return True;
1121       end if;
1122
1123       Left_Node := HT_Ops.First (Left.HT);
1124       while Left_Node /= null loop
1125          if Is_In (Right.HT, Left_Node) then
1126             return True;
1127          end if;
1128
1129          Left_Node := HT_Ops.Next (Left.HT, Left_Node);
1130       end loop;
1131
1132       return False;
1133    end Overlap;
1134
1135    -------------------
1136    -- Query_Element --
1137    -------------------
1138
1139    procedure Query_Element
1140      (Position : Cursor;
1141       Process  : not null access procedure (Element : Element_Type))
1142    is
1143    begin
1144       if Position.Node = null then
1145          raise Constraint_Error with
1146            "Position cursor of Query_Element equals No_Element";
1147       end if;
1148
1149       if Position.Node.Element = null then
1150          raise Program_Error with "bad cursor in Query_Element";
1151       end if;
1152
1153       pragma Assert (Vet (Position), "bad cursor in Query_Element");
1154
1155       declare
1156          HT : Hash_Table_Type renames
1157                 Position.Container'Unrestricted_Access.all.HT;
1158
1159          B : Natural renames HT.Busy;
1160          L : Natural renames HT.Lock;
1161
1162       begin
1163          B := B + 1;
1164          L := L + 1;
1165
1166          begin
1167             Process (Position.Node.Element.all);
1168          exception
1169             when others =>
1170                L := L - 1;
1171                B := B - 1;
1172                raise;
1173          end;
1174
1175          L := L - 1;
1176          B := B - 1;
1177       end;
1178    end Query_Element;
1179
1180    ----------
1181    -- Read --
1182    ----------
1183
1184    procedure Read
1185      (Stream    : not null access Root_Stream_Type'Class;
1186       Container : out Set)
1187    is
1188    begin
1189       Read_Nodes (Stream, Container.HT);
1190    end Read;
1191
1192    procedure Read
1193      (Stream : not null access Root_Stream_Type'Class;
1194       Item   : out Cursor)
1195    is
1196    begin
1197       raise Program_Error with "attempt to stream set cursor";
1198    end Read;
1199
1200    procedure Read
1201      (Stream : not null access Root_Stream_Type'Class;
1202       Item   : out Constant_Reference_Type)
1203    is
1204    begin
1205       raise Program_Error with "attempt to stream reference";
1206    end Read;
1207
1208    ---------------
1209    -- Read_Node --
1210    ---------------
1211
1212    function Read_Node
1213      (Stream : not null access Root_Stream_Type'Class) return Node_Access
1214    is
1215       X : Element_Access := new Element_Type'(Element_Type'Input (Stream));
1216    begin
1217       return new Node_Type'(X, null);
1218    exception
1219       when others =>
1220          Free_Element (X);
1221          raise;
1222    end Read_Node;
1223
1224    ---------------
1225    -- Reference --
1226    ---------------
1227
1228    function Constant_Reference
1229      (Container : aliased Set;
1230       Position  : Cursor) return Constant_Reference_Type
1231    is
1232       pragma Unreferenced (Container);
1233    begin
1234       return (Element => Position.Node.Element.all'Access);
1235    end Constant_Reference;
1236
1237    -------------
1238    -- Replace --
1239    -------------
1240
1241    procedure Replace
1242      (Container : in out Set;
1243       New_Item  : Element_Type)
1244    is
1245       Node : constant Node_Access :=
1246                Element_Keys.Find (Container.HT, New_Item);
1247
1248       X : Element_Access;
1249       pragma Warnings (Off, X);
1250
1251    begin
1252       if Node = null then
1253          raise Constraint_Error with
1254            "attempt to replace element not in set";
1255       end if;
1256
1257       if Container.HT.Lock > 0 then
1258          raise Program_Error with
1259            "attempt to tamper with elements (set is locked)";
1260       end if;
1261
1262       X := Node.Element;
1263
1264       Node.Element := new Element_Type'(New_Item);
1265
1266       Free_Element (X);
1267    end Replace;
1268
1269    ---------------------
1270    -- Replace_Element --
1271    ---------------------
1272
1273    procedure Replace_Element
1274      (Container : in out Set;
1275       Position  : Cursor;
1276       New_Item  : Element_Type)
1277    is
1278    begin
1279       if Position.Node = null then
1280          raise Constraint_Error with "Position cursor equals No_Element";
1281       end if;
1282
1283       if Position.Node.Element = null then
1284          raise Program_Error with "bad cursor in Replace_Element";
1285       end if;
1286
1287       if Position.Container /= Container'Unrestricted_Access then
1288          raise Program_Error with
1289            "Position cursor designates wrong set";
1290       end if;
1291
1292       pragma Assert (Vet (Position), "bad cursor in Replace_Element");
1293
1294       Replace_Element (Container.HT, Position.Node, New_Item);
1295    end Replace_Element;
1296
1297    ----------------------
1298    -- Reserve_Capacity --
1299    ----------------------
1300
1301    procedure Reserve_Capacity
1302      (Container : in out Set;
1303       Capacity  : Count_Type)
1304    is
1305    begin
1306       HT_Ops.Reserve_Capacity (Container.HT, Capacity);
1307    end Reserve_Capacity;
1308
1309    --------------
1310    -- Set_Next --
1311    --------------
1312
1313    procedure Set_Next (Node : Node_Access; Next : Node_Access) is
1314    begin
1315       Node.Next := Next;
1316    end Set_Next;
1317
1318    --------------------------
1319    -- Symmetric_Difference --
1320    --------------------------
1321
1322    procedure Symmetric_Difference
1323      (Target : in out Set;
1324       Source : Set)
1325    is
1326    begin
1327       if Target'Address = Source'Address then
1328          Clear (Target);
1329          return;
1330       end if;
1331
1332       if Target.HT.Busy > 0 then
1333          raise Program_Error with
1334            "attempt to tamper with cursors (set is busy)";
1335       end if;
1336
1337       declare
1338          N : constant Count_Type := Target.Length + Source.Length;
1339       begin
1340          if N > HT_Ops.Capacity (Target.HT) then
1341             HT_Ops.Reserve_Capacity (Target.HT, N);
1342          end if;
1343       end;
1344
1345       if Target.Length = 0 then
1346          Iterate_Source_When_Empty_Target : declare
1347             procedure Process (Src_Node : Node_Access);
1348
1349             procedure Iterate is new HT_Ops.Generic_Iteration (Process);
1350
1351             -------------
1352             -- Process --
1353             -------------
1354
1355             procedure Process (Src_Node : Node_Access) is
1356                E : Element_Type renames Src_Node.Element.all;
1357                B : Buckets_Type renames Target.HT.Buckets.all;
1358                J : constant Hash_Type := Hash (E) mod B'Length;
1359                N : Count_Type renames Target.HT.Length;
1360
1361             begin
1362                declare
1363                   X : Element_Access := new Element_Type'(E);
1364                begin
1365                   B (J) := new Node_Type'(X, B (J));
1366                exception
1367                   when others =>
1368                      Free_Element (X);
1369                      raise;
1370                end;
1371
1372                N := N + 1;
1373             end Process;
1374
1375          --  Start of processing for Iterate_Source_When_Empty_Target
1376
1377          begin
1378             Iterate (Source.HT);
1379          end Iterate_Source_When_Empty_Target;
1380
1381       else
1382          Iterate_Source : declare
1383             procedure Process (Src_Node : Node_Access);
1384
1385             procedure Iterate is
1386                new HT_Ops.Generic_Iteration (Process);
1387
1388             -------------
1389             -- Process --
1390             -------------
1391
1392             procedure Process (Src_Node : Node_Access) is
1393                E : Element_Type renames Src_Node.Element.all;
1394                B : Buckets_Type renames Target.HT.Buckets.all;
1395                J : constant Hash_Type := Hash (E) mod B'Length;
1396                N : Count_Type renames Target.HT.Length;
1397
1398             begin
1399                if B (J) = null then
1400                   declare
1401                      X : Element_Access := new Element_Type'(E);
1402                   begin
1403                      B (J) := new Node_Type'(X, null);
1404                   exception
1405                      when others =>
1406                         Free_Element (X);
1407                         raise;
1408                   end;
1409
1410                   N := N + 1;
1411
1412                elsif Equivalent_Elements (E, B (J).Element.all) then
1413                   declare
1414                      X : Node_Access := B (J);
1415                   begin
1416                      B (J) := B (J).Next;
1417                      N := N - 1;
1418                      Free (X);
1419                   end;
1420
1421                else
1422                   declare
1423                      Prev : Node_Access := B (J);
1424                      Curr : Node_Access := Prev.Next;
1425
1426                   begin
1427                      while Curr /= null loop
1428                         if Equivalent_Elements (E, Curr.Element.all) then
1429                            Prev.Next := Curr.Next;
1430                            N := N - 1;
1431                            Free (Curr);
1432                            return;
1433                         end if;
1434
1435                         Prev := Curr;
1436                         Curr := Prev.Next;
1437                      end loop;
1438
1439                      declare
1440                         X : Element_Access := new Element_Type'(E);
1441                      begin
1442                         B (J) := new Node_Type'(X, B (J));
1443                      exception
1444                         when others =>
1445                            Free_Element (X);
1446                            raise;
1447                      end;
1448
1449                      N := N + 1;
1450                   end;
1451                end if;
1452             end Process;
1453
1454          --  Start of processing for Iterate_Source
1455
1456          begin
1457             Iterate (Source.HT);
1458          end Iterate_Source;
1459       end if;
1460    end Symmetric_Difference;
1461
1462    function Symmetric_Difference (Left, Right : Set) return Set is
1463       Buckets : HT_Types.Buckets_Access;
1464       Length  : Count_Type;
1465
1466    begin
1467       if Left'Address = Right'Address then
1468          return Empty_Set;
1469       end if;
1470
1471       if Right.Length = 0 then
1472          return Left;
1473       end if;
1474
1475       if Left.Length = 0 then
1476          return Right;
1477       end if;
1478
1479       declare
1480          Size : constant Hash_Type :=
1481                   Prime_Numbers.To_Prime (Left.Length + Right.Length);
1482       begin
1483          Buckets := HT_Ops.New_Buckets (Length => Size);
1484       end;
1485
1486       Length := 0;
1487
1488       Iterate_Left : declare
1489          procedure Process (L_Node : Node_Access);
1490
1491          procedure Iterate is
1492             new HT_Ops.Generic_Iteration (Process);
1493
1494          -------------
1495          -- Process --
1496          -------------
1497
1498          procedure Process (L_Node : Node_Access) is
1499          begin
1500             if not Is_In (Right.HT, L_Node) then
1501                declare
1502                   E : Element_Type renames L_Node.Element.all;
1503                   J : constant Hash_Type := Hash (E) mod Buckets'Length;
1504
1505                begin
1506                   declare
1507                      X : Element_Access := new Element_Type'(E);
1508                   begin
1509                      Buckets (J) := new Node_Type'(X, Buckets (J));
1510                   exception
1511                      when others =>
1512                         Free_Element (X);
1513                         raise;
1514                   end;
1515
1516                   Length := Length + 1;
1517                end;
1518             end if;
1519          end Process;
1520
1521       --  Start of processing for Iterate_Left
1522
1523       begin
1524          Iterate (Left.HT);
1525       exception
1526          when others =>
1527             HT_Ops.Free_Hash_Table (Buckets);
1528             raise;
1529       end Iterate_Left;
1530
1531       Iterate_Right : declare
1532          procedure Process (R_Node : Node_Access);
1533
1534          procedure Iterate is
1535             new HT_Ops.Generic_Iteration (Process);
1536
1537          -------------
1538          -- Process --
1539          -------------
1540
1541          procedure Process (R_Node : Node_Access) is
1542          begin
1543             if not Is_In (Left.HT, R_Node) then
1544                declare
1545                   E : Element_Type renames R_Node.Element.all;
1546                   J : constant Hash_Type := Hash (E) mod Buckets'Length;
1547
1548                begin
1549                   declare
1550                      X : Element_Access := new Element_Type'(E);
1551                   begin
1552                      Buckets (J) := new Node_Type'(X, Buckets (J));
1553                   exception
1554                      when others =>
1555                         Free_Element (X);
1556                         raise;
1557                   end;
1558
1559                   Length := Length + 1;
1560                end;
1561             end if;
1562          end Process;
1563
1564       --  Start of processing for Iterate_Right
1565
1566       begin
1567          Iterate (Right.HT);
1568       exception
1569          when others =>
1570             HT_Ops.Free_Hash_Table (Buckets);
1571             raise;
1572       end Iterate_Right;
1573
1574       return (Controlled with HT => (Buckets, Length, 0, 0));
1575    end Symmetric_Difference;
1576
1577    ------------
1578    -- To_Set --
1579    ------------
1580
1581    function To_Set (New_Item : Element_Type) return Set is
1582       HT       : Hash_Table_Type;
1583       Node     : Node_Access;
1584       Inserted : Boolean;
1585       pragma Unreferenced (Node, Inserted);
1586    begin
1587       Insert (HT, New_Item, Node, Inserted);
1588       return Set'(Controlled with HT);
1589    end To_Set;
1590
1591    -----------
1592    -- Union --
1593    -----------
1594
1595    procedure Union
1596      (Target : in out Set;
1597       Source : Set)
1598    is
1599       procedure Process (Src_Node : Node_Access);
1600
1601       procedure Iterate is
1602          new HT_Ops.Generic_Iteration (Process);
1603
1604       -------------
1605       -- Process --
1606       -------------
1607
1608       procedure Process (Src_Node : Node_Access) is
1609          Src : Element_Type renames Src_Node.Element.all;
1610
1611          function New_Node (Next : Node_Access) return Node_Access;
1612          pragma Inline (New_Node);
1613
1614          procedure Insert is
1615             new Element_Keys.Generic_Conditional_Insert (New_Node);
1616
1617          --------------
1618          -- New_Node --
1619          --------------
1620
1621          function New_Node (Next : Node_Access) return Node_Access is
1622             Tgt : Element_Access := new Element_Type'(Src);
1623          begin
1624             return new Node_Type'(Tgt, Next);
1625          exception
1626             when others =>
1627                Free_Element (Tgt);
1628                raise;
1629          end New_Node;
1630
1631          Tgt_Node : Node_Access;
1632          Success  : Boolean;
1633          pragma Unreferenced (Tgt_Node, Success);
1634
1635       --  Start of processing for Process
1636
1637       begin
1638          Insert (Target.HT, Src, Tgt_Node, Success);
1639       end Process;
1640
1641    --  Start of processing for Union
1642
1643    begin
1644       if Target'Address = Source'Address then
1645          return;
1646       end if;
1647
1648       if Target.HT.Busy > 0 then
1649          raise Program_Error with
1650            "attempt to tamper with cursors (set is busy)";
1651       end if;
1652
1653       declare
1654          N : constant Count_Type := Target.Length + Source.Length;
1655       begin
1656          if N > HT_Ops.Capacity (Target.HT) then
1657             HT_Ops.Reserve_Capacity (Target.HT, N);
1658          end if;
1659       end;
1660
1661       Iterate (Source.HT);
1662    end Union;
1663
1664    function Union (Left, Right : Set) return Set is
1665       Buckets : HT_Types.Buckets_Access;
1666       Length  : Count_Type;
1667
1668    begin
1669       if Left'Address = Right'Address then
1670          return Left;
1671       end if;
1672
1673       if Right.Length = 0 then
1674          return Left;
1675       end if;
1676
1677       if Left.Length = 0 then
1678          return Right;
1679       end if;
1680
1681       declare
1682          Size : constant Hash_Type :=
1683                   Prime_Numbers.To_Prime (Left.Length + Right.Length);
1684       begin
1685          Buckets := HT_Ops.New_Buckets (Length => Size);
1686       end;
1687
1688       Iterate_Left : declare
1689          procedure Process (L_Node : Node_Access);
1690
1691          procedure Iterate is
1692             new HT_Ops.Generic_Iteration (Process);
1693
1694          -------------
1695          -- Process --
1696          -------------
1697
1698          procedure Process (L_Node : Node_Access) is
1699             Src    : Element_Type renames L_Node.Element.all;
1700             J      : constant Hash_Type := Hash (Src) mod Buckets'Length;
1701             Bucket : Node_Access renames Buckets (J);
1702             Tgt    : Element_Access := new Element_Type'(Src);
1703          begin
1704             Bucket := new Node_Type'(Tgt, Bucket);
1705          exception
1706             when others =>
1707                Free_Element (Tgt);
1708                raise;
1709          end Process;
1710
1711       --  Start of processing for Process
1712
1713       begin
1714          Iterate (Left.HT);
1715       exception
1716          when others =>
1717             HT_Ops.Free_Hash_Table (Buckets);
1718             raise;
1719       end Iterate_Left;
1720
1721       Length := Left.Length;
1722
1723       Iterate_Right : declare
1724          procedure Process (Src_Node : Node_Access);
1725
1726          procedure Iterate is
1727             new HT_Ops.Generic_Iteration (Process);
1728
1729          -------------
1730          -- Process --
1731          -------------
1732
1733          procedure Process (Src_Node : Node_Access) is
1734             Src : Element_Type renames Src_Node.Element.all;
1735             Idx : constant Hash_Type := Hash (Src) mod Buckets'Length;
1736
1737             Tgt_Node : Node_Access := Buckets (Idx);
1738
1739          begin
1740             while Tgt_Node /= null loop
1741                if Equivalent_Elements (Src, Tgt_Node.Element.all) then
1742                   return;
1743                end if;
1744                Tgt_Node := Next (Tgt_Node);
1745             end loop;
1746
1747             declare
1748                Tgt : Element_Access := new Element_Type'(Src);
1749             begin
1750                Buckets (Idx) := new Node_Type'(Tgt, Buckets (Idx));
1751             exception
1752                when others =>
1753                   Free_Element (Tgt);
1754                   raise;
1755             end;
1756
1757             Length := Length + 1;
1758          end Process;
1759
1760       --  Start of processing for Iterate_Right
1761
1762       begin
1763          Iterate (Right.HT);
1764       exception
1765          when others =>
1766             HT_Ops.Free_Hash_Table (Buckets);
1767             raise;
1768       end Iterate_Right;
1769
1770       return (Controlled with HT => (Buckets, Length, 0, 0));
1771    end Union;
1772
1773    ---------
1774    -- Vet --
1775    ---------
1776
1777    function Vet (Position : Cursor) return Boolean is
1778    begin
1779       if Position.Node = null then
1780          return Position.Container = null;
1781       end if;
1782
1783       if Position.Container = null then
1784          return False;
1785       end if;
1786
1787       if Position.Node.Next = Position.Node then
1788          return False;
1789       end if;
1790
1791       if Position.Node.Element = null then
1792          return False;
1793       end if;
1794
1795       declare
1796          HT : Hash_Table_Type renames Position.Container.HT;
1797          X  : Node_Access;
1798
1799       begin
1800          if HT.Length = 0 then
1801             return False;
1802          end if;
1803
1804          if HT.Buckets = null
1805            or else HT.Buckets'Length = 0
1806          then
1807             return False;
1808          end if;
1809
1810          X := HT.Buckets (Element_Keys.Index (HT, Position.Node.Element.all));
1811
1812          for J in 1 .. HT.Length loop
1813             if X = Position.Node then
1814                return True;
1815             end if;
1816
1817             if X = null then
1818                return False;
1819             end if;
1820
1821             if X = X.Next then  --  to prevent unnecessary looping
1822                return False;
1823             end if;
1824
1825             X := X.Next;
1826          end loop;
1827
1828          return False;
1829       end;
1830    end Vet;
1831
1832    -----------
1833    -- Write --
1834    -----------
1835
1836    procedure Write
1837      (Stream    : not null access Root_Stream_Type'Class;
1838       Container : Set)
1839    is
1840    begin
1841       Write_Nodes (Stream, Container.HT);
1842    end Write;
1843
1844    procedure Write
1845      (Stream : not null access Root_Stream_Type'Class;
1846       Item   : Cursor)
1847    is
1848    begin
1849       raise Program_Error with "attempt to stream set cursor";
1850    end Write;
1851
1852    procedure Write
1853      (Stream : not null access Root_Stream_Type'Class;
1854       Item   : Constant_Reference_Type)
1855    is
1856    begin
1857       raise Program_Error with "attempt to stream reference";
1858    end Write;
1859
1860    ----------------
1861    -- Write_Node --
1862    ----------------
1863
1864    procedure Write_Node
1865      (Stream : not null access Root_Stream_Type'Class;
1866       Node   : Node_Access)
1867    is
1868    begin
1869       Element_Type'Output (Stream, Node.Element.all);
1870    end Write_Node;
1871
1872    package body Generic_Keys is
1873
1874       -----------------------
1875       -- Local Subprograms --
1876       -----------------------
1877
1878       function Equivalent_Key_Node
1879         (Key  : Key_Type;
1880          Node : Node_Access) return Boolean;
1881       pragma Inline (Equivalent_Key_Node);
1882
1883       --------------------------
1884       -- Local Instantiations --
1885       --------------------------
1886
1887       package Key_Keys is
1888          new Hash_Tables.Generic_Keys
1889           (HT_Types  => HT_Types,
1890            Next      => Next,
1891            Set_Next  => Set_Next,
1892            Key_Type  => Key_Type,
1893            Hash      => Hash,
1894            Equivalent_Keys => Equivalent_Key_Node);
1895
1896       --------------
1897       -- Contains --
1898       --------------
1899
1900       function Contains
1901         (Container : Set;
1902          Key       : Key_Type) return Boolean
1903       is
1904       begin
1905          return Find (Container, Key) /= No_Element;
1906       end Contains;
1907
1908       ------------
1909       -- Delete --
1910       ------------
1911
1912       procedure Delete
1913         (Container : in out Set;
1914          Key       : Key_Type)
1915       is
1916          X : Node_Access;
1917
1918       begin
1919          Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X);
1920
1921          if X = null then
1922             raise Constraint_Error with "key not in map";  --  ??? "set"
1923          end if;
1924
1925          Free (X);
1926       end Delete;
1927
1928       -------------
1929       -- Element --
1930       -------------
1931
1932       function Element
1933         (Container : Set;
1934          Key       : Key_Type) return Element_Type
1935       is
1936          Node : constant Node_Access := Key_Keys.Find (Container.HT, Key);
1937
1938       begin
1939          if Node = null then
1940             raise Constraint_Error with "key not in map";  --  ??? "set"
1941          end if;
1942
1943          return Node.Element.all;
1944       end Element;
1945
1946       -------------------------
1947       -- Equivalent_Key_Node --
1948       -------------------------
1949
1950       function Equivalent_Key_Node
1951         (Key  : Key_Type;
1952          Node : Node_Access) return Boolean is
1953       begin
1954          return Equivalent_Keys (Key, Generic_Keys.Key (Node.Element.all));
1955       end Equivalent_Key_Node;
1956
1957       -------------
1958       -- Exclude --
1959       -------------
1960
1961       procedure Exclude
1962         (Container : in out Set;
1963          Key       : Key_Type)
1964       is
1965          X : Node_Access;
1966       begin
1967          Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X);
1968          Free (X);
1969       end Exclude;
1970
1971       ----------
1972       -- Find --
1973       ----------
1974
1975       function Find
1976         (Container : Set;
1977          Key       : Key_Type) return Cursor
1978       is
1979          Node : constant Node_Access := Key_Keys.Find (Container.HT, Key);
1980       begin
1981          return (if Node = null then No_Element
1982                  else Cursor'(Container'Unrestricted_Access, Node));
1983       end Find;
1984
1985       ---------
1986       -- Key --
1987       ---------
1988
1989       function Key (Position : Cursor) return Key_Type is
1990       begin
1991          if Position.Node = null then
1992             raise Constraint_Error with
1993               "Position cursor equals No_Element";
1994          end if;
1995
1996          if Position.Node.Element = null then
1997             raise Program_Error with "Position cursor is bad";
1998          end if;
1999
2000          pragma Assert (Vet (Position), "bad cursor in function Key");
2001
2002          return Key (Position.Node.Element.all);
2003       end Key;
2004
2005       -------------
2006       -- Replace --
2007       -------------
2008
2009       procedure Replace
2010         (Container : in out Set;
2011          Key       : Key_Type;
2012          New_Item  : Element_Type)
2013       is
2014          Node : constant Node_Access :=
2015                   Key_Keys.Find (Container.HT, Key);
2016
2017       begin
2018          if Node = null then
2019             raise Constraint_Error with
2020               "attempt to replace key not in set";
2021          end if;
2022
2023          Replace_Element (Container.HT, Node, New_Item);
2024       end Replace;
2025
2026       procedure Update_Element_Preserving_Key
2027         (Container : in out Set;
2028          Position  : Cursor;
2029          Process   : not null access
2030            procedure (Element : in out Element_Type))
2031       is
2032          HT   : Hash_Table_Type renames Container.HT;
2033          Indx : Hash_Type;
2034
2035       begin
2036          if Position.Node = null then
2037             raise Constraint_Error with
2038               "Position cursor equals No_Element";
2039          end if;
2040
2041          if Position.Node.Element = null
2042            or else Position.Node.Next = Position.Node
2043          then
2044             raise Program_Error with "Position cursor is bad";
2045          end if;
2046
2047          if Position.Container /= Container'Unrestricted_Access then
2048             raise Program_Error with
2049               "Position cursor designates wrong set";
2050          end if;
2051
2052          if HT.Buckets = null
2053            or else HT.Buckets'Length = 0
2054            or else HT.Length = 0
2055          then
2056             raise Program_Error with "Position cursor is bad (set is empty)";
2057          end if;
2058
2059          pragma Assert
2060            (Vet (Position),
2061             "bad cursor in Update_Element_Preserving_Key");
2062
2063          Indx := HT_Ops.Index (HT, Position.Node);
2064
2065          declare
2066             E : Element_Type renames Position.Node.Element.all;
2067             K : constant Key_Type := Key (E);
2068
2069             B : Natural renames HT.Busy;
2070             L : Natural renames HT.Lock;
2071
2072          begin
2073             B := B + 1;
2074             L := L + 1;
2075
2076             begin
2077                Process (E);
2078             exception
2079                when others =>
2080                   L := L - 1;
2081                   B := B - 1;
2082                   raise;
2083             end;
2084
2085             L := L - 1;
2086             B := B - 1;
2087
2088             if Equivalent_Keys (K, Key (E)) then
2089                pragma Assert (Hash (K) = Hash (E));
2090                return;
2091             end if;
2092          end;
2093
2094          if HT.Buckets (Indx) = Position.Node then
2095             HT.Buckets (Indx) := Position.Node.Next;
2096
2097          else
2098             declare
2099                Prev : Node_Access := HT.Buckets (Indx);
2100
2101             begin
2102                while Prev.Next /= Position.Node loop
2103                   Prev := Prev.Next;
2104
2105                   if Prev = null then
2106                      raise Program_Error with
2107                        "Position cursor is bad (node not found)";
2108                   end if;
2109                end loop;
2110
2111                Prev.Next := Position.Node.Next;
2112             end;
2113          end if;
2114
2115          HT.Length := HT.Length - 1;
2116
2117          declare
2118             X : Node_Access := Position.Node;
2119
2120          begin
2121             Free (X);
2122          end;
2123
2124          raise Program_Error with "key was modified";
2125       end Update_Element_Preserving_Key;
2126
2127       ------------------------------
2128       -- Reference_Preserving_Key --
2129       ------------------------------
2130
2131       function Reference_Preserving_Key
2132         (Container : aliased in out Set;
2133          Position  : Cursor) return Reference_Type
2134       is
2135          pragma Unreferenced (Container);
2136       begin
2137          return (Element => Position.Node.Element.all'Access);
2138       end Reference_Preserving_Key;
2139
2140       function Reference_Preserving_Key
2141         (Container : aliased in out Set;
2142          Key       : Key_Type) return Reference_Type
2143       is
2144          Position : constant Cursor := Find (Container, Key);
2145       begin
2146          return (Element => Position.Node.Element.all'Access);
2147       end Reference_Preserving_Key;
2148
2149    end Generic_Keys;
2150
2151 end Ada.Containers.Indefinite_Hashed_Sets;