gcc/ada/a-cihase.adb

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