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