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