gcc/ada/a-cohama.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT LIBRARY COMPONENTS                          --
   4 --                                                                          --
   5 --            A D A . C O N T A I N E R S . H A S H E D _ M A P S           --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 2004-2014, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- This unit was originally developed by Matthew J Heaney.                  --
  28 ------------------------------------------------------------------------------
  29
  30 with Ada.Unchecked_Deallocation;
  31
  32 with Ada.Containers.Hash_Tables.Generic_Operations;
  33 pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Operations);
  34
  35 with Ada.Containers.Hash_Tables.Generic_Keys;
  36 pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys);
  37
  38 with System; use type System.Address;
  39
  40 package body Ada.Containers.Hashed_Maps is
  41
  42    pragma Annotate (CodePeer, Skip_Analysis);
  43
  44    -----------------------
  45    -- Local Subprograms --
  46    -----------------------
  47
  48    function Copy_Node
  49      (Source : Node_Access) return Node_Access;
  50    pragma Inline (Copy_Node);
  51
  52    function Equivalent_Key_Node
  53      (Key  : Key_Type;
  54       Node : Node_Access) return Boolean;
  55    pragma Inline (Equivalent_Key_Node);
  56
  57    procedure Free (X : in out Node_Access);
  58
  59    function Find_Equal_Key
  60      (R_HT   : Hash_Table_Type;
  61       L_Node : Node_Access) return Boolean;
  62
  63    function Hash_Node (Node : Node_Access) return Hash_Type;
  64    pragma Inline (Hash_Node);
  65
  66    function Next (Node : Node_Access) return Node_Access;
  67    pragma Inline (Next);
  68
  69    function Read_Node
  70      (Stream : not null access Root_Stream_Type'Class) return Node_Access;
  71    pragma Inline (Read_Node);
  72
  73    procedure Set_Next (Node : Node_Access; Next : Node_Access);
  74    pragma Inline (Set_Next);
  75
  76    function Vet (Position : Cursor) return Boolean;
  77
  78    procedure Write_Node
  79      (Stream : not null access Root_Stream_Type'Class;
  80       Node   : Node_Access);
  81    pragma Inline (Write_Node);
  82
  83    --------------------------
  84    -- Local Instantiations --
  85    --------------------------
  86
  87    package HT_Ops is new Hash_Tables.Generic_Operations
  88      (HT_Types  => HT_Types,
  89       Hash_Node => Hash_Node,
  90       Next      => Next,
  91       Set_Next  => Set_Next,
  92       Copy_Node => Copy_Node,
  93       Free      => Free);
  94
  95    package Key_Ops is new Hash_Tables.Generic_Keys
  96      (HT_Types        => HT_Types,
  97       Next            => Next,
  98       Set_Next        => Set_Next,
  99       Key_Type        => Key_Type,
 100       Hash            => Hash,
 101       Equivalent_Keys => Equivalent_Key_Node);
 102
 103    function Is_Equal is new HT_Ops.Generic_Equal (Find_Equal_Key);
 104
 105    procedure Read_Nodes  is new HT_Ops.Generic_Read (Read_Node);
 106    procedure Write_Nodes is new HT_Ops.Generic_Write (Write_Node);
 107
 108    ---------
 109    -- "=" --
 110    ---------
 111
 112    function "=" (Left, Right : Map) return Boolean is
 113    begin
 114       return Is_Equal (Left.HT, Right.HT);
 115    end "=";
 116
 117    ------------
 118    -- Adjust --
 119    ------------
 120
 121    procedure Adjust (Container : in out Map) is
 122    begin
 123       HT_Ops.Adjust (Container.HT);
 124    end Adjust;
 125
 126    procedure Adjust (Control : in out Reference_Control_Type) is
 127    begin
 128       if Control.Container /= null then
 129          declare
 130             HT : Hash_Table_Type renames Control.Container.all.HT;
 131             B  : Natural renames HT.Busy;
 132             L  : Natural renames HT.Lock;
 133          begin
 134             B := B + 1;
 135             L := L + 1;
 136          end;
 137       end if;
 138    end Adjust;
 139
 140    ------------
 141    -- Assign --
 142    ------------
 143
 144    procedure Assign (Target : in out Map; Source : Map) is
 145       procedure Insert_Item (Node : Node_Access);
 146       pragma Inline (Insert_Item);
 147
 148       procedure Insert_Items is new HT_Ops.Generic_Iteration (Insert_Item);
 149
 150       -----------------
 151       -- Insert_Item --
 152       -----------------
 153
 154       procedure Insert_Item (Node : Node_Access) is
 155       begin
 156          Target.Insert (Key => Node.Key, New_Item => Node.Element);
 157       end Insert_Item;
 158
 159    --  Start of processing for Assign
 160
 161    begin
 162       if Target'Address = Source'Address then
 163          return;
 164       end if;
 165
 166       Target.Clear;
 167
 168       if Target.Capacity < Source.Length then
 169          Target.Reserve_Capacity (Source.Length);
 170       end if;
 171
 172       Insert_Items (Source.HT);
 173    end Assign;
 174
 175    --------------
 176    -- Capacity --
 177    --------------
 178
 179    function Capacity (Container : Map) return Count_Type is
 180    begin
 181       return HT_Ops.Capacity (Container.HT);
 182    end Capacity;
 183
 184    -----------
 185    -- Clear --
 186    -----------
 187
 188    procedure Clear (Container : in out Map) is
 189    begin
 190       HT_Ops.Clear (Container.HT);
 191    end Clear;
 192
 193    ------------------------
 194    -- Constant_Reference --
 195    ------------------------
 196
 197    function Constant_Reference
 198      (Container : aliased Map;
 199       Position  : Cursor) return Constant_Reference_Type
 200    is
 201    begin
 202       if Position.Container = null then
 203          raise Constraint_Error with
 204            "Position cursor has no element";
 205       end if;
 206
 207       if Position.Container /= Container'Unrestricted_Access then
 208          raise Program_Error with
 209            "Position cursor designates wrong map";
 210       end if;
 211
 212       pragma Assert
 213         (Vet (Position),
 214          "Position cursor in Constant_Reference is bad");
 215
 216       declare
 217          HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT;
 218          B  : Natural renames HT.Busy;
 219          L  : Natural renames HT.Lock;
 220       begin
 221          return R : constant Constant_Reference_Type :=
 222            (Element => Position.Node.Element'Access,
 223             Control => (Controlled with Position.Container))
 224          do
 225             B := B + 1;
 226             L := L + 1;
 227          end return;
 228       end;
 229    end Constant_Reference;
 230
 231    function Constant_Reference
 232      (Container : aliased Map;
 233       Key       : Key_Type) return Constant_Reference_Type
 234    is
 235       HT   : Hash_Table_Type renames Container'Unrestricted_Access.HT;
 236       Node : constant Node_Access := Key_Ops.Find (HT, Key);
 237
 238    begin
 239       if Node = null then
 240          raise Constraint_Error with "key not in map";
 241       end if;
 242
 243       declare
 244          B  : Natural renames HT.Busy;
 245          L  : Natural renames HT.Lock;
 246       begin
 247          return R : constant Constant_Reference_Type :=
 248            (Element => Node.Element'Access,
 249             Control => (Controlled with Container'Unrestricted_Access))
 250          do
 251             B := B + 1;
 252             L := L + 1;
 253          end return;
 254       end;
 255    end Constant_Reference;
 256
 257    --------------
 258    -- Contains --
 259    --------------
 260
 261    function Contains (Container : Map; Key : Key_Type) return Boolean is
 262    begin
 263       return Find (Container, Key) /= No_Element;
 264    end Contains;
 265
 266    ----------
 267    -- Copy --
 268    ----------
 269
 270    function Copy
 271      (Source   : Map;
 272       Capacity : Count_Type := 0) return Map
 273    is
 274       C : Count_Type;
 275
 276    begin
 277       if Capacity = 0 then
 278          C := Source.Length;
 279
 280       elsif Capacity >= Source.Length then
 281          C := Capacity;
 282
 283       else
 284          raise Capacity_Error
 285            with "Requested capacity is less than Source length";
 286       end if;
 287
 288       return Target : Map do
 289          Target.Reserve_Capacity (C);
 290          Target.Assign (Source);
 291       end return;
 292    end Copy;
 293
 294    ---------------
 295    -- Copy_Node --
 296    ---------------
 297
 298    function Copy_Node
 299      (Source : Node_Access) return Node_Access
 300    is
 301       Target : constant Node_Access :=
 302         new Node_Type'(Key     => Source.Key,
 303                        Element => Source.Element,
 304                        Next    => null);
 305    begin
 306       return Target;
 307    end Copy_Node;
 308
 309    ------------
 310    -- Delete --
 311    ------------
 312
 313    procedure Delete (Container : in out Map; Key : Key_Type) is
 314       X : Node_Access;
 315
 316    begin
 317       Key_Ops.Delete_Key_Sans_Free (Container.HT, Key, X);
 318
 319       if X = null then
 320          raise Constraint_Error with "attempt to delete key not in map";
 321       end if;
 322
 323       Free (X);
 324    end Delete;
 325
 326    procedure Delete (Container : in out Map; Position : in out Cursor) is
 327    begin
 328       if Position.Node = null then
 329          raise Constraint_Error with
 330            "Position cursor of Delete equals No_Element";
 331       end if;
 332
 333       if Position.Container /= Container'Unrestricted_Access then
 334          raise Program_Error with
 335            "Position cursor of Delete designates wrong map";
 336       end if;
 337
 338       if Container.HT.Busy > 0 then
 339          raise Program_Error with
 340            "Delete attempted to tamper with cursors (map is busy)";
 341       end if;
 342
 343       pragma Assert (Vet (Position), "bad cursor in Delete");
 344
 345       HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node);
 346
 347       Free (Position.Node);
 348       Position.Container := null;
 349    end Delete;
 350
 351    -------------
 352    -- Element --
 353    -------------
 354
 355    function Element (Container : Map; Key : Key_Type) return Element_Type is
 356       HT   : Hash_Table_Type renames Container'Unrestricted_Access.HT;
 357       Node : constant Node_Access := Key_Ops.Find (HT, Key);
 358
 359    begin
 360       if Node = null then
 361          raise Constraint_Error with
 362            "no element available because key not in map";
 363       end if;
 364
 365       return Node.Element;
 366    end Element;
 367
 368    function Element (Position : Cursor) return Element_Type is
 369    begin
 370       if Position.Node = null then
 371          raise Constraint_Error with
 372            "Position cursor of function Element equals No_Element";
 373       end if;
 374
 375       pragma Assert (Vet (Position), "bad cursor in function Element");
 376
 377       return Position.Node.Element;
 378    end Element;
 379
 380    -------------------------
 381    -- Equivalent_Key_Node --
 382    -------------------------
 383
 384    function Equivalent_Key_Node
 385      (Key  : Key_Type;
 386       Node : Node_Access) return Boolean is
 387    begin
 388       return Equivalent_Keys (Key, Node.Key);
 389    end Equivalent_Key_Node;
 390
 391    ---------------------
 392    -- Equivalent_Keys --
 393    ---------------------
 394
 395    function Equivalent_Keys (Left, Right : Cursor)
 396      return Boolean is
 397    begin
 398       if Left.Node = null then
 399          raise Constraint_Error with
 400            "Left cursor of Equivalent_Keys equals No_Element";
 401       end if;
 402
 403       if Right.Node = null then
 404          raise Constraint_Error with
 405            "Right cursor of Equivalent_Keys equals No_Element";
 406       end if;
 407
 408       pragma Assert (Vet (Left), "Left cursor of Equivalent_Keys is bad");
 409       pragma Assert (Vet (Right), "Right cursor of Equivalent_Keys is bad");
 410
 411       return Equivalent_Keys (Left.Node.Key, Right.Node.Key);
 412    end Equivalent_Keys;
 413
 414    function Equivalent_Keys (Left : Cursor; Right : Key_Type) return Boolean is
 415    begin
 416       if Left.Node = null then
 417          raise Constraint_Error with
 418            "Left cursor of Equivalent_Keys equals No_Element";
 419       end if;
 420
 421       pragma Assert (Vet (Left), "Left cursor in Equivalent_Keys is bad");
 422
 423       return Equivalent_Keys (Left.Node.Key, Right);
 424    end Equivalent_Keys;
 425
 426    function Equivalent_Keys (Left : Key_Type; Right : Cursor) return Boolean is
 427    begin
 428       if Right.Node = null then
 429          raise Constraint_Error with
 430            "Right cursor of Equivalent_Keys equals No_Element";
 431       end if;
 432
 433       pragma Assert (Vet (Right), "Right cursor of Equivalent_Keys is bad");
 434
 435       return Equivalent_Keys (Left, Right.Node.Key);
 436    end Equivalent_Keys;
 437
 438    -------------
 439    -- Exclude --
 440    -------------
 441
 442    procedure Exclude (Container : in out Map; Key : Key_Type) is
 443       X : Node_Access;
 444    begin
 445       Key_Ops.Delete_Key_Sans_Free (Container.HT, Key, X);
 446       Free (X);
 447    end Exclude;
 448
 449    --------------
 450    -- Finalize --
 451    --------------
 452
 453    procedure Finalize (Container : in out Map) is
 454    begin
 455       HT_Ops.Finalize (Container.HT);
 456    end Finalize;
 457
 458    procedure Finalize (Object : in out Iterator) is
 459    begin
 460       if Object.Container /= null then
 461          declare
 462             B : Natural renames Object.Container.all.HT.Busy;
 463          begin
 464             B := B - 1;
 465          end;
 466       end if;
 467    end Finalize;
 468
 469    procedure Finalize (Control : in out Reference_Control_Type) is
 470    begin
 471       if Control.Container /= null then
 472          declare
 473             HT : Hash_Table_Type renames Control.Container.all.HT;
 474             B  : Natural renames HT.Busy;
 475             L  : Natural renames HT.Lock;
 476          begin
 477             B := B - 1;
 478             L := L - 1;
 479          end;
 480
 481          Control.Container := null;
 482       end if;
 483    end Finalize;
 484
 485    ----------
 486    -- Find --
 487    ----------
 488
 489    function Find (Container : Map; Key : Key_Type) return Cursor is
 490       HT   : Hash_Table_Type renames Container'Unrestricted_Access.HT;
 491       Node : constant Node_Access := Key_Ops.Find (HT, Key);
 492
 493    begin
 494       if Node = null then
 495          return No_Element;
 496       end if;
 497
 498       return Cursor'(Container'Unrestricted_Access, Node);
 499    end Find;
 500
 501    --------------------
 502    -- Find_Equal_Key --
 503    --------------------
 504
 505    function Find_Equal_Key
 506      (R_HT   : Hash_Table_Type;
 507       L_Node : Node_Access) return Boolean
 508    is
 509       R_Index : constant Hash_Type := Key_Ops.Index (R_HT, L_Node.Key);
 510       R_Node  : Node_Access := R_HT.Buckets (R_Index);
 511
 512    begin
 513       while R_Node /= null loop
 514          if Equivalent_Keys (L_Node.Key, R_Node.Key) then
 515             return L_Node.Element = R_Node.Element;
 516          end if;
 517
 518          R_Node := R_Node.Next;
 519       end loop;
 520
 521       return False;
 522    end Find_Equal_Key;
 523
 524    -----------
 525    -- First --
 526    -----------
 527
 528    function First (Container : Map) return Cursor is
 529       Node : constant Node_Access := HT_Ops.First (Container.HT);
 530
 531    begin
 532       if Node = null then
 533          return No_Element;
 534       end if;
 535
 536       return Cursor'(Container'Unrestricted_Access, Node);
 537    end First;
 538
 539    function First (Object : Iterator) return Cursor is
 540    begin
 541       return Object.Container.First;
 542    end First;
 543
 544    ----------
 545    -- Free --
 546    ----------
 547
 548    procedure Free (X : in out Node_Access) is
 549       procedure Deallocate is
 550          new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
 551    begin
 552       if X /= null then
 553          X.Next := X;     --  detect mischief (in Vet)
 554          Deallocate (X);
 555       end if;
 556    end Free;
 557
 558    -----------------
 559    -- Has_Element --
 560    -----------------
 561
 562    function Has_Element (Position : Cursor) return Boolean is
 563    begin
 564       pragma Assert (Vet (Position), "bad cursor in Has_Element");
 565       return Position.Node /= null;
 566    end Has_Element;
 567
 568    ---------------
 569    -- Hash_Node --
 570    ---------------
 571
 572    function Hash_Node (Node : Node_Access) return Hash_Type is
 573    begin
 574       return Hash (Node.Key);
 575    end Hash_Node;
 576
 577    -------------
 578    -- Include --
 579    -------------
 580
 581    procedure Include
 582      (Container : in out Map;
 583       Key       : Key_Type;
 584       New_Item  : Element_Type)
 585    is
 586       Position : Cursor;
 587       Inserted : Boolean;
 588
 589    begin
 590       Insert (Container, Key, New_Item, Position, Inserted);
 591
 592       if not Inserted then
 593          if Container.HT.Lock > 0 then
 594             raise Program_Error with
 595               "Include attempted to tamper with elements (map is locked)";
 596          end if;
 597
 598          Position.Node.Key := Key;
 599          Position.Node.Element := New_Item;
 600       end if;
 601    end Include;
 602
 603    ------------
 604    -- Insert --
 605    ------------
 606
 607    procedure Insert
 608      (Container : in out Map;
 609       Key       : Key_Type;
 610       Position  : out Cursor;
 611       Inserted  : out Boolean)
 612    is
 613       function New_Node (Next : Node_Access) return Node_Access;
 614       pragma Inline (New_Node);
 615
 616       procedure Local_Insert is
 617         new Key_Ops.Generic_Conditional_Insert (New_Node);
 618
 619       --------------
 620       -- New_Node --
 621       --------------
 622
 623       function New_Node (Next : Node_Access) return Node_Access is
 624       begin
 625          return new Node_Type'(Key     => Key,
 626                                Element => <>,
 627                                Next    => Next);
 628       end New_Node;
 629
 630       HT : Hash_Table_Type renames Container.HT;
 631
 632    --  Start of processing for Insert
 633
 634    begin
 635       if HT_Ops.Capacity (HT) = 0 then
 636          HT_Ops.Reserve_Capacity (HT, 1);
 637       end if;
 638
 639       Local_Insert (HT, Key, Position.Node, Inserted);
 640
 641       if Inserted
 642         and then HT.Length > HT_Ops.Capacity (HT)
 643       then
 644          HT_Ops.Reserve_Capacity (HT, HT.Length);
 645       end if;
 646
 647       Position.Container := Container'Unrestricted_Access;
 648    end Insert;
 649
 650    procedure Insert
 651      (Container : in out Map;
 652       Key       : Key_Type;
 653       New_Item  : Element_Type;
 654       Position  : out Cursor;
 655       Inserted  : out Boolean)
 656    is
 657       function New_Node (Next : Node_Access) return Node_Access;
 658       pragma Inline (New_Node);
 659
 660       procedure Local_Insert is
 661         new Key_Ops.Generic_Conditional_Insert (New_Node);
 662
 663       --------------
 664       -- New_Node --
 665       --------------
 666
 667       function New_Node (Next : Node_Access) return Node_Access is
 668       begin
 669          return new Node_Type'(Key, New_Item, Next);
 670       end New_Node;
 671
 672       HT : Hash_Table_Type renames Container.HT;
 673
 674    --  Start of processing for Insert
 675
 676    begin
 677       if HT_Ops.Capacity (HT) = 0 then
 678          HT_Ops.Reserve_Capacity (HT, 1);
 679       end if;
 680
 681       Local_Insert (HT, Key, Position.Node, Inserted);
 682
 683       if Inserted
 684         and then HT.Length > HT_Ops.Capacity (HT)
 685       then
 686          HT_Ops.Reserve_Capacity (HT, HT.Length);
 687       end if;
 688
 689       Position.Container := Container'Unrestricted_Access;
 690    end Insert;
 691
 692    procedure Insert
 693      (Container : in out Map;
 694       Key       : Key_Type;
 695       New_Item  : Element_Type)
 696    is
 697       Position : Cursor;
 698       pragma Unreferenced (Position);
 699
 700       Inserted : Boolean;
 701
 702    begin
 703       Insert (Container, Key, New_Item, Position, Inserted);
 704
 705       if not Inserted then
 706          raise Constraint_Error with
 707            "attempt to insert key already in map";
 708       end if;
 709    end Insert;
 710
 711    --------------
 712    -- Is_Empty --
 713    --------------
 714
 715    function Is_Empty (Container : Map) return Boolean is
 716    begin
 717       return Container.HT.Length = 0;
 718    end Is_Empty;
 719
 720    -------------
 721    -- Iterate --
 722    -------------
 723
 724    procedure Iterate
 725      (Container : Map;
 726       Process   : not null access procedure (Position : Cursor))
 727    is
 728       procedure Process_Node (Node : Node_Access);
 729       pragma Inline (Process_Node);
 730
 731       procedure Local_Iterate is new HT_Ops.Generic_Iteration (Process_Node);
 732
 733       ------------------
 734       -- Process_Node --
 735       ------------------
 736
 737       procedure Process_Node (Node : Node_Access) is
 738       begin
 739          Process (Cursor'(Container'Unrestricted_Access, Node));
 740       end Process_Node;
 741
 742       B : Natural renames Container'Unrestricted_Access.all.HT.Busy;
 743
 744    --  Start of processing for Iterate
 745
 746    begin
 747       B := B + 1;
 748
 749       begin
 750          Local_Iterate (Container.HT);
 751       exception
 752          when others =>
 753             B := B - 1;
 754             raise;
 755       end;
 756
 757       B := B - 1;
 758    end Iterate;
 759
 760    function Iterate
 761      (Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'Class
 762    is
 763       B  : Natural renames Container'Unrestricted_Access.all.HT.Busy;
 764    begin
 765       return It : constant Iterator :=
 766         (Limited_Controlled with Container => Container'Unrestricted_Access)
 767       do
 768          B := B + 1;
 769       end return;
 770    end Iterate;
 771
 772    ---------
 773    -- Key --
 774    ---------
 775
 776    function Key (Position : Cursor) return Key_Type is
 777    begin
 778       if Position.Node = null then
 779          raise Constraint_Error with
 780            "Position cursor of function Key equals No_Element";
 781       end if;
 782
 783       pragma Assert (Vet (Position), "bad cursor in function Key");
 784
 785       return Position.Node.Key;
 786    end Key;
 787
 788    ------------
 789    -- Length --
 790    ------------
 791
 792    function Length (Container : Map) return Count_Type is
 793    begin
 794       return Container.HT.Length;
 795    end Length;
 796
 797    ----------
 798    -- Move --
 799    ----------
 800
 801    procedure Move
 802      (Target : in out Map;
 803       Source : in out Map)
 804    is
 805    begin
 806       HT_Ops.Move (Target => Target.HT, Source => Source.HT);
 807    end Move;
 808
 809    ----------
 810    -- Next --
 811    ----------
 812
 813    function Next (Node : Node_Access) return Node_Access is
 814    begin
 815       return Node.Next;
 816    end Next;
 817
 818    function Next (Position : Cursor) return Cursor is
 819    begin
 820       if Position.Node = null then
 821          return No_Element;
 822       end if;
 823
 824       pragma Assert (Vet (Position), "bad cursor in function Next");
 825
 826       declare
 827          HT   : Hash_Table_Type renames Position.Container.HT;
 828          Node : constant Node_Access := HT_Ops.Next (HT, Position.Node);
 829
 830       begin
 831          if Node = null then
 832             return No_Element;
 833          end if;
 834
 835          return Cursor'(Position.Container, Node);
 836       end;
 837    end Next;
 838
 839    procedure Next (Position : in out Cursor) is
 840    begin
 841       Position := Next (Position);
 842    end Next;
 843
 844    function Next
 845      (Object   : Iterator;
 846       Position : Cursor) return Cursor
 847    is
 848    begin
 849       if Position.Container = null then
 850          return No_Element;
 851       end if;
 852
 853       if Position.Container /= Object.Container then
 854          raise Program_Error with
 855            "Position cursor of Next designates wrong map";
 856       end if;
 857
 858       return Next (Position);
 859    end Next;
 860
 861    -------------------
 862    -- Query_Element --
 863    -------------------
 864
 865    procedure Query_Element
 866      (Position : Cursor;
 867       Process  : not null access
 868                    procedure (Key : Key_Type; Element : Element_Type))
 869    is
 870    begin
 871       if Position.Node = null then
 872          raise Constraint_Error with
 873            "Position cursor of Query_Element equals No_Element";
 874       end if;
 875
 876       pragma Assert (Vet (Position), "bad cursor in Query_Element");
 877
 878       declare
 879          M  : Map renames Position.Container.all;
 880          HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
 881
 882          B : Natural renames HT.Busy;
 883          L : Natural renames HT.Lock;
 884
 885       begin
 886          B := B + 1;
 887          L := L + 1;
 888
 889          declare
 890             K : Key_Type renames Position.Node.Key;
 891             E : Element_Type renames Position.Node.Element;
 892          begin
 893             Process (K, E);
 894          exception
 895             when others =>
 896                L := L - 1;
 897                B := B - 1;
 898                raise;
 899          end;
 900
 901          L := L - 1;
 902          B := B - 1;
 903       end;
 904    end Query_Element;
 905
 906    ----------
 907    -- Read --
 908    ----------
 909
 910    procedure Read
 911      (Stream    : not null access Root_Stream_Type'Class;
 912       Container : out Map)
 913    is
 914    begin
 915       Read_Nodes (Stream, Container.HT);
 916    end Read;
 917
 918    procedure Read
 919      (Stream : not null access Root_Stream_Type'Class;
 920       Item   : out Cursor)
 921    is
 922    begin
 923       raise Program_Error with "attempt to stream map cursor";
 924    end Read;
 925
 926    procedure Read
 927      (Stream : not null access Root_Stream_Type'Class;
 928       Item   : out Reference_Type)
 929    is
 930    begin
 931       raise Program_Error with "attempt to stream reference";
 932    end Read;
 933
 934    procedure Read
 935      (Stream : not null access Root_Stream_Type'Class;
 936       Item   : out Constant_Reference_Type)
 937    is
 938    begin
 939       raise Program_Error with "attempt to stream reference";
 940    end Read;
 941
 942    ---------------
 943    -- Reference --
 944    ---------------
 945
 946    function Reference
 947      (Container : aliased in out Map;
 948       Position  : Cursor) return Reference_Type
 949    is
 950    begin
 951       if Position.Container = null then
 952          raise Constraint_Error with
 953            "Position cursor has no element";
 954       end if;
 955
 956       if Position.Container /= Container'Unrestricted_Access then
 957          raise Program_Error with
 958            "Position cursor designates wrong map";
 959       end if;
 960
 961       pragma Assert
 962         (Vet (Position),
 963          "Position cursor in function Reference is bad");
 964
 965       declare
 966          HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT;
 967          B  : Natural renames HT.Busy;
 968          L  : Natural renames HT.Lock;
 969       begin
 970          return R : constant Reference_Type :=
 971            (Element => Position.Node.Element'Access,
 972             Control => (Controlled with Position.Container))
 973          do
 974             B := B + 1;
 975             L := L + 1;
 976          end return;
 977       end;
 978    end Reference;
 979
 980    function Reference
 981      (Container : aliased in out Map;
 982       Key       : Key_Type) return Reference_Type
 983    is
 984       HT   : Hash_Table_Type renames Container.HT;
 985       Node : constant Node_Access := Key_Ops.Find (HT, Key);
 986
 987    begin
 988       if Node = null then
 989          raise Constraint_Error with "key not in map";
 990       end if;
 991
 992       declare
 993          B  : Natural renames HT.Busy;
 994          L  : Natural renames HT.Lock;
 995       begin
 996          return R : constant Reference_Type :=
 997            (Element => Node.Element'Access,
 998             Control => (Controlled with Container'Unrestricted_Access))
 999          do
1000             B := B + 1;
1001             L := L + 1;
1002          end return;
1003       end;
1004    end Reference;
1005
1006    ---------------
1007    -- Read_Node --
1008    ---------------
1009
1010    function Read_Node
1011      (Stream : not null access Root_Stream_Type'Class) return Node_Access
1012    is
1013       Node : Node_Access := new Node_Type;
1014
1015    begin
1016       Key_Type'Read (Stream, Node.Key);
1017       Element_Type'Read (Stream, Node.Element);
1018       return Node;
1019
1020    exception
1021       when others =>
1022          Free (Node);
1023          raise;
1024    end Read_Node;
1025
1026    -------------
1027    -- Replace --
1028    -------------
1029
1030    procedure Replace
1031      (Container : in out Map;
1032       Key       : Key_Type;
1033       New_Item  : Element_Type)
1034    is
1035       Node : constant Node_Access := Key_Ops.Find (Container.HT, Key);
1036
1037    begin
1038       if Node = null then
1039          raise Constraint_Error with
1040            "attempt to replace key not in map";
1041       end if;
1042
1043       if Container.HT.Lock > 0 then
1044          raise Program_Error with
1045            "Replace attempted to tamper with elements (map is locked)";
1046       end if;
1047
1048       Node.Key := Key;
1049       Node.Element := New_Item;
1050    end Replace;
1051
1052    ---------------------
1053    -- Replace_Element --
1054    ---------------------
1055
1056    procedure Replace_Element
1057      (Container : in out Map;
1058       Position  : Cursor;
1059       New_Item  : Element_Type)
1060    is
1061    begin
1062       if Position.Node = null then
1063          raise Constraint_Error with
1064            "Position cursor of Replace_Element equals No_Element";
1065       end if;
1066
1067       if Position.Container /= Container'Unrestricted_Access then
1068          raise Program_Error with
1069            "Position cursor of Replace_Element designates wrong map";
1070       end if;
1071
1072       if Position.Container.HT.Lock > 0 then
1073          raise Program_Error with
1074            "Replace_Element attempted to tamper with elements (map is locked)";
1075       end if;
1076
1077       pragma Assert (Vet (Position), "bad cursor in Replace_Element");
1078
1079       Position.Node.Element := New_Item;
1080    end Replace_Element;
1081
1082    ----------------------
1083    -- Reserve_Capacity --
1084    ----------------------
1085
1086    procedure Reserve_Capacity
1087      (Container : in out Map;
1088       Capacity  : Count_Type)
1089    is
1090    begin
1091       HT_Ops.Reserve_Capacity (Container.HT, Capacity);
1092    end Reserve_Capacity;
1093
1094    --------------
1095    -- Set_Next --
1096    --------------
1097
1098    procedure Set_Next (Node : Node_Access; Next : Node_Access) is
1099    begin
1100       Node.Next := Next;
1101    end Set_Next;
1102
1103    --------------------
1104    -- Update_Element --
1105    --------------------
1106
1107    procedure Update_Element
1108      (Container : in out Map;
1109       Position  : Cursor;
1110       Process   : not null access procedure (Key     : Key_Type;
1111                                              Element : in out Element_Type))
1112    is
1113    begin
1114       if Position.Node = null then
1115          raise Constraint_Error with
1116            "Position cursor of Update_Element equals No_Element";
1117       end if;
1118
1119       if Position.Container /= Container'Unrestricted_Access then
1120          raise Program_Error with
1121            "Position cursor of Update_Element designates wrong map";
1122       end if;
1123
1124       pragma Assert (Vet (Position), "bad cursor in Update_Element");
1125
1126       declare
1127          HT : Hash_Table_Type renames Container.HT;
1128          B  : Natural renames HT.Busy;
1129          L  : Natural renames HT.Lock;
1130
1131       begin
1132          B := B + 1;
1133          L := L + 1;
1134
1135          declare
1136             K : Key_Type renames Position.Node.Key;
1137             E : Element_Type renames Position.Node.Element;
1138          begin
1139             Process (K, E);
1140          exception
1141             when others =>
1142                L := L - 1;
1143                B := B - 1;
1144                raise;
1145          end;
1146
1147          L := L - 1;
1148          B := B - 1;
1149       end;
1150    end Update_Element;
1151
1152    ---------
1153    -- Vet --
1154    ---------
1155
1156    function Vet (Position : Cursor) return Boolean is
1157    begin
1158       if Position.Node = null then
1159          return Position.Container = null;
1160       end if;
1161
1162       if Position.Container = null then
1163          return False;
1164       end if;
1165
1166       if Position.Node.Next = Position.Node then
1167          return False;
1168       end if;
1169
1170       declare
1171          HT : Hash_Table_Type renames Position.Container.HT;
1172          X  : Node_Access;
1173
1174       begin
1175          if HT.Length = 0 then
1176             return False;
1177          end if;
1178
1179          if HT.Buckets = null
1180            or else HT.Buckets'Length = 0
1181          then
1182             return False;
1183          end if;
1184
1185          X := HT.Buckets (Key_Ops.Checked_Index (HT, Position.Node.Key));
1186
1187          for J in 1 .. HT.Length loop
1188             if X = Position.Node then
1189                return True;
1190             end if;
1191
1192             if X = null then
1193                return False;
1194             end if;
1195
1196             if X = X.Next then  --  to prevent unnecessary looping
1197                return False;
1198             end if;
1199
1200             X := X.Next;
1201          end loop;
1202
1203          return False;
1204       end;
1205    end Vet;
1206
1207    -----------
1208    -- Write --
1209    -----------
1210
1211    procedure Write
1212      (Stream    : not null access Root_Stream_Type'Class;
1213       Container : Map)
1214    is
1215    begin
1216       Write_Nodes (Stream, Container.HT);
1217    end Write;
1218
1219    procedure Write
1220      (Stream : not null access Root_Stream_Type'Class;
1221       Item   : Cursor)
1222    is
1223    begin
1224       raise Program_Error with "attempt to stream map cursor";
1225    end Write;
1226
1227    procedure Write
1228      (Stream : not null access Root_Stream_Type'Class;
1229       Item   : Reference_Type)
1230    is
1231    begin
1232       raise Program_Error with "attempt to stream reference";
1233    end Write;
1234
1235    procedure Write
1236      (Stream : not null access Root_Stream_Type'Class;
1237       Item   : Constant_Reference_Type)
1238    is
1239    begin
1240       raise Program_Error with "attempt to stream reference";
1241    end Write;
1242
1243    ----------------
1244    -- Write_Node --
1245    ----------------
1246
1247    procedure Write_Node
1248      (Stream : not null access Root_Stream_Type'Class;
1249       Node   : Node_Access)
1250    is
1251    begin
1252       Key_Type'Write (Stream, Node.Key);
1253       Element_Type'Write (Stream, Node.Element);
1254    end Write_Node;
1255
1256 end Ada.Containers.Hashed_Maps;