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