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-2014, 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
  79      (HT  : aliased in out Hash_Table_Type;
  80       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    procedure Adjust (Control : in out Reference_Control_Type) is
 157    begin
 158       if Control.Container /= null then
 159          declare
 160             HT : Hash_Table_Type renames Control.Container.all.HT;
 161             B : Natural renames HT.Busy;
 162             L : Natural renames HT.Lock;
 163          begin
 164             B := B + 1;
 165             L := L + 1;
 166          end;
 167       end if;
 168    end Adjust;
 169
 170    ------------
 171    -- Assign --
 172    ------------
 173
 174    procedure Assign (Node : Node_Access; Item : Element_Type) is
 175       X : Element_Access := Node.Element;
 176
 177       --  The element allocator may need an accessibility check in the case the
 178       --  actual type is class-wide or has access discriminants (RM 4.8(10.1)
 179       --  and AI12-0035).
 180
 181       pragma Unsuppress (Accessibility_Check);
 182
 183    begin
 184       Node.Element := new Element_Type'(Item);
 185       Free_Element (X);
 186    end Assign;
 187
 188    procedure Assign (Target : in out Set; Source : Set) is
 189    begin
 190       if Target'Address = Source'Address then
 191          return;
 192       else
 193          Target.Clear;
 194          Target.Union (Source);
 195       end if;
 196    end Assign;
 197
 198    --------------
 199    -- Capacity --
 200    --------------
 201
 202    function Capacity (Container : Set) return Count_Type is
 203    begin
 204       return HT_Ops.Capacity (Container.HT);
 205    end Capacity;
 206
 207    -----------
 208    -- Clear --
 209    -----------
 210
 211    procedure Clear (Container : in out Set) is
 212    begin
 213       HT_Ops.Clear (Container.HT);
 214    end Clear;
 215
 216    ------------------------
 217    -- Constant_Reference --
 218    ------------------------
 219
 220    function Constant_Reference
 221      (Container : aliased Set;
 222       Position  : Cursor) return Constant_Reference_Type
 223    is
 224    begin
 225       if Position.Container = null then
 226          raise Constraint_Error with "Position cursor has no element";
 227       end if;
 228
 229       if Position.Container /= Container'Unrestricted_Access then
 230          raise Program_Error with
 231            "Position cursor designates wrong container";
 232       end if;
 233
 234       if Position.Node.Element = null then
 235          raise Program_Error with "Node has no element";
 236       end if;
 237
 238       pragma Assert (Vet (Position), "bad cursor in Constant_Reference");
 239
 240       declare
 241          HT : Hash_Table_Type renames Position.Container.all.HT;
 242          B : Natural renames HT.Busy;
 243          L : Natural renames HT.Lock;
 244       begin
 245          return R : constant Constant_Reference_Type :=
 246            (Element => Position.Node.Element.all'Access,
 247             Control => (Controlled with Container'Unrestricted_Access))
 248          do
 249             B := B + 1;
 250             L := L + 1;
 251          end return;
 252       end;
 253    end Constant_Reference;
 254
 255    --------------
 256    -- Contains --
 257    --------------
 258
 259    function Contains (Container : Set; Item : Element_Type) return Boolean is
 260    begin
 261       return Find (Container, Item) /= No_Element;
 262    end Contains;
 263
 264    ----------
 265    -- Copy --
 266    ----------
 267
 268    function Copy
 269      (Source   : Set;
 270       Capacity : Count_Type := 0) return Set
 271    is
 272       C : Count_Type;
 273
 274    begin
 275       if Capacity = 0 then
 276          C := Source.Length;
 277
 278       elsif Capacity >= Source.Length then
 279          C := Capacity;
 280
 281       else
 282          raise Capacity_Error
 283            with "Requested capacity is less than Source length";
 284       end if;
 285
 286       return Target : Set do
 287          Target.Reserve_Capacity (C);
 288          Target.Assign (Source);
 289       end return;
 290    end Copy;
 291
 292    ---------------
 293    -- Copy_Node --
 294    ---------------
 295
 296    function Copy_Node (Source : Node_Access) return Node_Access is
 297       E : Element_Access := new Element_Type'(Source.Element.all);
 298    begin
 299       return new Node_Type'(Element => E, Next => null);
 300    exception
 301       when others =>
 302          Free_Element (E);
 303          raise;
 304    end Copy_Node;
 305
 306    ------------
 307    -- Delete --
 308    ------------
 309
 310    procedure Delete
 311      (Container : in out Set;
 312       Item      : Element_Type)
 313    is
 314       X : Node_Access;
 315
 316    begin
 317       Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X);
 318
 319       if X = null then
 320          raise Constraint_Error with "attempt to delete element not in set";
 321       end if;
 322
 323       Free (X);
 324    end Delete;
 325
 326    procedure Delete
 327      (Container : in out Set;
 328       Position  : in out Cursor)
 329    is
 330    begin
 331       if Position.Node = null then
 332          raise Constraint_Error with "Position cursor equals No_Element";
 333       end if;
 334
 335       if Position.Node.Element = null then
 336          raise Program_Error with "Position cursor is bad";
 337       end if;
 338
 339       if Position.Container /= Container'Unrestricted_Access then
 340          raise Program_Error with "Position cursor designates wrong set";
 341       end if;
 342
 343       if Container.HT.Busy > 0 then
 344          raise Program_Error with
 345            "attempt to tamper with cursors (set is busy)";
 346       end if;
 347
 348       pragma Assert (Vet (Position), "Position cursor is bad");
 349
 350       HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node);
 351
 352       Free (Position.Node);
 353       Position.Container := null;
 354    end Delete;
 355
 356    ----------------
 357    -- Difference --
 358    ----------------
 359
 360    procedure Difference
 361      (Target : in out Set;
 362       Source : Set)
 363    is
 364       Src_HT   : Hash_Table_Type renames Source'Unrestricted_Access.HT;
 365       Tgt_Node : Node_Access;
 366
 367    begin
 368       if Target'Address = Source'Address then
 369          Clear (Target);
 370          return;
 371       end if;
 372
 373       if Src_HT.Length = 0 then
 374          return;
 375       end if;
 376
 377       if Target.HT.Busy > 0 then
 378          raise Program_Error with
 379            "attempt to tamper with cursors (set is busy)";
 380       end if;
 381
 382       if Src_HT.Length < Target.HT.Length then
 383          declare
 384             Src_Node : Node_Access;
 385
 386          begin
 387             Src_Node := HT_Ops.First (Src_HT);
 388             while Src_Node /= null loop
 389                Tgt_Node := Element_Keys.Find (Target.HT, Src_Node.Element.all);
 390
 391                if Tgt_Node /= null then
 392                   HT_Ops.Delete_Node_Sans_Free (Target.HT, Tgt_Node);
 393                   Free (Tgt_Node);
 394                end if;
 395
 396                Src_Node := HT_Ops.Next (Src_HT, Src_Node);
 397             end loop;
 398          end;
 399
 400       else
 401          Tgt_Node := HT_Ops.First (Target.HT);
 402          while Tgt_Node /= null loop
 403             if Is_In (Src_HT, Tgt_Node) then
 404                declare
 405                   X : Node_Access := Tgt_Node;
 406                begin
 407                   Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
 408                   HT_Ops.Delete_Node_Sans_Free (Target.HT, X);
 409                   Free (X);
 410                end;
 411
 412             else
 413                Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
 414             end if;
 415          end loop;
 416       end if;
 417    end Difference;
 418
 419    function Difference (Left, Right : Set) return Set is
 420       Left_HT  : Hash_Table_Type renames Left'Unrestricted_Access.HT;
 421       Right_HT : Hash_Table_Type renames Right'Unrestricted_Access.HT;
 422       Buckets  : HT_Types.Buckets_Access;
 423       Length   : Count_Type;
 424
 425    begin
 426       if Left'Address = Right'Address then
 427          return Empty_Set;
 428       end if;
 429
 430       if Left.Length = 0 then
 431          return Empty_Set;
 432       end if;
 433
 434       if Right.Length = 0 then
 435          return Left;
 436       end if;
 437
 438       declare
 439          Size : constant Hash_Type := Prime_Numbers.To_Prime (Left.Length);
 440       begin
 441          Buckets := HT_Ops.New_Buckets (Length => Size);
 442       end;
 443
 444       Length := 0;
 445
 446       Iterate_Left : declare
 447          procedure Process (L_Node : Node_Access);
 448
 449          procedure Iterate is
 450             new HT_Ops.Generic_Iteration (Process);
 451
 452          -------------
 453          -- Process --
 454          -------------
 455
 456          procedure Process (L_Node : Node_Access) is
 457          begin
 458             if not Is_In (Right_HT, L_Node) then
 459                declare
 460                   --  Per AI05-0022, the container implementation is required
 461                   --  to detect element tampering by a generic actual
 462                   --  subprogram, hence the use of Checked_Index instead of a
 463                   --  simple invocation of generic formal Hash.
 464
 465                   Indx   : constant Hash_Type :=
 466                     HT_Ops.Checked_Index (Left_HT, Buckets.all, L_Node);
 467
 468                   Bucket : Node_Access renames Buckets (Indx);
 469                   Src    : Element_Type renames L_Node.Element.all;
 470                   Tgt    : Element_Access := new Element_Type'(Src);
 471
 472                begin
 473                   Bucket := new Node_Type'(Tgt, Bucket);
 474
 475                exception
 476                   when others =>
 477                      Free_Element (Tgt);
 478                      raise;
 479                end;
 480
 481                Length := Length + 1;
 482             end if;
 483          end Process;
 484
 485       --  Start of processing for Iterate_Left
 486
 487       begin
 488          Iterate (Left.HT);
 489
 490       exception
 491          when others =>
 492             HT_Ops.Free_Hash_Table (Buckets);
 493             raise;
 494       end Iterate_Left;
 495
 496       return (Controlled with HT => (Buckets, Length, 0, 0));
 497    end Difference;
 498
 499    -------------
 500    -- Element --
 501    -------------
 502
 503    function Element (Position : Cursor) return Element_Type is
 504    begin
 505       if Position.Node = null then
 506          raise Constraint_Error with "Position cursor of equals No_Element";
 507       end if;
 508
 509       if Position.Node.Element = null then  --  handle dangling reference
 510          raise Program_Error with "Position cursor is bad";
 511       end if;
 512
 513       pragma Assert (Vet (Position), "bad cursor in function Element");
 514
 515       return Position.Node.Element.all;
 516    end Element;
 517
 518    ---------------------
 519    -- Equivalent_Sets --
 520    ---------------------
 521
 522    function Equivalent_Sets (Left, Right : Set) return Boolean is
 523    begin
 524       return Is_Equivalent (Left.HT, Right.HT);
 525    end Equivalent_Sets;
 526
 527    -------------------------
 528    -- Equivalent_Elements --
 529    -------------------------
 530
 531    function Equivalent_Elements (Left, Right : Cursor) return Boolean is
 532    begin
 533       if Left.Node = null then
 534          raise Constraint_Error with
 535            "Left cursor of Equivalent_Elements equals No_Element";
 536       end if;
 537
 538       if Right.Node = null then
 539          raise Constraint_Error with
 540            "Right cursor of Equivalent_Elements equals No_Element";
 541       end if;
 542
 543       if Left.Node.Element = null then
 544          raise Program_Error with
 545            "Left cursor of Equivalent_Elements is bad";
 546       end if;
 547
 548       if Right.Node.Element = null then
 549          raise Program_Error with
 550            "Right cursor of Equivalent_Elements is bad";
 551       end if;
 552
 553       pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Elements");
 554       pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Elements");
 555
 556       --  AI05-0022 requires that a container implementation detect element
 557       --  tampering by a generic actual subprogram. However, the following case
 558       --  falls outside the scope of that AI. Randy Brukardt explained on the
 559       --  ARG list on 2013/02/07 that:
 560
 561       --  (Begin Quote):
 562       --  But for an operation like "<" [the ordered set analog of
 563       --  Equivalent_Elements], there is no need to "dereference" a cursor
 564       --  after the call to the generic formal parameter function, so nothing
 565       --  bad could happen if tampering is undetected. And the operation can
 566       --  safely return a result without a problem even if an element is
 567       --  deleted from the container.
 568       --  (End Quote).
 569
 570       return Equivalent_Elements
 571                (Left.Node.Element.all,
 572                 Right.Node.Element.all);
 573    end Equivalent_Elements;
 574
 575    function Equivalent_Elements
 576      (Left  : Cursor;
 577       Right : Element_Type) return Boolean
 578    is
 579    begin
 580       if Left.Node = null then
 581          raise Constraint_Error with
 582            "Left cursor of Equivalent_Elements equals No_Element";
 583       end if;
 584
 585       if Left.Node.Element = null then
 586          raise Program_Error with
 587            "Left cursor of Equivalent_Elements is bad";
 588       end if;
 589
 590       pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Elements");
 591
 592       return Equivalent_Elements (Left.Node.Element.all, Right);
 593    end Equivalent_Elements;
 594
 595    function Equivalent_Elements
 596      (Left  : Element_Type;
 597       Right : Cursor) return Boolean
 598    is
 599    begin
 600       if Right.Node = null then
 601          raise Constraint_Error with
 602            "Right cursor of Equivalent_Elements equals No_Element";
 603       end if;
 604
 605       if Right.Node.Element = null then
 606          raise Program_Error with
 607            "Right cursor of Equivalent_Elements is bad";
 608       end if;
 609
 610       pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Elements");
 611
 612       return Equivalent_Elements (Left, Right.Node.Element.all);
 613    end Equivalent_Elements;
 614
 615    ---------------------
 616    -- Equivalent_Keys --
 617    ---------------------
 618
 619    function Equivalent_Keys
 620      (Key  : Element_Type;
 621       Node : Node_Access) return Boolean
 622    is
 623    begin
 624       return Equivalent_Elements (Key, Node.Element.all);
 625    end Equivalent_Keys;
 626
 627    -------------
 628    -- Exclude --
 629    -------------
 630
 631    procedure Exclude
 632      (Container : in out Set;
 633       Item      : Element_Type)
 634    is
 635       X : Node_Access;
 636    begin
 637       Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X);
 638       Free (X);
 639    end Exclude;
 640
 641    --------------
 642    -- Finalize --
 643    --------------
 644
 645    procedure Finalize (Container : in out Set) is
 646    begin
 647       HT_Ops.Finalize (Container.HT);
 648    end Finalize;
 649
 650    procedure Finalize (Object : in out Iterator) is
 651    begin
 652       if Object.Container /= null then
 653          declare
 654             B : Natural renames Object.Container.all.HT.Busy;
 655          begin
 656             B := B - 1;
 657          end;
 658       end if;
 659    end Finalize;
 660
 661    procedure Finalize (Control : in out Reference_Control_Type) is
 662    begin
 663       if Control.Container /= null then
 664          declare
 665             HT : Hash_Table_Type renames Control.Container.all.HT;
 666             B : Natural renames HT.Busy;
 667             L : Natural renames HT.Lock;
 668          begin
 669             B := B - 1;
 670             L := L - 1;
 671          end;
 672
 673          Control.Container := null;
 674       end if;
 675    end Finalize;
 676
 677    ----------
 678    -- Find --
 679    ----------
 680
 681    function Find
 682      (Container : Set;
 683       Item      : Element_Type) return Cursor
 684    is
 685       HT   : Hash_Table_Type renames Container'Unrestricted_Access.HT;
 686       Node : constant Node_Access := Element_Keys.Find (HT, Item);
 687    begin
 688       return (if Node = null then No_Element
 689               else Cursor'(Container'Unrestricted_Access, Node));
 690    end Find;
 691
 692    --------------------
 693    -- Find_Equal_Key --
 694    --------------------
 695
 696    function Find_Equal_Key
 697      (R_HT   : Hash_Table_Type;
 698       L_Node : Node_Access) return Boolean
 699    is
 700       R_Index : constant Hash_Type :=
 701         Element_Keys.Index (R_HT, L_Node.Element.all);
 702
 703       R_Node  : Node_Access := R_HT.Buckets (R_Index);
 704
 705    begin
 706       loop
 707          if R_Node = null then
 708             return False;
 709          end if;
 710
 711          if L_Node.Element.all = R_Node.Element.all then
 712             return True;
 713          end if;
 714
 715          R_Node := Next (R_Node);
 716       end loop;
 717    end Find_Equal_Key;
 718
 719    -------------------------
 720    -- Find_Equivalent_Key --
 721    -------------------------
 722
 723    function Find_Equivalent_Key
 724      (R_HT   : Hash_Table_Type;
 725       L_Node : Node_Access) return Boolean
 726    is
 727       R_Index : constant Hash_Type :=
 728         Element_Keys.Index (R_HT, L_Node.Element.all);
 729
 730       R_Node  : Node_Access := R_HT.Buckets (R_Index);
 731
 732    begin
 733       loop
 734          if R_Node = null then
 735             return False;
 736          end if;
 737
 738          if Equivalent_Elements (L_Node.Element.all, R_Node.Element.all) then
 739             return True;
 740          end if;
 741
 742          R_Node := Next (R_Node);
 743       end loop;
 744    end Find_Equivalent_Key;
 745
 746    -----------
 747    -- First --
 748    -----------
 749
 750    function First (Container : Set) return Cursor is
 751       Node : constant Node_Access := HT_Ops.First (Container.HT);
 752    begin
 753       return (if Node = null then No_Element
 754               else Cursor'(Container'Unrestricted_Access, Node));
 755    end First;
 756
 757    function First (Object : Iterator) return Cursor is
 758    begin
 759       return Object.Container.First;
 760    end First;
 761
 762    ----------
 763    -- Free --
 764    ----------
 765
 766    procedure Free (X : in out Node_Access) is
 767       procedure Deallocate is
 768          new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
 769
 770    begin
 771       if X = null then
 772          return;
 773       end if;
 774
 775       X.Next := X;  --  detect mischief (in Vet)
 776
 777       begin
 778          Free_Element (X.Element);
 779
 780       exception
 781          when others =>
 782             X.Element := null;
 783             Deallocate (X);
 784             raise;
 785       end;
 786
 787       Deallocate (X);
 788    end Free;
 789
 790    -----------------
 791    -- Has_Element --
 792    -----------------
 793
 794    function Has_Element (Position : Cursor) return Boolean is
 795    begin
 796       pragma Assert (Vet (Position), "bad cursor in Has_Element");
 797       return Position.Node /= null;
 798    end Has_Element;
 799
 800    ---------------
 801    -- Hash_Node --
 802    ---------------
 803
 804    function Hash_Node (Node : Node_Access) return Hash_Type is
 805    begin
 806       return Hash (Node.Element.all);
 807    end Hash_Node;
 808
 809    -------------
 810    -- Include --
 811    -------------
 812
 813    procedure Include
 814      (Container : in out Set;
 815       New_Item  : Element_Type)
 816    is
 817       Position : Cursor;
 818       Inserted : Boolean;
 819
 820       X : Element_Access;
 821
 822    begin
 823       Insert (Container, New_Item, Position, Inserted);
 824
 825       if not Inserted then
 826          if Container.HT.Lock > 0 then
 827             raise Program_Error with
 828               "attempt to tamper with elements (set is locked)";
 829          end if;
 830
 831          X := Position.Node.Element;
 832
 833          declare
 834             --  The element allocator may need an accessibility check in the
 835             --  case the actual type is class-wide or has access discriminants
 836             --  (see RM 4.8(10.1) and AI12-0035).
 837
 838             pragma Unsuppress (Accessibility_Check);
 839
 840          begin
 841             Position.Node.Element := new Element_Type'(New_Item);
 842          end;
 843
 844          Free_Element (X);
 845       end if;
 846    end Include;
 847
 848    ------------
 849    -- Insert --
 850    ------------
 851
 852    procedure Insert
 853      (Container : in out Set;
 854       New_Item  : Element_Type;
 855       Position  : out Cursor;
 856       Inserted  : out Boolean)
 857    is
 858    begin
 859       Insert (Container.HT, New_Item, Position.Node, Inserted);
 860       Position.Container := Container'Unchecked_Access;
 861    end Insert;
 862
 863    procedure Insert
 864      (Container : in out Set;
 865       New_Item  : Element_Type)
 866    is
 867       Position : Cursor;
 868       pragma Unreferenced (Position);
 869
 870       Inserted : Boolean;
 871
 872    begin
 873       Insert (Container, New_Item, Position, Inserted);
 874
 875       if not Inserted then
 876          raise Constraint_Error with
 877            "attempt to insert element already in set";
 878       end if;
 879    end Insert;
 880
 881    procedure Insert
 882      (HT       : in out Hash_Table_Type;
 883       New_Item : Element_Type;
 884       Node     : out Node_Access;
 885       Inserted : out Boolean)
 886    is
 887       function New_Node (Next : Node_Access) return Node_Access;
 888       pragma Inline (New_Node);
 889
 890       procedure Local_Insert is
 891          new Element_Keys.Generic_Conditional_Insert (New_Node);
 892
 893       --------------
 894       -- New_Node --
 895       --------------
 896
 897       function New_Node (Next : Node_Access) return Node_Access is
 898
 899          --  The element allocator may need an accessibility check in the case
 900          --  the actual type is class-wide or has access discriminants (see
 901          --  RM 4.8(10.1) and AI12-0035).
 902
 903          pragma Unsuppress (Accessibility_Check);
 904
 905          Element : Element_Access := new Element_Type'(New_Item);
 906
 907       begin
 908          return new Node_Type'(Element, Next);
 909
 910       exception
 911          when others =>
 912             Free_Element (Element);
 913             raise;
 914       end New_Node;
 915
 916    --  Start of processing for Insert
 917
 918    begin
 919       if HT_Ops.Capacity (HT) = 0 then
 920          HT_Ops.Reserve_Capacity (HT, 1);
 921       end if;
 922
 923       Local_Insert (HT, New_Item, Node, Inserted);
 924
 925       if Inserted and then HT.Length > HT_Ops.Capacity (HT) then
 926          HT_Ops.Reserve_Capacity (HT, HT.Length);
 927       end if;
 928    end Insert;
 929
 930    ------------------
 931    -- Intersection --
 932    ------------------
 933
 934    procedure Intersection
 935      (Target : in out Set;
 936       Source : Set)
 937    is
 938       Src_HT   : Hash_Table_Type renames Source'Unrestricted_Access.HT;
 939       Tgt_Node : Node_Access;
 940
 941    begin
 942       if Target'Address = Source'Address then
 943          return;
 944       end if;
 945
 946       if Source.Length = 0 then
 947          Clear (Target);
 948          return;
 949       end if;
 950
 951       if Target.HT.Busy > 0 then
 952          raise Program_Error with
 953            "attempt to tamper with cursors (set is busy)";
 954       end if;
 955
 956       Tgt_Node := HT_Ops.First (Target.HT);
 957       while Tgt_Node /= null loop
 958          if Is_In (Src_HT, Tgt_Node) then
 959             Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
 960
 961          else
 962             declare
 963                X : Node_Access := Tgt_Node;
 964             begin
 965                Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
 966                HT_Ops.Delete_Node_Sans_Free (Target.HT, X);
 967                Free (X);
 968             end;
 969          end if;
 970       end loop;
 971    end Intersection;
 972
 973    function Intersection (Left, Right : Set) return Set is
 974       Left_HT  : Hash_Table_Type renames Left'Unrestricted_Access.HT;
 975       Right_HT : Hash_Table_Type renames Right'Unrestricted_Access.HT;
 976       Buckets  : HT_Types.Buckets_Access;
 977       Length   : Count_Type;
 978
 979    begin
 980       if Left'Address = Right'Address then
 981          return Left;
 982       end if;
 983
 984       Length := Count_Type'Min (Left.Length, Right.Length);
 985
 986       if Length = 0 then
 987          return Empty_Set;
 988       end if;
 989
 990       declare
 991          Size : constant Hash_Type := Prime_Numbers.To_Prime (Length);
 992       begin
 993          Buckets := HT_Ops.New_Buckets (Length => Size);
 994       end;
 995
 996       Length := 0;
 997
 998       Iterate_Left : declare
 999          procedure Process (L_Node : Node_Access);
