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