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