gcc/ada/a-cihama.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT LIBRARY COMPONENTS                          --
   4 --                                                                          --
   5 --                      A D A . C O N T A I N E R S .                       --
   6 --               I N D E F I N I T E _ H A S H E D _ M A P S                --
   7 --                                                                          --
   8 --                                 B o d y                                  --
   9 --                                                                          --
  10 --          Copyright (C) 2004-2006, Free Software Foundation, Inc.         --
  11 --                                                                          --
  12 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  20 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  21 -- Boston, MA 02110-1301, USA.                                              --
  22 --                                                                          --
  23 -- As a special exception,  if other files  instantiate  generics from this --
  24 -- unit, or you link  this unit with other files  to produce an executable, --
  25 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  26 -- covered  by the  GNU  General  Public  License.  This exception does not --
  27 -- however invalidate  any other reasons why  the executable file  might be --
  28 -- covered by the  GNU Public License.                                      --
  29 --                                                                          --
  30 -- This unit has originally being developed by Matthew J Heaney.            --
  31 ------------------------------------------------------------------------------
  32
  33 with Ada.Containers.Hash_Tables.Generic_Operations;
  34 pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Operations);
  35
  36 with Ada.Containers.Hash_Tables.Generic_Keys;
  37 pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys);
  38
  39 with Ada.Unchecked_Deallocation;
  40
  41 package body Ada.Containers.Indefinite_Hashed_Maps is
  42
  43    procedure Free_Key is
  44       new Ada.Unchecked_Deallocation (Key_Type, Key_Access);
  45
  46    procedure Free_Element is
  47       new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
  48
  49    -----------------------
  50    -- Local Subprograms --
  51    -----------------------
  52
  53    function Copy_Node (Node : 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    function Find_Equal_Key
  62      (R_HT   : Hash_Table_Type;
  63       L_Node : Node_Access) return Boolean;
  64
  65    procedure Free (X : in out Node_Access);
  66    --  pragma Inline (Free);
  67
  68    function Hash_Node (Node : Node_Access) return Hash_Type;
  69    pragma Inline (Hash_Node);
  70
  71    function Next (Node : Node_Access) return Node_Access;
  72    pragma Inline (Next);
  73
  74    function Read_Node
  75      (Stream : access Root_Stream_Type'Class) return Node_Access;
  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 : access Root_Stream_Type'Class;
  84       Node   : Node_Access);
  85
  86    --------------------------
  87    -- Local Instantiations --
  88    --------------------------
  89
  90    package HT_Ops is
  91       new Ada.Containers.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
 100       new Hash_Tables.Generic_Keys
 101        (HT_Types  => HT_Types,
 102         Next      => Next,
 103         Set_Next  => Set_Next,
 104         Key_Type  => Key_Type,
 105         Hash      => Hash,
 106         Equivalent_Keys => Equivalent_Key_Node);
 107
 108    ---------
 109    -- "=" --
 110    ---------
 111
 112    function Is_Equal is new HT_Ops.Generic_Equal (Find_Equal_Key);
 113
 114    function "=" (Left, Right : Map) return Boolean is
 115    begin
 116       return Is_Equal (Left.HT, Right.HT);
 117    end "=";
 118
 119    ------------
 120    -- Adjust --
 121    ------------
 122
 123    procedure Adjust (Container : in out Map) is
 124    begin
 125       HT_Ops.Adjust (Container.HT);
 126    end Adjust;
 127
 128    --------------
 129    -- Capacity --
 130    --------------
 131
 132    function Capacity (Container : Map) return Count_Type is
 133    begin
 134       return HT_Ops.Capacity (Container.HT);
 135    end Capacity;
 136
 137    -----------
 138    -- Clear --
 139    -----------
 140
 141    procedure Clear (Container : in out Map) is
 142    begin
 143       HT_Ops.Clear (Container.HT);
 144    end Clear;
 145
 146    --------------
 147    -- Contains --
 148    --------------
 149
 150    function Contains (Container : Map; Key : Key_Type) return Boolean is
 151    begin
 152       return Find (Container, Key) /= No_Element;
 153    end Contains;
 154
 155    ---------------
 156    -- Copy_Node --
 157    ---------------
 158
 159    function Copy_Node (Node : Node_Access) return Node_Access is
 160       K : Key_Access := new Key_Type'(Node.Key.all);
 161       E : Element_Access;
 162
 163    begin
 164       E := new Element_Type'(Node.Element.all);
 165       return new Node_Type'(K, E, null);
 166
 167    exception
 168       when others =>
 169          Free_Key (K);
 170          Free_Element (E);
 171          raise;
 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 elements (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.all;
 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       if Position.Node.Element = null then
 240          raise Program_Error with
 241            "Position cursor of function Element is bad";
 242       end if;
 243
 244       pragma Assert (Vet (Position), "bad cursor in function Element");
 245
 246       return Position.Node.Element.all;
 247    end Element;
 248
 249    -------------------------
 250    -- Equivalent_Key_Node --
 251    -------------------------
 252
 253    function Equivalent_Key_Node
 254      (Key  : Key_Type;
 255       Node : Node_Access) return Boolean
 256    is
 257    begin
 258       return Equivalent_Keys (Key, Node.Key.all);
 259    end Equivalent_Key_Node;
 260
 261    ---------------------
 262    -- Equivalent_Keys --
 263    ---------------------
 264
 265    function Equivalent_Keys (Left, Right : Cursor) return Boolean is
 266    begin
 267       if Left.Node = null then
 268          raise Constraint_Error with
 269            "Left cursor of Equivalent_Keys equals No_Element";
 270       end if;
 271
 272       if Right.Node = null then
 273          raise Constraint_Error with
 274            "Right cursor of Equivalent_Keys equals No_Element";
 275       end if;
 276
 277       if Left.Node.Key = null then
 278          raise Program_Error with
 279            "Left cursor of Equivalent_Keys is bad";
 280       end if;
 281
 282       if Right.Node.Key = null then
 283          raise Program_Error with
 284            "Right cursor of Equivalent_Keys is bad";
 285       end if;
 286
 287       pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Keys");
 288       pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Keys");
 289
 290       return Equivalent_Keys (Left.Node.Key.all, Right.Node.Key.all);
 291    end Equivalent_Keys;
 292
 293    function Equivalent_Keys
 294      (Left  : Cursor;
 295       Right : Key_Type) return Boolean
 296    is
 297    begin
 298       if Left.Node = null then
 299          raise Constraint_Error with
 300            "Left cursor of Equivalent_Keys equals No_Element";
 301       end if;
 302
 303       if Left.Node.Key = null then
 304          raise Program_Error with
 305            "Left cursor of Equivalent_Keys is bad";
 306       end if;
 307
 308       pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Keys");
 309
 310       return Equivalent_Keys (Left.Node.Key.all, Right);
 311    end Equivalent_Keys;
 312
 313    function Equivalent_Keys
 314      (Left  : Key_Type;
 315       Right : Cursor) return Boolean
 316    is
 317    begin
 318       if Right.Node = null then
 319          raise Constraint_Error with
 320            "Right cursor of Equivalent_Keys equals No_Element";
 321       end if;
 322
 323       if Right.Node.Key = null then
 324          raise Program_Error with
 325            "Right cursor of Equivalent_Keys is bad";
 326       end if;
 327
 328       pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Keys");
 329
 330       return Equivalent_Keys (Left, Right.Node.Key.all);
 331    end Equivalent_Keys;
 332
 333    -------------
 334    -- Exclude --
 335    -------------
 336
 337    procedure Exclude (Container : in out Map; Key : Key_Type) is
 338       X : Node_Access;
 339    begin
 340       Key_Ops.Delete_Key_Sans_Free (Container.HT, Key, X);
 341       Free (X);
 342    end Exclude;
 343
 344    --------------
 345    -- Finalize --
 346    --------------
 347
 348    procedure Finalize (Container : in out Map) is
 349    begin
 350       HT_Ops.Finalize (Container.HT);
 351    end Finalize;
 352
 353    ----------
 354    -- Find --
 355    ----------
 356
 357    function Find (Container : Map; Key : Key_Type) return Cursor is
 358       Node : constant Node_Access := Key_Ops.Find (Container.HT, Key);
 359
 360    begin
 361       if Node = null then
 362          return No_Element;
 363       end if;
 364
 365       return Cursor'(Container'Unchecked_Access, Node);
 366    end Find;
 367
 368    --------------------
 369    -- Find_Equal_Key --
 370    --------------------
 371
 372    function Find_Equal_Key
 373      (R_HT   : Hash_Table_Type;
 374       L_Node : Node_Access) return Boolean
 375    is
 376       R_Index : constant Hash_Type := Key_Ops.Index (R_HT, L_Node.Key.all);
 377       R_Node  : Node_Access := R_HT.Buckets (R_Index);
 378
 379    begin
 380       while R_Node /= null loop
 381          if Equivalent_Keys (L_Node.Key.all, R_Node.Key.all) then
 382             return L_Node.Element.all = R_Node.Element.all;
 383          end if;
 384
 385          R_Node := R_Node.Next;
 386       end loop;
 387
 388       return False;
 389    end Find_Equal_Key;
 390
 391    -----------
 392    -- First --
 393    -----------
 394
 395    function First (Container : Map) return Cursor is
 396       Node : constant Node_Access := HT_Ops.First (Container.HT);
 397
 398    begin
 399       if Node = null then
 400          return No_Element;
 401       end if;
 402
 403       return Cursor'(Container'Unchecked_Access, Node);
 404    end First;
 405
 406    ----------
 407    -- Free --
 408    ----------
 409
 410    procedure Free (X : in out Node_Access) is
 411       procedure Deallocate is
 412          new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
 413    begin
 414       if X = null then
 415          return;
 416       end if;
 417
 418       X.Next := X;  --  detect mischief (in Vet)
 419
 420       begin
 421          Free_Key (X.Key);
 422       exception
 423          when others =>
 424             X.Key := null;
 425
 426             begin
 427                Free_Element (X.Element);
 428             exception
 429                when others =>
 430                   X.Element := null;
 431             end;
 432
 433             Deallocate (X);
 434             raise;
 435       end;
 436
 437       begin
 438          Free_Element (X.Element);
 439       exception
 440          when others =>
 441             X.Element := null;
 442
 443             Deallocate (X);
 444             raise;
 445       end;
 446
 447       Deallocate (X);
 448    end Free;
 449
 450    -----------------
 451    -- Has_Element --
 452    -----------------
 453
 454    function Has_Element (Position : Cursor) return Boolean is
 455    begin
 456       pragma Assert (Vet (Position), "bad cursor in Has_Element");
 457       return Position.Node /= null;
 458    end Has_Element;
 459
 460    ---------------
 461    -- Hash_Node --
 462    ---------------
 463
 464    function Hash_Node (Node : Node_Access) return Hash_Type is
 465    begin
 466       return Hash (Node.Key.all);
 467    end Hash_Node;
 468
 469    -------------
 470    -- Include --
 471    -------------
 472
 473    procedure Include
 474      (Container : in out Map;
 475       Key       : Key_Type;
 476       New_Item  : Element_Type)
 477    is
 478       Position : Cursor;
 479       Inserted : Boolean;
 480
 481       K : Key_Access;
 482       E : Element_Access;
 483
 484    begin
 485       Insert (Container, Key, New_Item, Position, Inserted);
 486
 487       if not Inserted then
 488          if Container.HT.Lock > 0 then
 489             raise Program_Error with
 490               "Include attempted to tamper with cursors (map is locked)";
 491          end if;
 492
 493          K := Position.Node.Key;
 494          E := Position.Node.Element;
 495
 496          Position.Node.Key := new Key_Type'(Key);
 497
 498          begin
 499             Position.Node.Element := new Element_Type'(New_Item);
 500          exception
 501             when others =>
 502                Free_Key (K);
 503                raise;
 504          end;
 505
 506          Free_Key (K);
 507          Free_Element (E);
 508       end if;
 509    end Include;
 510
 511    ------------
 512    -- Insert --
 513    ------------
 514
 515    procedure Insert
 516      (Container : in out Map;
 517       Key       : Key_Type;
 518       New_Item  : Element_Type;
 519       Position  : out Cursor;
 520       Inserted  : out Boolean)
 521    is
 522       function New_Node (Next : Node_Access) return Node_Access;
 523
 524       procedure Local_Insert is
 525         new Key_Ops.Generic_Conditional_Insert (New_Node);
 526
 527       --------------
 528       -- New_Node --
 529       --------------
 530
 531       function New_Node (Next : Node_Access) return Node_Access is
 532          K  : Key_Access := new Key_Type'(Key);
 533          E  : Element_Access;
 534
 535       begin
 536          E := new Element_Type'(New_Item);
 537          return new Node_Type'(K, E, Next);
 538       exception
 539          when others =>
 540             Free_Key (K);
 541             Free_Element (E);
 542             raise;
 543       end New_Node;
 544
 545       HT : Hash_Table_Type renames Container.HT;
 546
 547    --  Start of processing for Insert
 548
 549    begin
 550       if HT_Ops.Capacity (HT) = 0 then
 551          HT_Ops.Reserve_Capacity (HT, 1);
 552       end if;
 553
 554       Local_Insert (HT, Key, Position.Node, Inserted);
 555
 556       if Inserted
 557         and then HT.Length > HT_Ops.Capacity (HT)
 558       then
 559          HT_Ops.Reserve_Capacity (HT, HT.Length);
 560       end if;
 561
 562       Position.Container := Container'Unchecked_Access;
 563    end Insert;
 564
 565    procedure Insert
 566      (Container : in out Map;
 567       Key       : Key_Type;
 568       New_Item  : Element_Type)
 569    is
 570       Position : Cursor;
 571       Inserted : Boolean;
 572
 573    begin
 574       Insert (Container, Key, New_Item, Position, Inserted);
 575
 576       if not Inserted then
 577          raise Constraint_Error with
 578            "attempt to insert key already in map";
 579       end if;
 580    end Insert;
 581
 582    --------------
 583    -- Is_Empty --
 584    --------------
 585
 586    function Is_Empty (Container : Map) return Boolean is
 587    begin
 588       return Container.HT.Length = 0;
 589    end Is_Empty;
 590
 591    -------------
 592    -- Iterate --
 593    -------------
 594
 595    procedure Iterate
 596      (Container : Map;
 597       Process   : not null access procedure (Position : Cursor))
 598    is
 599       procedure Process_Node (Node : Node_Access);
 600       pragma Inline (Process_Node);
 601
 602       procedure Local_Iterate is
 603          new HT_Ops.Generic_Iteration (Process_Node);
 604
 605       ------------------
 606       -- Process_Node --
 607       ------------------
 608
 609       procedure Process_Node (Node : Node_Access) is
 610       begin
 611          Process (Cursor'(Container'Unchecked_Access, Node));
 612       end Process_Node;
 613
 614       B : Natural renames Container'Unrestricted_Access.HT.Busy;
 615
 616    --  Start of processing Iterate
 617
 618    begin
 619       B := B + 1;
 620
 621       begin
 622          Local_Iterate (Container.HT);
 623       exception
 624          when others =>
 625             B := B - 1;
 626             raise;
 627       end;
 628
 629       B := B - 1;
 630    end Iterate;
 631
 632    ---------
 633    -- Key --
 634    ---------
 635
 636    function Key (Position : Cursor) return Key_Type is
 637    begin
 638       if Position.Node = null then
 639          raise Constraint_Error with
 640            "Position cursor of function Key equals No_Element";
 641       end if;
 642
 643       if Position.Node.Key = null then
 644          raise Program_Error with
 645            "Position cursor of function Key is bad";
 646       end if;
 647
 648       pragma Assert (Vet (Position), "bad cursor in function Key");
 649
 650       return Position.Node.Key.all;
 651    end Key;
 652
 653    ------------
 654    -- Length --
 655    ------------
 656
 657    function Length (Container : Map) return Count_Type is
 658    begin
 659       return Container.HT.Length;
 660    end Length;
 661
 662    ----------
 663    -- Move --
 664    ----------
 665
 666    procedure Move
 667      (Target : in out Map;
 668       Source : in out Map)
 669    is
 670    begin
 671       HT_Ops.Move (Target => Target.HT, Source => Source.HT);
 672    end Move;
 673
 674    ----------
 675    -- Next --
 676    ----------
 677
 678    function Next (Node : Node_Access) return Node_Access is
 679    begin
 680       return Node.Next;
 681    end Next;
 682
 683    procedure Next (Position : in out Cursor) is
 684    begin
 685       Position := Next (Position);
 686    end Next;
 687
 688    function Next (Position : Cursor) return Cursor is
 689    begin
 690       if Position.Node = null then
 691          return No_Element;
 692       end if;
 693
 694       if Position.Node.Key = null
 695         or else Position.Node.Element = null
 696       then
 697          raise Program_Error with "Position cursor of Next is bad";
 698       end if;
 699
 700       pragma Assert (Vet (Position), "Position cursor of Next is bad");
 701
 702       declare
 703          HT   : Hash_Table_Type renames Position.Container.HT;
 704          Node : constant Node_Access := HT_Ops.Next (HT, Position.Node);
 705
 706       begin
 707          if Node = null then
 708             return No_Element;
 709          end if;
 710
 711          return Cursor'(Position.Container, Node);
 712       end;
 713    end Next;
 714
 715    -------------------
 716    -- Query_Element --
 717    -------------------
 718
 719    procedure Query_Element
 720      (Position : Cursor;
 721       Process  : not null access procedure (Key     : Key_Type;
 722                                             Element : Element_Type))
 723    is
 724    begin
 725       if Position.Node = null then
 726          raise Constraint_Error with
 727            "Position cursor of Query_Element equals No_Element";
 728       end if;
 729
 730       if Position.Node.Key = null
 731         or else Position.Node.Element = null
 732       then
 733          raise Program_Error with
 734            "Position cursor of Query_Element is bad";
 735       end if;
 736
 737       pragma Assert (Vet (Position), "bad cursor in Query_Element");
 738
 739       declare
 740          M  : Map renames Position.Container.all;
 741          HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
 742
 743          B : Natural renames HT.Busy;
 744          L : Natural renames HT.Lock;
 745
 746       begin
 747          B := B + 1;
 748          L := L + 1;
 749
 750          declare
 751             K : Key_Type renames Position.Node.Key.all;
 752             E : Element_Type renames Position.Node.Element.all;
 753
 754          begin
 755             Process (K, E);
 756          exception
 757             when others =>
 758                L := L - 1;
 759                B := B - 1;
 760                raise;
 761          end;
 762
 763          L := L - 1;
 764          B := B - 1;
 765       end;
 766    end Query_Element;
 767
 768    ----------
 769    -- Read --
 770    ----------
 771
 772    procedure Read_Nodes is new HT_Ops.Generic_Read (Read_Node);
 773
 774    procedure Read
 775      (Stream    : access Root_Stream_Type'Class;
 776       Container : out Map)
 777    is
 778    begin
 779       Read_Nodes (Stream, Container.HT);
 780    end Read;
 781
 782    procedure Read
 783      (Stream : access Root_Stream_Type'Class;
 784       Item   : out Cursor)
 785    is
 786    begin
 787       raise Program_Error with "attempt to stream map cursor";
 788    end Read;
 789
 790    ---------------
 791    -- Read_Node --
 792    ---------------
 793
 794    function Read_Node
 795      (Stream : access Root_Stream_Type'Class) return Node_Access
 796    is
 797       Node : Node_Access := new Node_Type;
 798
 799    begin
 800       begin
 801          Node.Key := new Key_Type'(Key_Type'Input (Stream));
 802       exception
 803          when others =>
 804             Free (Node);
 805             raise;
 806       end;
 807
 808       begin
 809          Node.Element := new Element_Type'(Element_Type'Input (Stream));
 810       exception
 811          when others =>
 812             Free_Key (Node.Key);
 813             Free (Node);
 814             raise;
 815       end;
 816
 817       return Node;
 818    end Read_Node;
 819
 820    -------------
 821    -- Replace --
 822    -------------
 823
 824    procedure Replace
 825      (Container : in out Map;
 826       Key       : Key_Type;
 827       New_Item  : Element_Type)
 828    is
 829       Node : constant Node_Access := Key_Ops.Find (Container.HT, Key);
 830
 831       K : Key_Access;
 832       E : Element_Access;
 833
 834    begin
 835       if Node = null then
 836          raise Constraint_Error with
 837            "attempt to replace key not in map";
 838       end if;
 839
 840       if Container.HT.Lock > 0 then
 841          raise Program_Error with
 842            "Replace attempted to tamper with cursors (map is locked)";
 843       end if;
 844
 845       K := Node.Key;
 846       E := Node.Element;
 847
 848       Node.Key := new Key_Type'(Key);
 849
 850       begin
 851          Node.Element := new Element_Type'(New_Item);
 852       exception
 853          when others =>
 854             Free_Key (K);
 855             raise;
 856       end;
 857
 858       Free_Key (K);
 859       Free_Element (E);
 860    end Replace;
 861
 862    ---------------------
 863    -- Replace_Element --
 864    ---------------------
 865
 866    procedure Replace_Element
 867      (Container : in out Map;
 868       Position  : Cursor;
 869       New_Item  : Element_Type)
 870    is
 871    begin
 872       if Position.Node = null then
 873          raise Constraint_Error with
 874            "Position cursor of Replace_Element equals No_Element";
 875       end if;
 876
 877       if Position.Node.Key = null
 878         or else Position.Node.Element = null
 879       then
 880          raise Program_Error with
 881            "Position cursor of Replace_Element is bad";
 882       end if;
 883
 884       if Position.Container /= Container'Unrestricted_Access then
 885          raise Program_Error with
 886            "Position cursor of Replace_Element designates wrong map";
 887       end if;
 888
 889       if Position.Container.HT.Lock > 0 then
 890          raise Program_Error with
 891            "Replace_Element attempted to tamper with cursors (map is locked)";
 892       end if;
 893
 894       pragma Assert (Vet (Position), "bad cursor in Replace_Element");
 895
 896       declare
 897          X : Element_Access := Position.Node.Element;
 898
 899       begin
 900          Position.Node.Element := new Element_Type'(New_Item);
 901          Free_Element (X);
 902       end;
 903    end Replace_Element;
 904
 905    ----------------------
 906    -- Reserve_Capacity --
 907    ----------------------
 908
 909    procedure Reserve_Capacity
 910      (Container : in out Map;
 911       Capacity  : Count_Type)
 912    is
 913    begin
 914       HT_Ops.Reserve_Capacity (Container.HT, Capacity);
 915    end Reserve_Capacity;
 916
 917    --------------
 918    -- Set_Next --
 919    --------------
 920
 921    procedure Set_Next (Node : Node_Access; Next : Node_Access) is
 922    begin
 923       Node.Next := Next;
 924    end Set_Next;
 925
 926    --------------------
 927    -- Update_Element --
 928    --------------------
 929
 930    procedure Update_Element
 931      (Container : in out Map;
 932       Position  : Cursor;
 933       Process   : not null access procedure (Key     : Key_Type;
 934                                              Element : in out Element_Type))
 935    is
 936    begin
 937       if Position.Node = null then
 938          raise Constraint_Error with
 939            "Position cursor of Update_Element equals No_Element";
 940       end if;
 941
 942       if Position.Node.Key = null
 943         or else Position.Node.Element = null
 944       then
 945          raise Program_Error with
 946            "Position cursor of Update_Element is bad";
 947       end if;
 948
 949       if Position.Container /= Container'Unrestricted_Access then
 950          raise Program_Error with
 951            "Position cursor of Update_Element designates wrong map";
 952       end if;
 953
 954       pragma Assert (Vet (Position), "bad cursor in Update_Element");
 955
 956       declare
 957          HT : Hash_Table_Type renames Container.HT;
 958
 959          B : Natural renames HT.Busy;
 960          L : Natural renames HT.Lock;
 961
 962       begin
 963          B := B + 1;
 964          L := L + 1;
 965
 966          declare
 967             K : Key_Type renames Position.Node.Key.all;
 968             E : Element_Type renames Position.Node.Element.all;
 969          begin
 970             Process (K, E);
 971          exception
 972             when others =>
 973                L := L - 1;
 974                B := B - 1;
 975                raise;
 976          end;
 977
 978          L := L - 1;
 979          B := B - 1;
 980       end;
 981    end Update_Element;
 982
 983    ---------
 984    -- Vet --
 985    ---------
 986
 987    function Vet (Position : Cursor) return Boolean is
 988    begin
 989       if Position.Node = null then
 990          return Position.Container = null;
 991       end if;
 992
 993       if Position.Container = null then
 994          return False;
 995       end if;
 996
 997       if Position.Node.Next = Position.Node then
 998          return False;
 999       end if;
