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