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