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 -- 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 := new Buckets_Type (0 .. Size - 1);
 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       Inserted : Boolean;
 707
 708    begin
 709       Insert (Container, New_Item, Position, Inserted);
 710
 711       if not Inserted then
 712          raise Constraint_Error with
 713            "attempt to insert element already in set";
 714       end if;
 715    end Insert;
 716
 717    procedure Insert
 718      (HT       : in out Hash_Table_Type;
 719       New_Item : Element_Type;
 720       Node     : out Node_Access;
 721       Inserted : out Boolean)
 722    is
 723       function New_Node (Next : Node_Access) return Node_Access;
 724       pragma Inline (New_Node);
 725
 726       procedure Local_Insert is
 727          new Element_Keys.Generic_Conditional_Insert (New_Node);
 728
 729       --------------
 730       -- New_Node --
 731       --------------
 732
 733       function New_Node (Next : Node_Access) return Node_Access is
 734          Element : Element_Access := new Element_Type'(New_Item);
 735
 736       begin
 737          return new Node_Type'(Element, Next);
 738       exception
 739          when others =>
 740             Free_Element (Element);
 741             raise;
 742       end New_Node;
 743
 744    --  Start of processing for Insert
 745
 746    begin
 747       if HT_Ops.Capacity (HT) = 0 then
 748          HT_Ops.Reserve_Capacity (HT, 1);
 749       end if;
 750
 751       Local_Insert (HT, New_Item, Node, Inserted);
 752
 753       if Inserted
 754         and then HT.Length > HT_Ops.Capacity (HT)
 755       then
 756          HT_Ops.Reserve_Capacity (HT, HT.Length);
 757       end if;
 758    end Insert;
 759
 760    ------------------
 761    -- Intersection --
 762    ------------------
 763
 764    procedure Intersection
 765      (Target : in out Set;
 766       Source : Set)
 767    is
 768       Tgt_Node : Node_Access;
 769
 770    begin
 771       if Target'Address = Source'Address then
 772          return;
 773       end if;
 774
 775       if Source.Length = 0 then
 776          Clear (Target);
 777          return;
 778       end if;
 779
 780       if Target.HT.Busy > 0 then
 781          raise Program_Error with
 782            "attempt to tamper with elements (set is busy)";
 783       end if;
 784
 785       Tgt_Node := HT_Ops.First (Target.HT);
 786       while Tgt_Node /= null loop
 787          if Is_In (Source.HT, Tgt_Node) then
 788             Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
 789
 790          else
 791             declare
 792                X : Node_Access := Tgt_Node;
 793             begin
 794                Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
 795                HT_Ops.Delete_Node_Sans_Free (Target.HT, X);
 796                Free (X);
 797             end;
 798          end if;
 799       end loop;
 800    end Intersection;
 801
 802    function Intersection (Left, Right : Set) return Set is
 803       Buckets : HT_Types.Buckets_Access;
 804       Length  : Count_Type;
 805
 806    begin
 807       if Left'Address = Right'Address then
 808          return Left;
 809       end if;
 810
 811       Length := Count_Type'Min (Left.Length, Right.Length);
 812
 813       if Length = 0 then
 814          return Empty_Set;
 815       end if;
 816
 817       declare
 818          Size : constant Hash_Type := Prime_Numbers.To_Prime (Length);
 819       begin
 820          Buckets := new Buckets_Type (0 .. Size - 1);
 821       end;
 822
 823       Length := 0;
 824
 825       Iterate_Left : declare
 826          procedure Process (L_Node : Node_Access);
 827
 828          procedure Iterate is
 829             new HT_Ops.Generic_Iteration (Process);
 830
 831          -------------
 832          -- Process --
 833          -------------
 834
 835          procedure Process (L_Node : Node_Access) is
 836          begin
 837             if Is_In (Right.HT, L_Node) then
 838                declare
 839                   Src : Element_Type renames L_Node.Element.all;
 840
 841                   Indx : constant Hash_Type := Hash (Src) mod Buckets'Length;
 842
 843                   Bucket : Node_Access renames Buckets (Indx);
 844
 845                   Tgt : Element_Access := new Element_Type'(Src);
 846
 847                begin
 848                   Bucket := new Node_Type'(Tgt, Bucket);
 849                exception
 850                   when others =>
 851                      Free_Element (Tgt);
 852                      raise;
 853                end;
 854
 855                Length := Length + 1;
 856             end if;
 857          end Process;
 858
 859       --  Start of processing for Iterate_Left
 860
 861       begin
 862          Iterate (Left.HT);
 863       exception
 864          when others =>
 865             HT_Ops.Free_Hash_Table (Buckets);
 866             raise;
 867       end Iterate_Left;
 868
 869       return (Controlled with HT => (Buckets, Length, 0, 0));
 870    end Intersection;
 871
 872    --------------
 873    -- Is_Empty --
 874    --------------
 875
 876    function Is_Empty (Container : Set) return Boolean is
 877    begin
 878       return Container.HT.Length = 0;
 879    end Is_Empty;
 880
 881    -----------
 882    -- Is_In --
 883    -----------
 884
 885    function Is_In (HT  : Hash_Table_Type; Key : Node_Access) return Boolean is
 886    begin
 887       return Element_Keys.Find (HT, Key.Element.all) /= null;
 888    end Is_In;
 889
 890    ---------------
 891    -- Is_Subset --
 892    ---------------
 893
 894    function Is_Subset
 895      (Subset : Set;
 896       Of_Set : Set) return Boolean
 897    is
 898       Subset_Node : Node_Access;
 899
 900    begin
 901       if Subset'Address = Of_Set'Address then
 902          return True;
 903       end if;
 904
 905       if Subset.Length > Of_Set.Length then
 906          return False;
 907       end if;
 908
 909       Subset_Node := HT_Ops.First (Subset.HT);
 910       while Subset_Node /= null loop
 911          if not Is_In (Of_Set.HT, Subset_Node) then
 912             return False;
 913          end if;
 914
 915          Subset_Node := HT_Ops.Next (Subset.HT, Subset_Node);
 916       end loop;
 917
 918       return True;
 919    end Is_Subset;
 920
 921    -------------
 922    -- Iterate --
 923    -------------
 924
 925    procedure Iterate
 926      (Container : Set;
 927       Process   : not null access procedure (Position : Cursor))
 928    is
 929       procedure Process_Node (Node : Node_Access);
 930       pragma Inline (Process_Node);
 931
 932       procedure Iterate is
 933          new HT_Ops.Generic_Iteration (Process_Node);
 934
 935       ------------------
 936       -- Process_Node --
 937       ------------------
 938
 939       procedure Process_Node (Node : Node_Access) is
 940       begin
 941          Process (Cursor'(Container'Unrestricted_Access, Node));
 942       end Process_Node;
 943
 944       B : Natural renames Container'Unrestricted_Access.HT.Busy;
 945
 946    --  Start of processing for Iterate
 947
 948    begin
 949       B := B + 1;
 950
 951       begin
 952          Iterate (Container.HT);
 953       exception
 954          when others =>
 955             B := B - 1;
 956             raise;
 957       end;
 958
 959       B := B - 1;
 960    end Iterate;
 961
 962    ------------
 963    -- Length --
 964    ------------
 965
 966    function Length (Container : Set) return Count_Type is
 967    begin
 968       return Container.HT.Length;
 969    end Length;
 970
 971    ----------
 972    -- Move --
 973    ----------
 974
 975    procedure Move (Target : in out Set; Source : in out Set) is
 976    begin
 977       HT_Ops.Move (Target => Target.HT, Source => Source.HT);
 978    end Move;
 979
 980    ----------
 981    -- Next --
 982    ----------
 983
 984    function Next (Node : Node_Access) return Node_Access is
 985    begin
 986       return Node.Next;
 987    end Next;
 988
 989    function Next (Position : Cursor) return Cursor is
 990    begin
 991       if Position.Node = null then
 992          return No_Element;
 993       end if;
 994
 995       if Position.Node.Element = null then
 996          raise Program_Error with "bad cursor in Next";
 997       end if;
 998
 999       pragma Assert (Vet (Position), "bad cursor in Next");
