gcc/ada/a-cihama.adb

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