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