1000
1001       declare
1002          HT   : Hash_Table_Type renames Position.Container.HT;
1003          Node : constant Node_Access := HT_Ops.Next (HT, Position.Node);
1004
1005       begin
1006          if Node = null then
1007             return No_Element;
1008          end if;
1009
1010          return Cursor'(Position.Container, Node);
1011       end;
1012    end Next;
1013
1014    procedure Next (Position : in out Cursor) is
1015    begin
1016       Position := Next (Position);
1017    end Next;
1018
1019    -------------
1020    -- Overlap --
1021    -------------
1022
1023    function Overlap (Left, Right : Set) return Boolean is
1024       Left_Node : Node_Access;
1025
1026    begin
1027       if Right.Length = 0 then
1028          return False;
1029       end if;
1030
1031       if Left'Address = Right'Address then
1032          return True;
1033       end if;
1034
1035       Left_Node := HT_Ops.First (Left.HT);
1036       while Left_Node /= null loop
1037          if Is_In (Right.HT, Left_Node) then
1038             return True;
1039          end if;
1040
1041          Left_Node := HT_Ops.Next (Left.HT, Left_Node);
1042       end loop;
1043
1044       return False;
1045    end Overlap;
1046
1047    -------------------
1048    -- Query_Element --
1049    -------------------
1050
1051    procedure Query_Element
1052      (Position : Cursor;
1053       Process  : not null access procedure (Element : Element_Type))
1054    is
1055    begin
1056       if Position.Node = null then
1057          raise Constraint_Error with
1058            "Position cursor of Query_Element equals No_Element";
1059       end if;
1060
1061       if Position.Node.Element = null then
1062          raise Program_Error with "bad cursor in Query_Element";
1063       end if;
1064
1065       pragma Assert (Vet (Position), "bad cursor in Query_Element");
1066
1067       declare
1068          HT : Hash_Table_Type renames
1069                 Position.Container'Unrestricted_Access.all.HT;
1070
1071          B : Natural renames HT.Busy;
1072          L : Natural renames HT.Lock;
1073
1074       begin
1075          B := B + 1;
1076          L := L + 1;
1077
1078          begin
1079             Process (Position.Node.Element.all);
1080          exception
1081             when others =>
1082                L := L - 1;
1083                B := B - 1;
1084                raise;
1085          end;
1086
1087          L := L - 1;
1088          B := B - 1;
1089       end;
1090    end Query_Element;
1091
1092    ----------
1093    -- Read --
1094    ----------
1095
1096    procedure Read
1097      (Stream    : not null access Root_Stream_Type'Class;
1098       Container : out Set)
1099    is
1100    begin
1101       Read_Nodes (Stream, Container.HT);
1102    end Read;
1103
1104    procedure Read
1105      (Stream : not null access Root_Stream_Type'Class;
1106       Item   : out Cursor)
1107    is
1108    begin
1109       raise Program_Error with "attempt to stream set cursor";
1110    end Read;
1111
1112    ---------------
1113    -- Read_Node --
1114    ---------------
1115
1116    function Read_Node
1117      (Stream : not null access Root_Stream_Type'Class) return Node_Access
1118    is
1119       X : Element_Access := new Element_Type'(Element_Type'Input (Stream));
1120
1121    begin
1122       return new Node_Type'(X, null);
1123    exception
1124       when others =>
1125          Free_Element (X);
1126          raise;
1127    end Read_Node;
1128
1129    -------------
1130    -- Replace --
1131    -------------
1132
1133    procedure Replace
1134      (Container : in out Set;
1135       New_Item  : Element_Type)
1136    is
1137       Node : constant Node_Access :=
1138                Element_Keys.Find (Container.HT, New_Item);
1139
1140       X : Element_Access;
1141
1142    begin
1143       if Node = null then
1144          raise Constraint_Error with
1145            "attempt to replace element not in set";
1146       end if;
1147
1148       if Container.HT.Lock > 0 then
1149          raise Program_Error with
1150            "attempt to tamper with cursors (set is locked)";
1151       end if;
1152
1153       X := Node.Element;
1154
1155       Node.Element := new Element_Type'(New_Item);
1156
1157       Free_Element (X);
1158    end Replace;
1159
1160    ---------------------
1161    -- Replace_Element --
1162    ---------------------
1163
1164    procedure Replace_Element
1165      (Container : in out Set;
1166       Position  : Cursor;
1167       New_Item  : Element_Type)
1168    is
1169    begin
1170       if Position.Node = null then
1171          raise Constraint_Error with "Position cursor equals No_Element";
1172       end if;
1173
1174       if Position.Node.Element = null then
1175          raise Program_Error with "bad cursor in Replace_Element";
1176       end if;
1177
1178       if Position.Container /= Container'Unrestricted_Access then
1179          raise Program_Error with
1180            "Position cursor designates wrong set";
1181       end if;
1182
1183       pragma Assert (Vet (Position), "bad cursor in Replace_Element");
1184
1185       Replace_Element (Container.HT, Position.Node, New_Item);
1186    end Replace_Element;
1187
1188    ----------------------
1189    -- Reserve_Capacity --
1190    ----------------------
1191
1192    procedure Reserve_Capacity
1193      (Container : in out Set;
1194       Capacity  : Count_Type)
1195    is
1196    begin
1197       HT_Ops.Reserve_Capacity (Container.HT, Capacity);
1198    end Reserve_Capacity;
1199
1200    --------------
1201    -- Set_Next --
1202    --------------
1203
1204    procedure Set_Next (Node : Node_Access; Next : Node_Access) is
1205    begin
1206       Node.Next := Next;
1207    end Set_Next;
1208
1209    --------------------------
1210    -- Symmetric_Difference --
1211    --------------------------
1212
1213    procedure Symmetric_Difference
1214      (Target : in out Set;
1215       Source : Set)
1216    is
1217    begin
1218       if Target'Address = Source'Address then
1219          Clear (Target);
1220          return;
1221       end if;
1222
1223       if Target.HT.Busy > 0 then
1224          raise Program_Error with
1225            "attempt to tamper with elements (set is busy)";
1226       end if;
1227
1228       declare
1229          N : constant Count_Type := Target.Length + Source.Length;
1230       begin
1231          if N > HT_Ops.Capacity (Target.HT) then
1232             HT_Ops.Reserve_Capacity (Target.HT, N);
1233          end if;
1234       end;
1235
1236       if Target.Length = 0 then
1237          Iterate_Source_When_Empty_Target : declare
1238             procedure Process (Src_Node : Node_Access);
1239
1240             procedure Iterate is
1241                new HT_Ops.Generic_Iteration (Process);
1242
1243             -------------
1244             -- Process --
1245             -------------
1246
1247             procedure Process (Src_Node : Node_Access) is
1248                E : Element_Type renames Src_Node.Element.all;
1249                B : Buckets_Type renames Target.HT.Buckets.all;
1250                J : constant Hash_Type := Hash (E) mod B'Length;
1251                N : Count_Type renames Target.HT.Length;
1252
1253             begin
1254                declare
1255                   X : Element_Access := new Element_Type'(E);
1256                begin
1257                   B (J) := new Node_Type'(X, B (J));
1258                exception
1259                   when others =>
1260                      Free_Element (X);
1261                      raise;
1262                end;
1263
1264                N := N + 1;
1265             end Process;
1266
1267          --  Start of processing for Iterate_Source_When_Empty_Target
1268
1269          begin
1270             Iterate (Source.HT);
1271          end Iterate_Source_When_Empty_Target;
1272
1273       else
1274          Iterate_Source : declare
1275             procedure Process (Src_Node : Node_Access);
1276
1277             procedure Iterate is
1278                new HT_Ops.Generic_Iteration (Process);
1279
1280             -------------
1281             -- Process --
1282             -------------
1283
1284             procedure Process (Src_Node : Node_Access) is
1285                E : Element_Type renames Src_Node.Element.all;
1286                B : Buckets_Type renames Target.HT.Buckets.all;
1287                J : constant Hash_Type := Hash (E) mod B'Length;
1288                N : Count_Type renames Target.HT.Length;
1289
1290             begin
1291                if B (J) = null then
1292                   declare
1293                      X : Element_Access := new Element_Type'(E);
1294                   begin
1295                      B (J) := new Node_Type'(X, null);
1296                   exception
1297                      when others =>
1298                         Free_Element (X);
1299                         raise;
1300                   end;
1301
1302                   N := N + 1;
1303
1304                elsif Equivalent_Elements (E, B (J).Element.all) then
1305                   declare
1306                      X : Node_Access := B (J);
1307                   begin
1308                      B (J) := B (J).Next;
1309                      N := N - 1;
1310                      Free (X);
1311                   end;
1312
1313                else
1314                   declare
1315                      Prev : Node_Access := B (J);
1316                      Curr : Node_Access := Prev.Next;
1317
1318                   begin
1319                      while Curr /= null loop
1320                         if Equivalent_Elements (E, Curr.Element.all) then
1321                            Prev.Next := Curr.Next;
1322                            N := N - 1;
1323                            Free (Curr);
1324                            return;
1325                         end if;
1326
1327                         Prev := Curr;
1328                         Curr := Prev.Next;
1329                      end loop;
1330
1331                      declare
1332                         X : Element_Access := new Element_Type'(E);
1333                      begin
1334                         B (J) := new Node_Type'(X, B (J));
1335                      exception
1336                         when others =>
1337                            Free_Element (X);
1338                            raise;
1339                      end;
1340
1341                      N := N + 1;
1342                   end;
1343                end if;
1344             end Process;
1345
1346          --  Start of processing for Iterate_Source
1347
1348          begin
1349             Iterate (Source.HT);
1350          end Iterate_Source;
1351       end if;
1352    end Symmetric_Difference;
1353
1354    function Symmetric_Difference (Left, Right : Set) return Set is
1355       Buckets : HT_Types.Buckets_Access;
1356       Length  : Count_Type;
1357
1358    begin
1359       if Left'Address = Right'Address then
1360          return Empty_Set;
1361       end if;
1362
1363       if Right.Length = 0 then
1364          return Left;
1365       end if;
1366
1367       if Left.Length = 0 then
1368          return Right;
1369       end if;
1370
1371       declare
1372          Size : constant Hash_Type :=
1373                   Prime_Numbers.To_Prime (Left.Length + Right.Length);
1374       begin
1375          Buckets := new Buckets_Type (0 .. Size - 1);
1376       end;
1377
1378       Length := 0;
1379
1380       Iterate_Left : declare
1381          procedure Process (L_Node : Node_Access);
1382
1383          procedure Iterate is
1384             new HT_Ops.Generic_Iteration (Process);
1385
1386          -------------
1387          -- Process --
1388          -------------
1389
1390          procedure Process (L_Node : Node_Access) is
1391          begin
1392             if not Is_In (Right.HT, L_Node) then
1393                declare
1394                   E : Element_Type renames L_Node.Element.all;
1395                   J : constant Hash_Type := Hash (E) mod Buckets'Length;
1396
1397                begin
1398                   declare
1399                      X : Element_Access := new Element_Type'(E);
1400                   begin
1401                      Buckets (J) := new Node_Type'(X, Buckets (J));
1402                   exception
1403                      when others =>
1404                         Free_Element (X);
1405                         raise;
1406                   end;
1407
1408                   Length := Length + 1;
1409                end;
1410             end if;
1411          end Process;
1412
1413       --  Start of processing for Iterate_Left
1414
1415       begin
1416          Iterate (Left.HT);
1417       exception
1418          when others =>
1419             HT_Ops.Free_Hash_Table (Buckets);
1420             raise;
1421       end Iterate_Left;
1422
1423       Iterate_Right : declare
1424          procedure Process (R_Node : Node_Access);
1425
1426          procedure Iterate is
1427             new HT_Ops.Generic_Iteration (Process);
1428
1429          -------------
1430          -- Process --
1431          -------------
1432
1433          procedure Process (R_Node : Node_Access) is
1434          begin
1435             if not Is_In (Left.HT, R_Node) then
1436                declare
1437                   E : Element_Type renames R_Node.Element.all;
1438                   J : constant Hash_Type := Hash (E) mod Buckets'Length;
1439
1440                begin
1441                   declare
1442                      X : Element_Access := new Element_Type'(E);
1443                   begin
1444                      Buckets (J) := new Node_Type'(X, Buckets (J));
1445                   exception
1446                      when others =>
1447                         Free_Element (X);
1448                         raise;
1449                   end;
1450
1451                   Length := Length + 1;
1452                end;
1453             end if;
1454          end Process;
1455
1456       --  Start of processing for Iterate_Right
1457
1458       begin
1459          Iterate (Right.HT);
1460       exception
1461          when others =>
1462             HT_Ops.Free_Hash_Table (Buckets);
1463             raise;
1464       end Iterate_Right;
1465
1466       return (Controlled with HT => (Buckets, Length, 0, 0));
1467    end Symmetric_Difference;
1468
1469    ------------
1470    -- To_Set --
1471    ------------
1472
1473    function To_Set (New_Item : Element_Type) return Set is
1474       HT       : Hash_Table_Type;
1475       Node     : Node_Access;
1476       Inserted : Boolean;
1477
1478    begin
1479       Insert (HT, New_Item, Node, Inserted);
1480       return Set'(Controlled with HT);
1481    end To_Set;
1482
1483    -----------
1484    -- Union --
1485    -----------
1486
1487    procedure Union
1488      (Target : in out Set;
1489       Source : Set)
1490    is
1491       procedure Process (Src_Node : Node_Access);
1492
1493       procedure Iterate is
1494          new HT_Ops.Generic_Iteration (Process);
1495
1496       -------------
1497       -- Process --
1498       -------------
1499
1500       procedure Process (Src_Node : Node_Access) is
1501          Src : Element_Type renames Src_Node.Element.all;
1502
1503          function New_Node (Next : Node_Access) return Node_Access;
1504          pragma Inline (New_Node);
1505
1506          procedure Insert is
1507             new Element_Keys.Generic_Conditional_Insert (New_Node);
1508
1509          --------------
1510          -- New_Node --
1511          --------------
1512
1513          function New_Node (Next : Node_Access) return Node_Access is
1514             Tgt : Element_Access := new Element_Type'(Src);
1515
1516          begin
1517             return new Node_Type'(Tgt, Next);
1518          exception
1519             when others =>
1520                Free_Element (Tgt);
1521                raise;
1522          end New_Node;
1523
1524          Tgt_Node : Node_Access;
1525          Success  : Boolean;
1526
1527       --  Start of processing for Process
1528
1529       begin
1530          Insert (Target.HT, Src, Tgt_Node, Success);
1531       end Process;
1532
1533    --  Start of processing for Union
1534
1535    begin
1536       if Target'Address = Source'Address then
1537          return;
1538       end if;
1539
1540       if Target.HT.Busy > 0 then
1541          raise Program_Error with
1542            "attempt to tamper with elements (set is busy)";
1543       end if;
1544
1545       declare
1546          N : constant Count_Type := Target.Length + Source.Length;
1547       begin
1548          if N > HT_Ops.Capacity (Target.HT) then
1549             HT_Ops.Reserve_Capacity (Target.HT, N);
1550          end if;
1551       end;
1552
1553       Iterate (Source.HT);
1554    end Union;
1555
1556    function Union (Left, Right : Set) return Set is
1557       Buckets : HT_Types.Buckets_Access;
1558       Length  : Count_Type;
1559
1560    begin
1561       if Left'Address = Right'Address then
1562          return Left;
1563       end if;
1564
1565       if Right.Length = 0 then
1566          return Left;
1567       end if;
1568
1569       if Left.Length = 0 then
1570          return Right;
1571       end if;
1572
1573       declare
1574          Size : constant Hash_Type :=
1575                   Prime_Numbers.To_Prime (Left.Length + Right.Length);
1576       begin
1577          Buckets := new Buckets_Type (0 .. Size - 1);
1578       end;
1579
1580       Iterate_Left : declare
1581          procedure Process (L_Node : Node_Access);
1582
1583          procedure Iterate is
1584             new HT_Ops.Generic_Iteration (Process);
1585
1586          -------------
1587          -- Process --
1588          -------------
1589
1590          procedure Process (L_Node : Node_Access) is
1591             Src : Element_Type renames L_Node.Element.all;
1592
1593             J : constant Hash_Type := Hash (Src) mod Buckets'Length;
1594
1595             Bucket : Node_Access renames Buckets (J);
1596
1597             Tgt : Element_Access := new Element_Type'(Src);
1598
1599          begin
1600             Bucket := new Node_Type'(Tgt, Bucket);
1601          exception
1602             when others =>
1603                Free_Element (Tgt);
1604                raise;
1605          end Process;
1606
1607       --  Start of processing for Process
1608
1609       begin
1610          Iterate (Left.HT);
1611       exception
1612          when others =>
1613             HT_Ops.Free_Hash_Table (Buckets);
1614             raise;
1615       end Iterate_Left;
1616
1617       Length := Left.Length;
1618
1619       Iterate_Right : declare
1620          procedure Process (Src_Node : Node_Access);
1621
1622          procedure Iterate is
1623             new HT_Ops.Generic_Iteration (Process);
1624
1625          -------------
1626          -- Process --
1627          -------------
1628
1629          procedure Process (Src_Node : Node_Access) is
1630             Src : Element_Type renames Src_Node.Element.all;
1631             Idx : constant Hash_Type := Hash (Src) mod Buckets'Length;
1632
1633             Tgt_Node : Node_Access := Buckets (Idx);
1634
1635          begin
1636             while Tgt_Node /= null loop
1637                if Equivalent_Elements (Src, Tgt_Node.Element.all) then
1638                   return;
1639                end if;
1640                Tgt_Node := Next (Tgt_Node);
1641             end loop;
1642
1643             declare
1644                Tgt : Element_Access := new Element_Type'(Src);
1645             begin
1646                Buckets (Idx) := new Node_Type'(Tgt, Buckets (Idx));
1647             exception
1648                when others =>
1649                   Free_Element (Tgt);
1650                   raise;
1651             end;
1652
1653             Length := Length + 1;
1654          end Process;
1655
1656       --  Start of processing for Iterate_Right
1657
1658       begin
1659          Iterate (Right.HT);
1660       exception
1661          when others =>
1662             HT_Ops.Free_Hash_Table (Buckets);
1663             raise;
1664       end Iterate_Right;
1665
1666       return (Controlled with HT => (Buckets, Length, 0, 0));
1667    end Union;
1668
1669    ---------
1670    -- Vet --
1671    ---------
1672
1673    function Vet (Position : Cursor) return Boolean is
1674    begin
1675       if Position.Node = null then
1676          return Position.Container = null;
1677       end if;
1678
1679       if Position.Container = null then
1680          return False;
1681       end if;
1682
1683       if Position.Node.Next = Position.Node then
1684          return False;
1685       end if;
1686
1687       if Position.Node.Element = null then
1688          return False;
1689       end if;
1690
1691       declare
1692          HT : Hash_Table_Type renames Position.Container.HT;
1693          X  : Node_Access;
1694
1695       begin
1696          if HT.Length = 0 then
1697             return False;
1698          end if;
1699
1700          if HT.Buckets = null
1701            or else HT.Buckets'Length = 0
1702          then
1703             return False;
1704          end if;
1705
1706          X := HT.Buckets (Element_Keys.Index (HT, Position.Node.Element.all));
1707
1708          for J in 1 .. HT.Length loop
1709             if X = Position.Node then
1710                return True;
1711             end if;
1712
1713             if X = null then
1714                return False;
1715             end if;
1716
1717             if X = X.Next then  --  to prevent unnecessary looping
1718                return False;
1719             end if;
1720
1721             X := X.Next;
1722          end loop;
1723
1724          return False;
1725       end;
1726    end Vet;
1727
1728    -----------
1729    -- Write --
1730    -----------
1731
1732    procedure Write
1733      (Stream    : not null access Root_Stream_Type'Class;
1734       Container : Set)
1735    is
1736    begin
1737       Write_Nodes (Stream, Container.HT);
1738    end Write;
1739
1740    procedure Write
1741      (Stream : not null access Root_Stream_Type'Class;
1742       Item   : Cursor)
1743    is
1744    begin
1745       raise Program_Error with "attempt to stream set cursor";
1746    end Write;
1747
1748    ----------------
1749    -- Write_Node --
1750    ----------------
1751
1752    procedure Write_Node
1753      (Stream : not null access Root_Stream_Type'Class;
1754       Node   : Node_Access)
1755    is
1756    begin
1757       Element_Type'Output (Stream, Node.Element.all);
1758    end Write_Node;
1759
1760    package body Generic_Keys is
1761
1762       -----------------------
1763       -- Local Subprograms --
1764       -----------------------
1765
1766       function Equivalent_Key_Node
1767         (Key  : Key_Type;
1768          Node : Node_Access) return Boolean;
1769       pragma Inline (Equivalent_Key_Node);
1770
1771       --------------------------
1772       -- Local Instantiations --
1773       --------------------------
1774
1775       package Key_Keys is
1776          new Hash_Tables.Generic_Keys
1777           (HT_Types  => HT_Types,
1778            Next      => Next,
1779            Set_Next  => Set_Next,
1780            Key_Type  => Key_Type,
1781            Hash      => Hash,
1782            Equivalent_Keys => Equivalent_Key_Node);
1783
1784       --------------
1785       -- Contains --
1786       --------------
1787
1788       function Contains
1789         (Container : Set;
1790          Key       : Key_Type) return Boolean
1791       is
1792       begin
1793          return Find (Container, Key) /= No_Element;
1794       end Contains;
1795
1796       ------------
1797       -- Delete --
1798       ------------
1799
1800       procedure Delete
1801         (Container : in out Set;
1802          Key       : Key_Type)
1803       is
1804          X : Node_Access;
1805
1806       begin
1807          Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X);
1808
1809          if X = null then
1810             raise Constraint_Error with "key not in map";
1811          end if;
1812
1813          Free (X);
1814       end Delete;
1815
1816       -------------
1817       -- Element --
1818       -------------
1819
1820       function Element
1821         (Container : Set;
1822          Key       : Key_Type) return Element_Type
1823       is
1824          Node : constant Node_Access := Key_Keys.Find (Container.HT, Key);
1825
1826       begin
1827          if Node = null then
1828             raise Constraint_Error with "key not in map";
1829          end if;
1830
1831          return Node.Element.all;
1832       end Element;
1833
1834       -------------------------
1835       -- Equivalent_Key_Node --
1836       -------------------------
1837
1838       function Equivalent_Key_Node
1839         (Key  : Key_Type;
1840          Node : Node_Access) return Boolean is
1841       begin
1842          return Equivalent_Keys (Key, Generic_Keys.Key (Node.Element.all));
1843       end Equivalent_Key_Node;
1844
1845       -------------
1846       -- Exclude --
1847       -------------
1848
1849       procedure Exclude
1850         (Container : in out Set;
1851          Key       : Key_Type)
1852       is
1853          X : Node_Access;
1854       begin
1855          Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X);
1856          Free (X);
1857       end Exclude;
1858
1859       ----------
1860       -- Find --
1861       ----------
1862
1863       function Find
1864         (Container : Set;
1865          Key       : Key_Type) return Cursor
1866       is
1867          Node : constant Node_Access := Key_Keys.Find (Container.HT, Key);
1868
1869       begin
1870          if Node = null then
1871             return No_Element;
1872          end if;
1873
1874          return Cursor'(Container'Unrestricted_Access, Node);
1875       end Find;
1876
1877       ---------
1878       -- Key --
1879       ---------
1880
1881       function Key (Position : Cursor) return Key_Type is
1882       begin
1883          if Position.Node = null then
1884             raise Constraint_Error with
1885               "Position cursor equals No_Element";
1886          end if;
1887
1888          if Position.Node.Element = null then
1889             raise Program_Error with "Position cursor is bad";
1890          end if;
1891
1892          pragma Assert (Vet (Position), "bad cursor in function Key");
1893
1894          return Key (Position.Node.Element.all);
1895       end Key;
1896
1897       -------------
1898       -- Replace --
1899       -------------
1900
1901       procedure Replace
1902         (Container : in out Set;
1903          Key       : Key_Type;
1904          New_Item  : Element_Type)
1905       is
1906          Node : constant Node_Access :=
1907                   Key_Keys.Find (Container.HT, Key);
1908
1909       begin
1910          if Node = null then
1911             raise Constraint_Error with
1912               "attempt to replace key not in set";
1913          end if;
1914
1915          Replace_Element (Container.HT, Node, New_Item);
1916       end Replace;
1917
1918       procedure Update_Element_Preserving_Key
1919         (Container : in out Set;
1920          Position  : Cursor;
1921          Process   : not null access
1922            procedure (Element : in out Element_Type))
1923       is
1924          HT   : Hash_Table_Type renames Container.HT;
1925          Indx : Hash_Type;
1926
1927       begin
1928          if Position.Node = null then
1929             raise Constraint_Error with
1930               "Position cursor equals No_Element";
1931          end if;
1932
1933          if Position.Node.Element = null
1934            or else Position.Node.Next = Position.Node
1935          then
1936             raise Program_Error with "Position cursor is bad";
1937          end if;
1938
1939          if Position.Container /= Container'Unrestricted_Access then
1940             raise Program_Error with
1941               "Position cursor designates wrong set";
1942          end if;
1943
1944          if HT.Buckets = null
1945            or else HT.Buckets'Length = 0
1946            or else HT.Length = 0
1947          then
1948             raise Program_Error with "Position cursor is bad (set is empty)";
1949          end if;
1950
1951          pragma Assert
1952            (Vet (Position),
1953             "bad cursor in Update_Element_Preserving_Key");
1954
1955          Indx := HT_Ops.Index (HT, Position.Node);
1956
1957          declare
1958             E : Element_Type renames Position.Node.Element.all;
1959             K : constant Key_Type := Key (E);
1960
1961             B : Natural renames HT.Busy;
1962             L : Natural renames HT.Lock;
1963
1964          begin
1965             B := B + 1;
1966             L := L + 1;
1967
1968             begin
1969                Process (E);
1970             exception
1971                when others =>
1972                   L := L - 1;
1973                   B := B - 1;
1974                   raise;
1975             end;
1976
1977             L := L - 1;
1978             B := B - 1;
1979
1980             if Equivalent_Keys (K, Key (E)) then
1981                pragma Assert (Hash (K) = Hash (E));
1982                return;
1983             end if;
1984          end;
1985
1986          if HT.Buckets (Indx) = Position.Node then
1987             HT.Buckets (Indx) := Position.Node.Next;
1988
1989          else
1990             declare
1991                Prev : Node_Access := HT.Buckets (Indx);
1992
1993             begin
1994                while Prev.Next /= Position.Node loop
1995                   Prev := Prev.Next;
1996
1997                   if Prev = null then
1998                      raise Program_Error with
1999                        "Position cursor is bad (node not found)";
2000                   end if;
2001                end loop;
2002
2003                Prev.Next := Position.Node.Next;
2004             end;
2005          end if;
2006
2007          HT.Length := HT.Length - 1;
2008
2009          declare
2010             X : Node_Access := Position.Node;
2011
2012          begin
2013             Free (X);
2014          end;
2015
2016          raise Program_Error with "key was modified";
2017       end Update_Element_Preserving_Key;
2018
2019    end Generic_Keys;
2020
2021 end Ada.Containers.Indefinite_Hashed_Sets;