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