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