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-2007, 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 : not null 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 : not null 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       pragma Unreferenced (Position);
 572
 573       Inserted : Boolean;
 574
 575    begin
 576       Insert (Container, Key, New_Item, Position, Inserted);
 577
 578       if not Inserted then
 579          raise Constraint_Error with
 580            "attempt to insert key already in map";
 581       end if;
 582    end Insert;
 583
 584    --------------
 585    -- Is_Empty --
 586    --------------
 587
 588    function Is_Empty (Container : Map) return Boolean is
 589    begin
 590       return Container.HT.Length = 0;
 591    end Is_Empty;
 592
 593    -------------
 594    -- Iterate --
 595    -------------
 596
 597    procedure Iterate
 598      (Container : Map;
 599       Process   : not null access procedure (Position : Cursor))
 600    is
 601       procedure Process_Node (Node : Node_Access);
 602       pragma Inline (Process_Node);
 603
 604       procedure Local_Iterate is
 605          new HT_Ops.Generic_Iteration (Process_Node);
 606
 607       ------------------
 608       -- Process_Node --
 609       ------------------
 610
 611       procedure Process_Node (Node : Node_Access) is
 612       begin
 613          Process (Cursor'(Container'Unchecked_Access, Node));
 614       end Process_Node;
 615
 616       B : Natural renames Container'Unrestricted_Access.HT.Busy;
 617
 618    --  Start of processing Iterate
 619
 620    begin
 621       B := B + 1;
 622
 623       begin
 624          Local_Iterate (Container.HT);
 625       exception
 626          when others =>
 627             B := B - 1;
 628             raise;
 629       end;
 630
 631       B := B - 1;
 632    end Iterate;
 633
 634    ---------
 635    -- Key --
 636    ---------
 637
 638    function Key (Position : Cursor) return Key_Type is
 639    begin
 640       if Position.Node = null then
 641          raise Constraint_Error with
 642            "Position cursor of function Key equals No_Element";
 643       end if;
 644
 645       if Position.Node.Key = null then
 646          raise Program_Error with
 647            "Position cursor of function Key is bad";
 648       end if;
 649
 650       pragma Assert (Vet (Position), "bad cursor in function Key");
 651
 652       return Position.Node.Key.all;
 653    end Key;
 654
 655    ------------
 656    -- Length --
 657    ------------
 658
 659    function Length (Container : Map) return Count_Type is
 660    begin
 661       return Container.HT.Length;
 662    end Length;
 663
 664    ----------
 665    -- Move --
 666    ----------
 667
 668    procedure Move
 669      (Target : in out Map;
 670       Source : in out Map)
 671    is
 672    begin
 673       HT_Ops.Move (Target => Target.HT, Source => Source.HT);
 674    end Move;
 675
 676    ----------
 677    -- Next --
 678    ----------
 679
 680    function Next (Node : Node_Access) return Node_Access is
 681    begin
 682       return Node.Next;
 683    end Next;
 684
 685    procedure Next (Position : in out Cursor) is
 686    begin
 687       Position := Next (Position);
 688    end Next;
 689
 690    function Next (Position : Cursor) return Cursor is
 691    begin
 692       if Position.Node = null then
 693          return No_Element;
 694       end if;
 695
 696       if Position.Node.Key = null
 697         or else Position.Node.Element = null
 698       then
 699          raise Program_Error with "Position cursor of Next is bad";
 700       end if;
 701
 702       pragma Assert (Vet (Position), "Position cursor of Next is bad");
 703
 704       declare
 705          HT   : Hash_Table_Type renames Position.Container.HT;
 706          Node : constant Node_Access := HT_Ops.Next (HT, Position.Node);
 707
 708       begin
 709          if Node = null then
 710             return No_Element;
 711          end if;
 712
 713          return Cursor'(Position.Container, Node);
 714       end;
 715    end Next;
 716
 717    -------------------
 718    -- Query_Element --
 719    -------------------
 720
 721    procedure Query_Element
 722      (Position : Cursor;
 723       Process  : not null access procedure (Key     : Key_Type;
 724                                             Element : Element_Type))
 725    is
 726    begin
 727       if Position.Node = null then
 728          raise Constraint_Error with
 729            "Position cursor of Query_Element equals No_Element";
 730       end if;
 731
 732       if Position.Node.Key = null
 733         or else Position.Node.Element = null
 734       then
 735          raise Program_Error with
 736            "Position cursor of Query_Element is bad";
 737       end if;
 738
 739       pragma Assert (Vet (Position), "bad cursor in Query_Element");
 740
 741       declare
 742          M  : Map renames Position.Container.all;
 743          HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
 744
 745          B : Natural renames HT.Busy;
 746          L : Natural renames HT.Lock;
 747
 748       begin
 749          B := B + 1;
 750          L := L + 1;
 751
 752          declare
 753             K : Key_Type renames Position.Node.Key.all;
 754             E : Element_Type renames Position.Node.Element.all;
 755
 756          begin
 757             Process (K, E);
 758          exception
 759             when others =>
 760                L := L - 1;
 761                B := B - 1;
 762                raise;
 763          end;
 764
 765          L := L - 1;
 766          B := B - 1;
 767       end;
 768    end Query_Element;
 769
 770    ----------
 771    -- Read --
 772    ----------
 773
 774    procedure Read_Nodes is new HT_Ops.Generic_Read (Read_Node);
 775
 776    procedure Read
 777      (Stream    : not null access Root_Stream_Type'Class;
 778       Container : out Map)
 779    is
 780    begin
 781       Read_Nodes (Stream, Container.HT);
 782    end Read;
 783
 784    procedure Read
 785      (Stream : not null access Root_Stream_Type'Class;
 786       Item   : out Cursor)
 787    is
 788    begin
 789       raise Program_Error with "attempt to stream map cursor";
 790    end Read;
 791
 792    ---------------
 793    -- Read_Node --
 794    ---------------
 795
 796    function Read_Node
 797      (Stream : not null access Root_Stream_Type'Class) return Node_Access
 798    is
 799       Node : Node_Access := new Node_Type;
 800
 801    begin
 802       begin
 803          Node.Key := new Key_Type'(Key_Type'Input (Stream));
 804       exception
 805          when others =>
 806             Free (Node);
 807             raise;
 808       end;
 809
 810       begin
 811          Node.Element := new Element_Type'(Element_Type'Input (Stream));
 812       exception
 813          when others =>
 814             Free_Key (Node.Key);
 815             Free (Node);
 816             raise;
 817       end;
 818
 819       return Node;
 820    end Read_Node;
 821
 822    -------------
 823    -- Replace --
 824    -------------
 825
 826    procedure Replace
 827      (Container : in out Map;
 828       Key       : Key_Type;
 829       New_Item  : Element_Type)
 830    is
 831       Node : constant Node_Access := Key_Ops.Find (Container.HT, Key);
 832
 833       K : Key_Access;
 834       E : Element_Access;
 835
 836    begin
 837       if Node = null then
 838          raise Constraint_Error with
 839            "attempt to replace key not in map";
 840       end if;
 841
 842       if Container.HT.Lock > 0 then
 843          raise Program_Error with
 844            "Replace attempted to tamper with cursors (map is locked)";
 845       end if;
 846
 847       K := Node.Key;
 848       E := Node.Element;
 849
 850       Node.Key := new Key_Type'(Key);
 851
 852       begin
 853          Node.Element := new Element_Type'(New_Item);
 854       exception
 855          when others =>
 856             Free_Key (K);
 857             raise;
 858       end;
 859
 860       Free_Key (K);
 861       Free_Element (E);
 862    end Replace;
 863
 864    ---------------------
 865    -- Replace_Element --
 866    ---------------------
 867
 868    procedure Replace_Element
 869      (Container : in out Map;
 870       Position  : Cursor;
 871       New_Item  : Element_Type)
 872    is
 873    begin
 874       if Position.Node = null then
 875          raise Constraint_Error with
 876            "Position cursor of Replace_Element equals No_Element";
 877       end if;
 878
 879       if Position.Node.Key = null
 880         or else Position.Node.Element = null
 881       then
 882          raise Program_Error with
 883            "Position cursor of Replace_Element is bad";
 884       end if;
 885
 886       if Position.Container /= Container'Unrestricted_Access then
 887          raise Program_Error with
 888            "Position cursor of Replace_Element designates wrong map";
 889       end if;
 890
 891       if Position.Container.HT.Lock > 0 then
 892          raise Program_Error with
 893            "Replace_Element attempted to tamper with cursors (map is locked)";
 894       end if;
 895
 896       pragma Assert (Vet (Position), "bad cursor in Replace_Element");
 897
 898       declare
 899          X : Element_Access := Position.Node.Element;
 900
 901       begin
 902          Position.Node.Element := new Element_Type'(New_Item);
 903          Free_Element (X);
 904       end;
 905    end Replace_Element;
 906
 907    ----------------------
 908    -- Reserve_Capacity --
 909    ----------------------
 910
 911    procedure Reserve_Capacity
 912      (Container : in out Map;
 913       Capacity  : Count_Type)
 914    is
 915    begin
 916       HT_Ops.Reserve_Capacity (Container.HT, Capacity);
 917    end Reserve_Capacity;
 918
 919    --------------
 920    -- Set_Next --
 921    --------------
 922
 923    procedure Set_Next (Node : Node_Access; Next : Node_Access) is
 924    begin
 925       Node.Next := Next;
 926    end Set_Next;
 927
 928    --------------------
 929    -- Update_Element --
 930    --------------------
 931
 932    procedure Update_Element
 933      (Container : in out Map;
 934       Position  : Cursor;
 935       Process   : not null access procedure (Key     : Key_Type;
 936                                              Element : in out Element_Type))
 937    is
 938    begin
 939       if Position.Node = null then
 940          raise Constraint_Error with
 941            "Position cursor of Update_Element equals No_Element";
 942       end if;
 943
 944       if Position.Node.Key = null
 945         or else Position.Node.Element = null
 946       then
 947          raise Program_Error with
 948            "Position cursor of Update_Element is bad";
 949       end if;
 950
 951       if Position.Container /= Container'Unrestricted_Access then
 952          raise Program_Error with
 953            "Position cursor of Update_Element designates wrong map";
 954       end if;
 955
 956       pragma Assert (Vet (Position), "bad cursor in Update_Element");
 957
 958       declare
 959          HT : Hash_Table_Type renames Container.HT;
 960
 961          B : Natural renames HT.Busy;
 962          L : Natural renames HT.Lock;
 963
 964       begin
 965          B := B + 1;
 966          L := L + 1;
 967
 968          declare
 969             K : Key_Type renames Position.Node.Key.all;
 970
 971             E : Element_Type renames Position.Node.Element.all;
 972             pragma Unreferenced (E);
 973
 974          begin
 975             Process (K, E);
 976
 977          exception
 978             when others =>
 979                L := L - 1;
 980                B := B - 1;
 981                raise;
 982          end;
 983
 984          L := L - 1;
 985          B := B - 1;
 986       end;
 987    end Update_Element;
 988
 989    ---------
 990    -- Vet --
 991    ---------
 992
 993    function Vet (Position : Cursor) return Boolean is
 994    begin
 995       if Position.Node = null then
 996          return Position.Container = null;
 997       end if;
 998
 999       if Position.Container = null then
