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