gcc/ada/a-cfhase.adb

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