1000          return False;
1001       end if;
1002
1003       if Position.Node.Next = Position.Node then
1004          return False;
1005       end if;
1006
1007       if Position.Node.Key = null then
1008          return False;
1009       end if;
1010
1011       if Position.Node.Element = null then
1012          return False;
1013       end if;
1014
1015       declare
1016          HT : Hash_Table_Type renames Position.Container.HT;
1017          X  : Node_Access;
1018
1019       begin
1020          if HT.Length = 0 then
1021             return False;
1022          end if;
1023
1024          if HT.Buckets = null
1025            or else HT.Buckets'Length = 0
1026          then
1027             return False;
1028          end if;
1029
1030          X := HT.Buckets (Key_Ops.Index (HT, Position.Node.Key.all));
1031
1032          for J in 1 .. HT.Length loop
1033             if X = Position.Node then
1034                return True;
1035             end if;
1036
1037             if X = null then
1038                return False;
1039             end if;
1040
1041             if X = X.Next then -- to prevent endless loop
1042                return False;
1043             end if;
1044
1045             X := X.Next;
1046          end loop;
1047
1048          return False;
1049       end;
1050    end Vet;
1051
1052    -----------
1053    -- Write --
1054    -----------
1055
1056    procedure Write_Nodes is new HT_Ops.Generic_Write (Write_Node);
1057
1058    procedure Write
1059      (Stream    : not null access Root_Stream_Type'Class;
1060       Container : Map)
1061    is
1062    begin
1063       Write_Nodes (Stream, Container.HT);
1064    end Write;
1065
1066    procedure Write
1067      (Stream : not null access Root_Stream_Type'Class;
1068       Item   : Cursor)
1069    is
1070    begin
1071       raise Program_Error with "attempt to stream map cursor";
1072    end Write;
1073
1074    ----------------
1075    -- Write_Node --
1076    ----------------
1077
1078    procedure Write_Node
1079      (Stream : not null access Root_Stream_Type'Class;
1080       Node   : Node_Access)
1081    is
1082    begin
1083       Key_Type'Output (Stream, Node.Key.all);
1084       Element_Type'Output (Stream, Node.Element.all);
1085    end Write_Node;
1086
1087 end Ada.Containers.Indefinite_Hashed_Maps;