1000
1001       if Position.Node.Key = null then
1002          return False;
1003       end if;
1004
1005       if Position.Node.Element = null then
1006          return False;
1007       end if;
1008
1009       declare
1010          HT : Hash_Table_Type renames Position.Container.HT;
1011          X  : Node_Access;
1012
1013       begin
1014          if HT.Length = 0 then
1015             return False;
1016          end if;
1017
1018          if HT.Buckets = null
1019            or else HT.Buckets'Length = 0
1020          then
1021             return False;
1022          end if;
1023
1024          X := HT.Buckets (Key_Ops.Index (HT, Position.Node.Key.all));
1025
1026          for J in 1 .. HT.Length loop
1027             if X = Position.Node then
1028                return True;
1029             end if;
1030
1031             if X = null then
1032                return False;
1033             end if;
1034
1035             if X = X.Next then -- to prevent endless loop
1036                return False;
1037             end if;
1038
1039             X := X.Next;
1040          end loop;
1041
1042          return False;
1043       end;
1044    end Vet;
1045
1046    -----------
1047    -- Write --
1048    -----------
1049
1050    procedure Write_Nodes is new HT_Ops.Generic_Write (Write_Node);
1051
1052    procedure Write
1053      (Stream    : access Root_Stream_Type'Class;
1054       Container : Map)
1055    is
1056    begin
1057       Write_Nodes (Stream, Container.HT);
1058    end Write;
1059
1060    procedure Write
1061      (Stream : access Root_Stream_Type'Class;
1062       Item   : Cursor)
1063    is
1064    begin
1065       raise Program_Error with "attempt to stream map cursor";
1066    end Write;
1067
1068    ----------------
1069    -- Write_Node --
1070    ----------------
1071
1072    procedure Write_Node
1073      (Stream : access Root_Stream_Type'Class;
1074       Node   : Node_Access)
1075    is
1076    begin
1077       Key_Type'Output (Stream, Node.Key.all);
1078       Element_Type'Output (Stream, Node.Element.all);
1079    end Write_Node;
1080
1081 end Ada.Containers.Indefinite_Hashed_Maps;