gcc/ada/a-cohase.adb

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