1000
1001          procedure Iterate is
1002             new HT_Ops.Generic_Iteration (Process);
1003
1004          -------------
1005          -- Process --
1006          -------------
1007
1008          procedure Process (L_Node : Node_Access) is
1009          begin
1010             if Is_In (Right_HT, L_Node) then
1011                declare
1012                   --  Per AI05-0022, the container implementation is required
1013                   --  to detect element tampering by a generic actual
1014                   --  subprogram, hence the use of Checked_Index instead of a
1015                   --  simple invocation of generic formal Hash.
1016
1017                   Indx : constant Hash_Type :=
1018                     HT_Ops.Checked_Index (Left_HT, Buckets.all, L_Node);
1019
1020                   Bucket : Node_Access renames Buckets (Indx);
1021
1022                   Src : Element_Type renames L_Node.Element.all;
1023                   Tgt : Element_Access := new Element_Type'(Src);
1024
1025                begin
1026                   Bucket := new Node_Type'(Tgt, Bucket);
1027
1028                exception
1029                   when others =>
1030                      Free_Element (Tgt);
1031                      raise;
1032                end;
1033
1034                Length := Length + 1;
1035             end if;
1036          end Process;
1037
1038       --  Start of processing for Iterate_Left
1039
1040       begin
1041          Iterate (Left.HT);
1042
1043       exception
1044          when others =>
1045             HT_Ops.Free_Hash_Table (Buckets);
1046             raise;
1047       end Iterate_Left;
1048
1049       return (Controlled with HT => (Buckets, Length, 0, 0));
1050    end Intersection;
1051
1052    --------------
1053    -- Is_Empty --
1054    --------------
1055
1056    function Is_Empty (Container : Set) return Boolean is
1057    begin
1058       return Container.HT.Length = 0;
1059    end Is_Empty;
1060
1061    -----------
1062    -- Is_In --
1063    -----------
1064
1065    function Is_In
1066      (HT  : aliased in out Hash_Table_Type;
1067       Key : Node_Access) return Boolean
1068    is
1069    begin
1070       return Element_Keys.Find (HT, Key.Element.all) /= null;
1071    end Is_In;
1072
1073    ---------------
1074    -- Is_Subset --
1075    ---------------
1076
1077    function Is_Subset
1078      (Subset : Set;
1079       Of_Set : Set) return Boolean
1080    is
1081       Subset_HT   : Hash_Table_Type renames Subset'Unrestricted_Access.HT;
1082       Of_Set_HT   : Hash_Table_Type renames Of_Set'Unrestricted_Access.HT;
1083       Subset_Node : Node_Access;
1084
1085    begin
1086       if Subset'Address = Of_Set'Address then
1087          return True;
1088       end if;
1089
1090       if Subset.Length > Of_Set.Length then
1091          return False;
1092       end if;
1093
1094       Subset_Node := HT_Ops.First (Subset_HT);
1095       while Subset_Node /= null loop
1096          if not Is_In (Of_Set_HT, Subset_Node) then
1097             return False;
1098          end if;
1099
1100          Subset_Node := HT_Ops.Next (Subset_HT, Subset_Node);
1101       end loop;
1102
1103       return True;
1104    end Is_Subset;
1105
1106    -------------
1107    -- Iterate --
1108    -------------
1109
1110    procedure Iterate
1111      (Container : Set;
1112       Process   : not null access procedure (Position : Cursor))
1113    is
1114       procedure Process_Node (Node : Node_Access);
1115       pragma Inline (Process_Node);
1116
1117       procedure Iterate is
1118          new HT_Ops.Generic_Iteration (Process_Node);
1119
1120       ------------------
1121       -- Process_Node --
1122       ------------------
1123
1124       procedure Process_Node (Node : Node_Access) is
1125       begin
1126          Process (Cursor'(Container'Unrestricted_Access, Node));
1127       end Process_Node;
1128
1129       B : Natural renames Container'Unrestricted_Access.all.HT.Busy;
1130
1131    --  Start of processing for Iterate
1132
1133    begin
1134       B := B + 1;
1135
1136       begin
1137          Iterate (Container.HT);
1138       exception
1139          when others =>
1140             B := B - 1;
1141             raise;
1142       end;
1143
1144       B := B - 1;
1145    end Iterate;
1146
1147    function Iterate (Container : Set)
1148      return Set_Iterator_Interfaces.Forward_Iterator'Class
1149    is
1150       B : Natural renames Container'Unrestricted_Access.all.HT.Busy;
1151    begin
1152       return It : constant Iterator :=
1153         Iterator'(Limited_Controlled with
1154                     Container => Container'Unrestricted_Access)
1155       do
1156          B := B + 1;
1157       end return;
1158    end Iterate;
1159
1160    ------------
1161    -- Length --
1162    ------------
1163
1164    function Length (Container : Set) return Count_Type is
1165    begin
1166       return Container.HT.Length;
1167    end Length;
1168
1169    ----------
1170    -- Move --
1171    ----------
1172
1173    procedure Move (Target : in out Set; Source : in out Set) is
1174    begin
1175       HT_Ops.Move (Target => Target.HT, Source => Source.HT);
1176    end Move;
1177
1178    ----------
1179    -- Next --
1180    ----------
1181
1182    function Next (Node : Node_Access) return Node_Access is
1183    begin
1184       return Node.Next;
1185    end Next;
1186
1187    function Next (Position : Cursor) return Cursor is
1188    begin
1189       if Position.Node = null then
1190          return No_Element;
1191       end if;
1192
1193       if Position.Node.Element = null then
1194          raise Program_Error with "bad cursor in Next";
1195       end if;
1196
1197       pragma Assert (Vet (Position), "bad cursor in Next");
1198
1199       declare
1200          HT   : Hash_Table_Type renames Position.Container.HT;
1201          Node : constant Node_Access := HT_Ops.Next (HT, Position.Node);
1202       begin
1203          return (if Node = null then No_Element
1204                  else Cursor'(Position.Container, Node));
1205       end;
1206    end Next;
1207
1208    procedure Next (Position : in out Cursor) is
1209    begin
1210       Position := Next (Position);
1211    end Next;
1212
1213    function Next
1214      (Object   : Iterator;
1215       Position : Cursor) return Cursor
1216    is
1217    begin
1218       if Position.Container = null then
1219          return No_Element;
1220       end if;
1221
1222       if Position.Container /= Object.Container then
1223          raise Program_Error with
1224            "Position cursor of Next designates wrong set";
1225       end if;
1226
1227       return Next (Position);
1228    end Next;
1229
1230    -------------
1231    -- Overlap --
1232    -------------
1233
1234    function Overlap (Left, Right : Set) return Boolean is
1235       Left_HT   : Hash_Table_Type renames Left'Unrestricted_Access.HT;
1236       Right_HT  : Hash_Table_Type renames Right'Unrestricted_Access.HT;
1237       Left_Node : Node_Access;
1238
1239    begin
1240       if Right.Length = 0 then
1241          return False;
1242       end if;
1243
1244       if Left'Address = Right'Address then
1245          return True;
1246       end if;
1247
1248       Left_Node := HT_Ops.First (Left_HT);
1249       while Left_Node /= null loop
1250          if Is_In (Right_HT, Left_Node) then
1251             return True;
1252          end if;
1253
1254          Left_Node := HT_Ops.Next (Left_HT, Left_Node);
1255       end loop;
1256
1257       return False;
1258    end Overlap;
1259
1260    -------------------
1261    -- Query_Element --
1262    -------------------
1263
1264    procedure Query_Element
1265      (Position : Cursor;
1266       Process  : not null access procedure (Element : Element_Type))
1267    is
1268    begin
1269       if Position.Node = null then
1270          raise Constraint_Error with
1271            "Position cursor of Query_Element equals No_Element";
1272       end if;
1273
1274       if Position.Node.Element = null then
1275          raise Program_Error with "bad cursor in Query_Element";
1276       end if;
1277
1278       pragma Assert (Vet (Position), "bad cursor in Query_Element");
1279
1280       declare
1281          HT : Hash_Table_Type renames
1282                 Position.Container'Unrestricted_Access.all.HT;
1283
1284          B : Natural renames HT.Busy;
1285          L : Natural renames HT.Lock;
1286
1287       begin
1288          B := B + 1;
1289          L := L + 1;
1290
1291          begin
1292             Process (Position.Node.Element.all);
1293          exception
1294             when others =>
1295                L := L - 1;
1296                B := B - 1;
1297                raise;
1298          end;
1299
1300          L := L - 1;
1301          B := B - 1;
1302       end;
1303    end Query_Element;
1304
1305    ----------
1306    -- Read --
1307    ----------
1308
1309    procedure Read
1310      (Stream    : not null access Root_Stream_Type'Class;
1311       Container : out Set)
1312    is
1313    begin
1314       Read_Nodes (Stream, Container.HT);
1315    end Read;
1316
1317    procedure Read
1318      (Stream : not null access Root_Stream_Type'Class;
1319       Item   : out Cursor)
1320    is
1321    begin
1322       raise Program_Error with "attempt to stream set cursor";
1323    end Read;
1324
1325    procedure Read
1326      (Stream : not null access Root_Stream_Type'Class;
1327       Item   : out Constant_Reference_Type)
1328    is
1329    begin
1330       raise Program_Error with "attempt to stream reference";
1331    end Read;
1332
1333    ---------------
1334    -- Read_Node --
1335    ---------------
1336
1337    function Read_Node
1338      (Stream : not null access Root_Stream_Type'Class) return Node_Access
1339    is
1340       X : Element_Access := new Element_Type'(Element_Type'Input (Stream));
1341    begin
1342       return new Node_Type'(X, null);
1343    exception
1344       when others =>
1345          Free_Element (X);
1346          raise;
1347    end Read_Node;
1348
1349    -------------
1350    -- Replace --
1351    -------------
1352
1353    procedure Replace
1354      (Container : in out Set;
1355       New_Item  : Element_Type)
1356    is
1357       Node : constant Node_Access :=
1358         Element_Keys.Find (Container.HT, New_Item);
1359
1360       X : Element_Access;
1361       pragma Warnings (Off, X);
1362
1363    begin
1364       if Node = null then
1365          raise Constraint_Error with
1366            "attempt to replace element not in set";
1367       end if;
1368
1369       if Container.HT.Lock > 0 then
1370          raise Program_Error with
1371            "attempt to tamper with elements (set is locked)";
1372       end if;
1373
1374       X := Node.Element;
1375
1376       declare
1377          --  The element allocator may need an accessibility check in the case
1378          --  the actual type is class-wide or has access discriminants (see
1379          --  RM 4.8(10.1) and AI12-0035).
1380
1381          pragma Unsuppress (Accessibility_Check);
1382
1383       begin
1384          Node.Element := new Element_Type'(New_Item);
1385       end;
1386
1387       Free_Element (X);
1388    end Replace;
1389
1390    ---------------------
1391    -- Replace_Element --
1392    ---------------------
1393
1394    procedure Replace_Element
1395      (Container : in out Set;
1396       Position  : Cursor;
1397       New_Item  : Element_Type)
1398    is
1399    begin
1400       if Position.Node = null then
1401          raise Constraint_Error with "Position cursor equals No_Element";
1402       end if;
1403
1404       if Position.Node.Element = null then
1405          raise Program_Error with "bad cursor in Replace_Element";
1406       end if;
1407
1408       if Position.Container /= Container'Unrestricted_Access then
1409          raise Program_Error with
1410            "Position cursor designates wrong set";
1411       end if;
1412
1413       pragma Assert (Vet (Position), "bad cursor in Replace_Element");
1414
1415       Replace_Element (Container.HT, Position.Node, New_Item);
1416    end Replace_Element;
1417
1418    ----------------------
1419    -- Reserve_Capacity --
1420    ----------------------
1421
1422    procedure Reserve_Capacity
1423      (Container : in out Set;
1424       Capacity  : Count_Type)
1425    is
1426    begin
1427       HT_Ops.Reserve_Capacity (Container.HT, Capacity);
1428    end Reserve_Capacity;
1429
1430    --------------
1431    -- Set_Next --
1432    --------------
1433
1434    procedure Set_Next (Node : Node_Access; Next : Node_Access) is
1435    begin
1436       Node.Next := Next;
1437    end Set_Next;
1438
1439    --------------------------
1440    -- Symmetric_Difference --
1441    --------------------------
1442
1443    procedure Symmetric_Difference
1444      (Target : in out Set;
1445       Source : Set)
1446    is
1447       Tgt_HT : Hash_Table_Type renames Target.HT;
1448       Src_HT : Hash_Table_Type renames Source.HT'Unrestricted_Access.all;
1449
1450       --  Per AI05-0022, the container implementation is required to detect
1451       --  element tampering by a generic actual subprogram.
1452
1453       TB : Natural renames Tgt_HT.Busy;
1454       TL : Natural renames Tgt_HT.Lock;
1455
1456       SB : Natural renames Src_HT.Busy;
1457       SL : Natural renames Src_HT.Lock;
1458
1459    begin
1460       if Target'Address = Source'Address then
1461          Clear (Target);
1462          return;
1463       end if;
1464
1465       if TB > 0 then
1466          raise Program_Error with
1467            "attempt to tamper with cursors (set is busy)";
1468       end if;
1469
1470       declare
1471          N : constant Count_Type := Target.Length + Source.Length;
1472       begin
1473          if N > HT_Ops.Capacity (Tgt_HT) then
1474             HT_Ops.Reserve_Capacity (Tgt_HT, N);
1475          end if;
1476       end;
1477
1478       if Target.Length = 0 then
1479          Iterate_Source_When_Empty_Target : declare
1480             procedure Process (Src_Node : Node_Access);
1481
1482             procedure Iterate is new HT_Ops.Generic_Iteration (Process);
1483
1484             -------------
1485             -- Process --
1486             -------------
1487
1488             procedure Process (Src_Node : Node_Access) is
1489                E : Element_Type renames Src_Node.Element.all;
1490                B : Buckets_Type renames Tgt_HT.Buckets.all;
1491                J : constant Hash_Type := Hash (E) mod B'Length;
1492                N : Count_Type renames Tgt_HT.Length;
1493
1494             begin
1495                declare
1496                   X : Element_Access := new Element_Type'(E);
1497                begin
1498                   B (J) := new Node_Type'(X, B (J));
1499                exception
1500                   when others =>
1501                      Free_Element (X);
1502                      raise;
1503                end;
1504
1505                N := N + 1;
1506             end Process;
1507
1508          --  Start of processing for Iterate_Source_When_Empty_Target
1509
1510          begin
1511             TB := TB + 1;
1512             TL := TL + 1;
1513
1514             SB := SB + 1;
1515             SL := SL + 1;
1516
1517             Iterate (Src_HT);
1518
1519             SL := SL - 1;
1520             SB := SB - 1;
1521
1522             TL := TL - 1;
1523             TB := TB - 1;
1524
1525          exception
1526             when others =>
1527                SL := SL - 1;
1528                SB := SB - 1;
1529
1530                TL := TL - 1;
1531                TB := TB - 1;
1532
1533                raise;
1534          end Iterate_Source_When_Empty_Target;
1535
1536       else
1537          Iterate_Source : declare
1538             procedure Process (Src_Node : Node_Access);
1539
1540             procedure Iterate is
1541                new HT_Ops.Generic_Iteration (Process);
1542
1543             -------------
1544             -- Process --
1545             -------------
1546
1547             procedure Process (Src_Node : Node_Access) is
1548                E : Element_Type renames Src_Node.Element.all;
1549                B : Buckets_Type renames Tgt_HT.Buckets.all;
1550                J : constant Hash_Type := Hash (E) mod B'Length;
1551                N : Count_Type renames Tgt_HT.Length;
1552
1553             begin
1554                if B (J) = null then
1555                   declare
1556                      X : Element_Access := new Element_Type'(E);
1557                   begin
1558                      B (J) := new Node_Type'(X, null);
1559                   exception
1560                      when others =>
1561                         Free_Element (X);
1562                         raise;
1563                   end;
1564
1565                   N := N + 1;
1566
1567                elsif Equivalent_Elements (E, B (J).Element.all) then
1568                   declare
1569                      X : Node_Access := B (J);
1570                   begin
1571                      B (J) := B (J).Next;
1572                      N := N - 1;
1573                      Free (X);
1574                   end;
1575
1576                else
1577                   declare
1578                      Prev : Node_Access := B (J);
1579                      Curr : Node_Access := Prev.Next;
1580
1581                   begin
1582                      while Curr /= null loop
1583                         if Equivalent_Elements (E, Curr.Element.all) then
1584                            Prev.Next := Curr.Next;
1585                            N := N - 1;
1586                            Free (Curr);
1587                            return;
1588                         end if;
1589
1590                         Prev := Curr;
1591                         Curr := Prev.Next;
1592                      end loop;
1593
1594                      declare
1595                         X : Element_Access := new Element_Type'(E);
1596                      begin
1597                         B (J) := new Node_Type'(X, B (J));
1598                      exception
1599                         when others =>
1600                            Free_Element (X);
1601                            raise;
1602                      end;
1603
1604                      N := N + 1;
1605                   end;
1606                end if;
1607             end Process;
1608
1609          --  Start of processing for Iterate_Source
1610
1611          begin
1612             TB := TB + 1;
1613             TL := TL + 1;
1614
1615             SB := SB + 1;
1616             SL := SL + 1;
1617
1618             Iterate (Src_HT);
1619
1620             SL := SL - 1;
1621             SB := SB - 1;
1622
1623             TL := TL - 1;
1624             TB := TB - 1;
1625
1626          exception
1627             when others =>
1628                SL := SL - 1;
1629                SB := SB - 1;
1630
1631                TL := TL - 1;
1632                TB := TB - 1;
1633
1634                raise;
1635          end Iterate_Source;
1636       end if;
1637    end Symmetric_Difference;
1638
1639    function Symmetric_Difference (Left, Right : Set) return Set is
1640       Left_HT  : Hash_Table_Type renames Left'Unrestricted_Access.HT;
1641       Right_HT : Hash_Table_Type renames Right'Unrestricted_Access.HT;
1642       Buckets  : HT_Types.Buckets_Access;
1643       Length   : Count_Type;
1644
1645    begin
1646       if Left'Address = Right'Address then
1647          return Empty_Set;
1648       end if;
1649
1650       if Right.Length = 0 then
1651          return Left;
1652       end if;
1653
1654       if Left.Length = 0 then
1655          return Right;
1656       end if;
1657
1658       declare
1659          Size : constant Hash_Type :=
1660            Prime_Numbers.To_Prime (Left.Length + Right.Length);
1661       begin
1662          Buckets := HT_Ops.New_Buckets (Length => Size);
1663       end;
1664
1665       Length := 0;
1666
1667       Iterate_Left : declare
1668          procedure Process (L_Node : Node_Access);
1669
1670          procedure Iterate is
1671             new HT_Ops.Generic_Iteration (Process);
1672
1673          -------------
1674          -- Process --
1675          -------------
1676
1677          procedure Process (L_Node : Node_Access) is
1678          begin
1679             if not Is_In (Right_HT, L_Node) then
1680                declare
1681                   E : Element_Type renames L_Node.Element.all;
1682
1683                   --  Per AI05-0022, the container implementation is required
1684                   --  to detect element tampering by a generic actual
1685                   --  subprogram, hence the use of Checked_Index instead of a
1686                   --  simple invocation of generic formal Hash.
1687
1688                   J : constant Hash_Type :=
1689                     HT_Ops.Checked_Index (Left_HT, Buckets.all, L_Node);
1690
1691                begin
1692                   declare
1693                      X : Element_Access := new Element_Type'(E);
1694                   begin
1695                      Buckets (J) := new Node_Type'(X, Buckets (J));
1696                   exception
1697                      when others =>
1698                         Free_Element (X);
1699                         raise;
1700                   end;
1701
1702                   Length := Length + 1;
1703                end;
1704             end if;
1705          end Process;
1706
1707       --  Start of processing for Iterate_Left
1708
1709       begin
1710          Iterate (Left_HT);
1711       exception
1712          when others =>
1713             HT_Ops.Free_Hash_Table (Buckets);
1714             raise;
1715       end Iterate_Left;
1716
1717       Iterate_Right : declare
1718          procedure Process (R_Node : Node_Access);
1719
1720          procedure Iterate is
1721             new HT_Ops.Generic_Iteration (Process);
1722
1723          -------------
1724          -- Process --
1725          -------------
1726
1727          procedure Process (R_Node : Node_Access) is
1728          begin
1729             if not Is_In (Left_HT, R_Node) then
1730                declare
1731                   E : Element_Type renames R_Node.Element.all;
1732
1733                   --  Per AI05-0022, the container implementation is required
1734                   --  to detect element tampering by a generic actual
1735                   --  subprogram, hence the use of Checked_Index instead of a
1736                   --  simple invocation of generic formal Hash.
1737
1738                   J : constant Hash_Type :=
1739                     HT_Ops.Checked_Index (Right_HT, Buckets.all, R_Node);
1740
1741                begin
1742                   declare
1743                      X : Element_Access := new Element_Type'(E);
1744                   begin
1745                      Buckets (J) := new Node_Type'(X, Buckets (J));
1746                   exception
1747                      when others =>
1748                         Free_Element (X);
1749                         raise;
1750                   end;
1751
1752                   Length := Length + 1;
1753                end;
1754             end if;
1755          end Process;
1756
1757       --  Start of processing for Iterate_Right
1758
1759       begin
1760          Iterate (Right_HT);
1761
1762       exception
1763          when others =>
1764             HT_Ops.Free_Hash_Table (Buckets);
1765             raise;
1766       end Iterate_Right;
1767
1768       return (Controlled with HT => (Buckets, Length, 0, 0));
1769    end Symmetric_Difference;
1770
1771    ------------
1772    -- To_Set --
1773    ------------
1774
1775    function To_Set (New_Item : Element_Type) return Set is
1776       HT       : Hash_Table_Type;
1777       Node     : Node_Access;
1778       Inserted : Boolean;
1779       pragma Unreferenced (Node, Inserted);
1780    begin
1781       Insert (HT, New_Item, Node, Inserted);
1782       return Set'(Controlled with HT);
1783    end To_Set;
1784
1785    -----------
1786    -- Union --
1787    -----------
1788
1789    procedure Union
1790      (Target : in out Set;
1791       Source : Set)
1792    is
1793       procedure Process (Src_Node : Node_Access);
1794
1795       procedure Iterate is
1796          new HT_Ops.Generic_Iteration (Process);
1797
1798       -------------
1799       -- Process --
1800       -------------
1801
1802       procedure Process (Src_Node : Node_Access) is
1803          Src : Element_Type renames Src_Node.Element.all;
1804
1805          function New_Node (Next : Node_Access) return Node_Access;
1806          pragma Inline (New_Node);
1807
1808          procedure Insert is
1809             new Element_Keys.Generic_Conditional_Insert (New_Node);
1810
1811          --------------
1812          -- New_Node --
1813          --------------
1814
1815          function New_Node (Next : Node_Access) return Node_Access is
1816             Tgt : Element_Access := new Element_Type'(Src);
1817          begin
1818             return new Node_Type'(Tgt, Next);
1819          exception
1820             when others =>
1821                Free_Element (Tgt);
1822                raise;
1823          end New_Node;
1824
1825          Tgt_Node : Node_Access;
1826          Success  : Boolean;
1827          pragma Unreferenced (Tgt_Node, Success);
1828
1829       --  Start of processing for Process
1830
1831       begin
1832          Insert (Target.HT, Src, Tgt_Node, Success);
1833       end Process;
1834
1835    --  Start of processing for Union
1836
1837    begin
1838       if Target'Address = Source'Address then
1839          return;
1840       end if;
1841
1842       if Target.HT.Busy > 0 then
1843          raise Program_Error with
1844            "attempt to tamper with cursors (set is busy)";
1845       end if;
1846
1847       declare
1848          N : constant Count_Type := Target.Length + Source.Length;
1849       begin
1850          if N > HT_Ops.Capacity (Target.HT) then
1851             HT_Ops.Reserve_Capacity (Target.HT, N);
1852          end if;
1853       end;
1854
1855       Iterate (Source.HT);
1856    end Union;
1857
1858    function Union (Left, Right : Set) return Set is
1859       Left_HT  : Hash_Table_Type renames Left.HT'Unrestricted_Access.all;
1860       Right_HT : Hash_Table_Type renames Right.HT'Unrestricted_Access.all;
1861       Buckets  : HT_Types.Buckets_Access;
1862       Length   : Count_Type;
1863
1864    begin
1865       if Left'Address = Right'Address then
1866          return Left;
1867       end if;
1868
1869       if Right.Length = 0 then
1870          return Left;
1871       end if;
1872
1873       if Left.Length = 0 then
1874          return Right;
1875       end if;
1876
1877       declare
1878          Size : constant Hash_Type :=
1879            Prime_Numbers.To_Prime (Left.Length + Right.Length);
1880       begin
1881          Buckets := HT_Ops.New_Buckets (Length => Size);
1882       end;
1883
1884       Iterate_Left : declare
1885          procedure Process (L_Node : Node_Access);
1886
1887          procedure Iterate is
1888             new HT_Ops.Generic_Iteration (Process);
1889
1890          -------------
1891          -- Process --
1892          -------------
1893
1894          procedure Process (L_Node : Node_Access) is
1895             Src    : Element_Type renames L_Node.Element.all;
1896             J      : constant Hash_Type := Hash (Src) mod Buckets'Length;
1897             Bucket : Node_Access renames Buckets (J);
1898             Tgt    : Element_Access := new Element_Type'(Src);
1899          begin
1900             Bucket := new Node_Type'(Tgt, Bucket);
1901          exception
1902             when others =>
1903                Free_Element (Tgt);
1904                raise;
1905          end Process;
1906
1907          --  Per AI05-0022, the container implementation is required to detect
1908          --  element tampering by a generic actual subprogram, hence the use of
1909          --  Checked_Index instead of a simple invocation of generic formal
1910          --  Hash.
1911
1912          B : Integer renames Left_HT.Busy;
1913          L : Integer renames Left_HT.Lock;
1914
1915       --  Start of processing for Iterate_Left
1916
1917       begin
1918          B := B + 1;
1919          L := L + 1;
1920
1921          Iterate (Left.HT);
1922
1923          L := L - 1;
1924          B := B - 1;
1925
1926       exception
1927          when others =>
1928             L := L - 1;
1929             B := B - 1;
1930
1931             HT_Ops.Free_Hash_Table (Buckets);
1932             raise;
1933       end Iterate_Left;
1934
1935       Length := Left.Length;
1936
1937       Iterate_Right : declare
1938          procedure Process (Src_Node : Node_Access);
1939
1940          procedure Iterate is
1941             new HT_Ops.Generic_Iteration (Process);
1942
1943          -------------
1944          -- Process --
1945          -------------
1946
1947          procedure Process (Src_Node : Node_Access) is
1948             Src : Element_Type renames Src_Node.Element.all;
1949             Idx : constant Hash_Type := Hash (Src) mod Buckets'Length;
1950
1951             Tgt_Node : Node_Access := Buckets (Idx);
1952
1953          begin
1954             while Tgt_Node /= null loop
1955                if Equivalent_Elements (Src, Tgt_Node.Element.all) then
1956                   return;
1957                end if;
1958                Tgt_Node := Next (Tgt_Node);
1959             end loop;
1960
1961             declare
1962                Tgt : Element_Access := new Element_Type'(Src);
1963             begin
1964                Buckets (Idx) := new Node_Type'(Tgt, Buckets (Idx));
1965             exception
1966                when others =>
1967                   Free_Element (Tgt);
1968                   raise;
1969             end;
1970
1971             Length := Length + 1;
1972          end Process;
1973
1974          --  Per AI05-0022, the container implementation is required to detect
1975          --  element tampering by a generic actual subprogram, hence the use of
1976          --  Checked_Index instead of a simple invocation of generic formal
1977          --  Hash.
1978
1979          LB : Integer renames Left_HT.Busy;
1980          LL : Integer renames Left_HT.Lock;
1981
1982          RB : Integer renames Right_HT.Busy;
1983          RL : Integer renames Right_HT.Lock;
1984
1985       --  Start of processing for Iterate_Right
1986
1987       begin
1988          LB := LB + 1;
1989          LL := LL + 1;
1990
1991          RB := RB + 1;
1992          RL := RL + 1;
1993
1994          Iterate (Right.HT);
1995
1996          RL := RL - 1;
1997          RB := RB - 1;
1998
1999          LL := LL - 1;
2000          LB := LB - 1;
2001
2002       exception
2003          when others =>
2004             RL := RL - 1;
2005             RB := RB - 1;
2006
2007             LL := LL - 1;
2008             LB := LB - 1;
2009
2010             HT_Ops.Free_Hash_Table (Buckets);
2011             raise;
2012       end Iterate_Right;
2013
2014       return (Controlled with HT => (Buckets, Length, 0, 0));
2015    end Union;
2016
2017    ---------
2018    -- Vet --
2019    ---------
2020
2021    function Vet (Position : Cursor) return Boolean is
2022    begin
2023       if Position.Node = null then
2024          return Position.Container = null;
2025       end if;
2026
2027       if Position.Container = null then
2028          return False;
2029       end if;
2030
2031       if Position.Node.Next = Position.Node then
2032          return False;
2033       end if;
2034
2035       if Position.Node.Element = null then
2036          return False;
2037       end if;
2038
2039       declare
2040          HT : Hash_Table_Type renames Position.Container.HT;
2041          X  : Node_Access;
2042
2043       begin
2044          if HT.Length = 0 then
2045             return False;
2046          end if;
2047
2048          if HT.Buckets = null
2049            or else HT.Buckets'Length = 0
2050          then
2051             return False;
2052          end if;
2053
2054          X := HT.Buckets (Element_Keys.Checked_Index
2055                             (HT,
2056                              Position.Node.Element.all));
2057
2058          for J in 1 .. HT.Length loop
2059             if X = Position.Node then
2060                return True;
2061             end if;
2062
2063             if X = null then
2064                return False;
2065             end if;
2066
2067             if X = X.Next then  --  to prevent unnecessary looping
2068                return False;
2069             end if;
2070
2071             X := X.Next;
2072          end loop;
2073
2074          return False;
2075       end;
2076    end Vet;
2077
2078    -----------
2079    -- Write --
2080    -----------
2081
2082    procedure Write
2083      (Stream    : not null access Root_Stream_Type'Class;
2084       Container : Set)
2085    is
2086    begin
2087       Write_Nodes (Stream, Container.HT);
2088    end Write;
2089
2090    procedure Write
2091      (Stream : not null access Root_Stream_Type'Class;
2092       Item   : Cursor)
2093    is
2094    begin
2095       raise Program_Error with "attempt to stream set cursor";
2096    end Write;
2097
2098    procedure Write
2099      (Stream : not null access Root_Stream_Type'Class;
2100       Item   : Constant_Reference_Type)
2101    is
2102    begin
2103       raise Program_Error with "attempt to stream reference";
2104    end Write;
2105
2106    ----------------
2107    -- Write_Node --
2108    ----------------
2109
2110    procedure Write_Node
2111      (Stream : not null access Root_Stream_Type'Class;
2112       Node   : Node_Access)
2113    is
2114    begin
2115       Element_Type'Output (Stream, Node.Element.all);
2116    end Write_Node;
2117
2118    package body Generic_Keys is
2119
2120       -----------------------
2121       -- Local Subprograms --
2122       -----------------------
2123
2124       function Equivalent_Key_Node
2125         (Key  : Key_Type;
2126          Node : Node_Access) return Boolean;
2127       pragma Inline (Equivalent_Key_Node);
2128
2129       --------------------------
2130       -- Local Instantiations --
2131       --------------------------
2132
2133       package Key_Keys is
2134          new Hash_Tables.Generic_Keys
2135           (HT_Types  => HT_Types,
2136            Next      => Next,
2137            Set_Next  => Set_Next,
2138            Key_Type  => Key_Type,
2139            Hash      => Hash,
2140            Equivalent_Keys => Equivalent_Key_Node);
2141
2142       ------------
2143       -- Adjust --
2144       ------------
2145
2146       procedure Adjust (Control : in out Reference_Control_Type) is
2147       begin
2148          if Control.Container /= null then
2149             declare
2150                HT : Hash_Table_Type renames Control.Container.HT;
2151                B  : Natural renames HT.Busy;
2152                L  : Natural renames HT.Lock;
2153             begin
2154                B := B + 1;
2155                L := L + 1;
2156             end;
2157          end if;
2158       end Adjust;
2159
2160       ------------------------
2161       -- Constant_Reference --
2162       ------------------------
2163
2164       function Constant_Reference
2165         (Container : aliased Set;
2166          Key       : Key_Type) return Constant_Reference_Type
2167       is
2168          HT   : Hash_Table_Type renames Container'Unrestricted_Access.HT;
2169          Node : constant Node_Access := Key_Keys.Find (HT, Key);
2170
2171       begin
2172          if Node = null then
2173             raise Constraint_Error with "Key not in set";
2174          end if;
2175
2176          if Node.Element = null then
2177             raise Program_Error with "Node has no element";
2178          end if;
2179
2180          declare
2181             B : Natural renames HT.Busy;
2182             L : Natural renames HT.Lock;
2183          begin
2184             return R : constant Constant_Reference_Type :=
2185               (Element => Node.Element.all'Access,
2186                Control => (Controlled with Container'Unrestricted_Access))
2187             do
2188                B := B + 1;
2189                L := L + 1;
2190             end return;
2191          end;
2192       end Constant_Reference;
2193
2194       --------------
2195       -- Contains --
2196       --------------
2197
2198       function Contains
2199         (Container : Set;
2200          Key       : Key_Type) return Boolean
2201       is
2202       begin
2203          return Find (Container, Key) /= No_Element;
2204       end Contains;
2205
2206       ------------
2207       -- Delete --
2208       ------------
2209
2210       procedure Delete
2211         (Container : in out Set;
2212          Key       : Key_Type)
2213       is
2214          X : Node_Access;
2215
2216       begin
2217          Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X);
2218
2219          if X = null then
2220             raise Constraint_Error with "key not in set";
2221          end if;
2222
2223          Free (X);
2224       end Delete;
2225
2226       -------------
2227       -- Element --
2228       -------------
2229
2230       function Element
2231         (Container : Set;
2232          Key       : Key_Type) return Element_Type
2233       is
2234          HT   : Hash_Table_Type renames Container'Unrestricted_Access.HT;
2235          Node : constant Node_Access := Key_Keys.Find (HT, Key);
2236
2237       begin
2238          if Node = null then
2239             raise Constraint_Error with "key not in set";
2240          end if;
2241
2242          return Node.Element.all;
2243       end Element;
2244
2245       -------------------------
2246       -- Equivalent_Key_Node --
2247       -------------------------
2248
2249       function Equivalent_Key_Node
2250         (Key  : Key_Type;
2251          Node : Node_Access) return Boolean is
2252       begin
2253          return Equivalent_Keys (Key, Generic_Keys.Key (Node.Element.all));
2254       end Equivalent_Key_Node;
2255
2256       -------------
2257       -- Exclude --
2258       -------------
2259
2260       procedure Exclude
2261         (Container : in out Set;
2262          Key       : Key_Type)
2263       is
2264          X : Node_Access;
2265       begin
2266          Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X);
2267          Free (X);
2268       end Exclude;
2269
2270       --------------
2271       -- Finalize --
2272       --------------
2273
2274       procedure Finalize (Control : in out Reference_Control_Type) is
2275       begin
2276          if Control.Container /= null then
2277             declare
2278                HT : Hash_Table_Type renames Control.Container.HT;
2279                B  : Natural renames HT.Busy;
2280                L  : Natural renames HT.Lock;
2281             begin
2282                B := B - 1;
2283                L := L - 1;
2284             end;
2285
2286             if Hash (Key (Control.Old_Pos)) /= Control.Old_Hash then
2287                HT_Ops.Delete_Node_At_Index
2288                  (Control.Container.HT, Control.Index, Control.Old_Pos.Node);
2289                raise Program_Error;
2290             end if;
2291
2292             Control.Container := null;
2293          end if;
2294       end Finalize;
2295
2296       ----------
2297       -- Find --
2298       ----------
2299
2300       function Find
2301         (Container : Set;
2302          Key       : Key_Type) return Cursor
2303       is
2304          HT   : Hash_Table_Type renames Container'Unrestricted_Access.HT;
2305          Node : constant Node_Access := Key_Keys.Find (HT, Key);
2306       begin
2307          return (if Node = null then No_Element
2308                  else Cursor'(Container'Unrestricted_Access, Node));
2309       end Find;
2310
2311       ---------
2312       -- Key --
2313       ---------
2314
2315       function Key (Position : Cursor) return Key_Type is
2316       begin
2317          if Position.Node = null then
2318             raise Constraint_Error with
2319               "Position cursor equals No_Element";
2320          end if;
2321
2322          if Position.Node.Element = null then
2323             raise Program_Error with "Position cursor is bad";
2324          end if;
2325
2326          pragma Assert (Vet (Position), "bad cursor in function Key");
2327
2328          return Key (Position.Node.Element.all);
2329       end Key;
2330
2331       ----------
2332       -- Read --
2333       ----------
2334
2335       procedure Read
2336         (Stream : not null access Root_Stream_Type'Class;
2337          Item   : out Reference_Type)
2338       is
2339       begin
2340          raise Program_Error with "attempt to stream reference";
2341       end Read;
2342
2343       ------------------------------
2344       -- Reference_Preserving_Key --
2345       ------------------------------
2346
2347       function Reference_Preserving_Key
2348         (Container : aliased in out Set;
2349          Position  : Cursor) return Reference_Type
2350       is
2351       begin
2352          if Position.Container = null then
2353             raise Constraint_Error with "Position cursor has no element";
2354          end if;
2355
2356          if Position.Container /= Container'Unrestricted_Access then
2357             raise Program_Error with
2358               "Position cursor designates wrong container";
2359          end if;
2360
2361          if Position.Node.Element = null then
2362             raise Program_Error with "Node has no element";
2363          end if;
2364
2365          pragma Assert
2366            (Vet (Position),
2367             "bad cursor in function Reference_Preserving_Key");
2368
2369          declare
2370             HT : Hash_Table_Type renames Container.HT;
2371             B  : Natural renames HT.Busy;
2372             L  : Natural renames HT.Lock;
2373          begin
2374             return R : constant Reference_Type :=
2375                          (Element => Position.Node.Element.all'Access,
2376                           Control =>
2377                             (Controlled with
2378                               Container => Container'Access,
2379                               Index     => HT_Ops.Index (HT, Position.Node),
2380                               Old_Pos   => Position,
2381                               Old_Hash  => Hash (Key (Position))))
2382          do
2383                B := B + 1;
2384                L := L + 1;
2385             end return;
2386          end;
2387       end Reference_Preserving_Key;
2388
2389       function Reference_Preserving_Key
2390         (Container : aliased in out Set;
2391          Key       : Key_Type) return Reference_Type
2392       is
2393          Node : constant Node_Access := Key_Keys.Find (Container.HT, Key);
2394
2395       begin
2396          if Node = null then
2397             raise Constraint_Error with "Key not in set";
2398          end if;
2399
2400          if Node.Element = null then
2401             raise Program_Error with "Node has no element";
2402          end if;
2403
2404          declare
2405             HT : Hash_Table_Type renames Container.HT;
2406             B  : Natural renames HT.Busy;
2407             L  : Natural renames HT.Lock;
2408             P  : constant Cursor := Find (Container, Key);
2409          begin
2410             return R : constant Reference_Type :=
2411                          (Element => Node.Element.all'Access,
2412                           Control =>
2413                             (Controlled with
2414                               Container => Container'Access,
2415                               Index     => HT_Ops.Index (HT, P.Node),
2416                               Old_Pos   => P,
2417                               Old_Hash  => Hash (Key)))
2418             do
2419                B := B + 1;
2420                L := L + 1;
2421             end return;
2422          end;
2423       end Reference_Preserving_Key;
2424
2425       -------------
2426       -- Replace --
2427       -------------
2428
2429       procedure Replace
2430         (Container : in out Set;
2431          Key       : Key_Type;
2432          New_Item  : Element_Type)
2433       is
2434          Node : constant Node_Access := Key_Keys.Find (Container.HT, Key);
2435
2436       begin
2437          if Node = null then
2438             raise Constraint_Error with
2439               "attempt to replace key not in set";
2440          end if;
2441
2442          Replace_Element (Container.HT, Node, New_Item);
2443       end Replace;
2444
2445       -----------------------------------
2446       -- Update_Element_Preserving_Key --
2447       -----------------------------------
2448
2449       procedure Update_Element_Preserving_Key
2450         (Container : in out Set;
2451          Position  : Cursor;
2452          Process   : not null access
2453            procedure (Element : in out Element_Type))
2454       is
2455          HT   : Hash_Table_Type renames Container.HT;
2456          Indx : Hash_Type;
2457
2458       begin
2459          if Position.Node = null then
2460             raise Constraint_Error with
2461               "Position cursor equals No_Element";
2462          end if;
2463
2464          if Position.Node.Element = null
2465            or else Position.Node.Next = Position.Node
2466          then
2467             raise Program_Error with "Position cursor is bad";
2468          end if;
2469
2470          if Position.Container /= Container'Unrestricted_Access then
2471             raise Program_Error with
2472               "Position cursor designates wrong set";
2473          end if;
2474
2475          if HT.Buckets = null
2476            or else HT.Buckets'Length = 0
2477            or else HT.Length = 0
2478          then
2479             raise Program_Error with "Position cursor is bad (set is empty)";
2480          end if;
2481
2482          pragma Assert
2483            (Vet (Position),
2484             "bad cursor in Update_Element_Preserving_Key");
2485
2486          --  Per AI05-0022, the container implementation is required to detect
2487          --  element tampering by a generic actual subprogram.
2488
2489          declare
2490             E : Element_Type renames Position.Node.Element.all;
2491             K : constant Key_Type := Key (E);
2492
2493             B : Natural renames HT.Busy;
2494             L : Natural renames HT.Lock;
2495
2496             Eq : Boolean;
2497
2498          begin
2499             B := B + 1;
2500             L := L + 1;
2501
2502             begin
2503                Indx := HT_Ops.Index (HT, Position.Node);
2504                Process (E);
2505                Eq := Equivalent_Keys (K, Key (E));
2506
2507             exception
2508                when others =>
2509                   L := L - 1;
2510                   B := B - 1;
2511
2512                   raise;
2513             end;
2514
2515             L := L - 1;
2516             B := B - 1;
2517
2518             if Eq then
2519                return;
2520             end if;
2521          end;
2522
2523          if HT.Buckets (Indx) = Position.Node then
2524             HT.Buckets (Indx) := Position.Node.Next;
2525
2526          else
2527             declare
2528                Prev : Node_Access := HT.Buckets (Indx);
2529
2530             begin
2531                while Prev.Next /= Position.Node loop
2532                   Prev := Prev.Next;
2533
2534                   if Prev = null then
2535                      raise Program_Error with
2536                        "Position cursor is bad (node not found)";
2537                   end if;
2538                end loop;
2539
2540                Prev.Next := Position.Node.Next;
2541             end;
2542          end if;
2543
2544          HT.Length := HT.Length - 1;
2545
2546          declare
2547             X : Node_Access := Position.Node;
2548
2549          begin
2550             Free (X);
2551          end;
2552
2553          raise Program_Error with "key was modified";
2554       end Update_Element_Preserving_Key;
2555
2556       -----------
2557       -- Write --
2558       -----------
2559
2560       procedure Write
2561         (Stream : not null access Root_Stream_Type'Class;
2562          Item   : Reference_Type)
2563       is
2564       begin
2565          raise Program_Error with "attempt to stream reference";
2566       end Write;
2567
2568    end Generic_Keys;
2569
2570 end Ada.Containers.Indefinite_Hashed_Sets;