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