gcc/ada/a-cihase.adb

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