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-2011, 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 3,  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.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- This unit was originally developed by Matthew J Heaney.                  --
  28 ------------------------------------------------------------------------------
  29
  30 with Ada.Containers.Hash_Tables.Generic_Operations;
  31 pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Operations);
  32
  33 with Ada.Containers.Hash_Tables.Generic_Keys;
  34 pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys);
  35
  36 with Ada.Unchecked_Deallocation;
  37
  38 with System; use type System.Address;
  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    type Iterator is new Limited_Controlled and
  49      Map_Iterator_Interfaces.Forward_Iterator with
  50    record
  51       Container : Map_Access;
  52    end record;
  53
  54    overriding procedure Finalize (Object : in out Iterator);
  55
  56    overriding function First (Object : Iterator) return Cursor;
  57
  58    overriding function Next
  59      (Object   : Iterator;
  60       Position : Cursor) return Cursor;
  61
  62    -----------------------
  63    -- Local Subprograms --
  64    -----------------------
  65
  66    function Copy_Node (Node : Node_Access) return Node_Access;
  67    pragma Inline (Copy_Node);
  68
  69    function Equivalent_Key_Node
  70      (Key  : Key_Type;
  71       Node : Node_Access) return Boolean;
  72    pragma Inline (Equivalent_Key_Node);
  73
  74    function Find_Equal_Key
  75      (R_HT   : Hash_Table_Type;
  76       L_Node : Node_Access) return Boolean;
  77
  78    procedure Free (X : in out Node_Access);
  79    --  pragma Inline (Free);
  80
  81    function Hash_Node (Node : Node_Access) return Hash_Type;
  82    pragma Inline (Hash_Node);
  83
  84    function Next (Node : Node_Access) return Node_Access;
  85    pragma Inline (Next);
  86
  87    function Read_Node
  88      (Stream : not null access Root_Stream_Type'Class) return Node_Access;
  89
  90    procedure Set_Next (Node : Node_Access; Next : Node_Access);
  91    pragma Inline (Set_Next);
  92
  93    function Vet (Position : Cursor) return Boolean;
  94
  95    procedure Write_Node
  96      (Stream : not null access Root_Stream_Type'Class;
  97       Node   : Node_Access);
  98
  99    --------------------------
 100    -- Local Instantiations --
 101    --------------------------
 102
 103    package HT_Ops is new Ada.Containers.Hash_Tables.Generic_Operations
 104      (HT_Types  => HT_Types,
 105       Hash_Node => Hash_Node,
 106       Next      => Next,
 107       Set_Next  => Set_Next,
 108       Copy_Node => Copy_Node,
 109       Free      => Free);
 110
 111    package Key_Ops is new Hash_Tables.Generic_Keys
 112      (HT_Types        => HT_Types,
 113       Next            => Next,
 114       Set_Next        => Set_Next,
 115       Key_Type        => Key_Type,
 116       Hash            => Hash,
 117       Equivalent_Keys => Equivalent_Key_Node);
 118
 119    ---------
 120    -- "=" --
 121    ---------
 122
 123    function Is_Equal is new HT_Ops.Generic_Equal (Find_Equal_Key);
 124
 125    overriding function "=" (Left, Right : Map) return Boolean is
 126    begin
 127       return Is_Equal (Left.HT, Right.HT);
 128    end "=";
 129
 130    ------------
 131    -- Adjust --
 132    ------------
 133
 134    procedure Adjust (Container : in out Map) is
 135    begin
 136       HT_Ops.Adjust (Container.HT);
 137    end Adjust;
 138
 139    ------------
 140    -- Assign --
 141    ------------
 142
 143    procedure Assign (Target : in out Map; Source : Map) is
 144       procedure Insert_Item (Node : Node_Access);
 145       pragma Inline (Insert_Item);
 146
 147       procedure Insert_Items is new HT_Ops.Generic_Iteration (Insert_Item);
 148
 149       -----------------
 150       -- Insert_Item --
 151       -----------------
 152
 153       procedure Insert_Item (Node : Node_Access) is
 154       begin
 155          Target.Insert (Key => Node.Key.all, New_Item => Node.Element.all);
 156       end Insert_Item;
 157
 158    --  Start of processing for Assign
 159
 160    begin
 161       if Target'Address = Source'Address then
 162          return;
 163       end if;
 164
 165       Target.Clear;
 166
 167       if Target.Capacity < Source.Length then
 168          Target.Reserve_Capacity (Source.Length);
 169       end if;
 170
 171       Insert_Items (Target.HT);
 172    end Assign;
 173
 174    --------------
 175    -- Capacity --
 176    --------------
 177
 178    function Capacity (Container : Map) return Count_Type is
 179    begin
 180       return HT_Ops.Capacity (Container.HT);
 181    end Capacity;
 182
 183    -----------
 184    -- Clear --
 185    -----------
 186
 187    procedure Clear (Container : in out Map) is
 188    begin
 189       HT_Ops.Clear (Container.HT);
 190    end Clear;
 191
 192    ------------------------
 193    -- Constant_Reference --
 194    ------------------------
 195
 196    function Constant_Reference
 197      (Container : aliased Map;
 198       Position  : Cursor) return Constant_Reference_Type
 199    is
 200    begin
 201       if Position.Container = null then
 202          raise Constraint_Error with
 203            "Position cursor has no element";
 204       end if;
 205
 206       if Position.Container /= Container'Unrestricted_Access then
 207          raise Program_Error with
 208            "Position cursor designates wrong map";
 209       end if;
 210
 211       if Position.Node.Element = null then
 212          raise Program_Error with
 213            "Position cursor has no element";
 214       end if;
 215
 216       pragma Assert
 217         (Vet (Position),
 218          "Position cursor in Constant_Reference is bad");
 219
 220       return (Element => Position.Node.Element.all'Access);
 221    end Constant_Reference;
 222
 223    function Constant_Reference
 224      (Container : aliased Map;
 225       Key       : Key_Type) return Constant_Reference_Type
 226    is
 227       Node : constant Node_Access := Key_Ops.Find (Container.HT, Key);
 228
 229    begin
 230       if Node = null then
 231          raise Constraint_Error with "key not in map";
 232       end if;
 233
 234       if Node.Element = null then
 235          raise Program_Error with "key has no element";
 236       end if;
 237
 238       return (Element => Node.Element.all'Access);
 239    end Constant_Reference;
 240
 241    --------------
 242    -- Contains --
 243    --------------
 244
 245    function Contains (Container : Map; Key : Key_Type) return Boolean is
 246    begin
 247       return Find (Container, Key) /= No_Element;
 248    end Contains;
 249
 250    ----------
 251    -- Copy --
 252    ----------
 253
 254    function Copy
 255      (Source   : Map;
 256       Capacity : Count_Type := 0) return Map
 257    is
 258       C : Count_Type;
 259
 260    begin
 261       if Capacity = 0 then
 262          C := Source.Length;
 263
 264       elsif Capacity >= Source.Length then
 265          C := Capacity;
 266
 267       else
 268          raise Capacity_Error
 269            with "Requested capacity is less than Source length";
 270       end if;
 271
 272       return Target : Map do
 273          Target.Reserve_Capacity (C);
 274          Target.Assign (Source);
 275       end return;
 276    end Copy;
 277
 278    ---------------
 279    -- Copy_Node --
 280    ---------------
 281
 282    function Copy_Node (Node : Node_Access) return Node_Access is
 283       K : Key_Access := new Key_Type'(Node.Key.all);
 284       E : Element_Access;
 285
 286    begin
 287       E := new Element_Type'(Node.Element.all);
 288       return new Node_Type'(K, E, null);
 289
 290    exception
 291       when others =>
 292          Free_Key (K);
 293          Free_Element (E);
 294          raise;
 295    end Copy_Node;
 296
 297    ------------
 298    -- Delete --
 299    ------------
 300
 301    procedure Delete (Container : in out Map; Key : Key_Type) is
 302       X : Node_Access;
 303
 304    begin
 305       Key_Ops.Delete_Key_Sans_Free (Container.HT, Key, X);
 306
 307       if X = null then
 308          raise Constraint_Error with "attempt to delete key not in map";
 309       end if;
 310
 311       Free (X);
 312    end Delete;
 313
 314    procedure Delete (Container : in out Map; Position : in out Cursor) is
 315    begin
 316       if Position.Node = null then
 317          raise Constraint_Error with
 318            "Position cursor of Delete equals No_Element";
 319       end if;
 320
 321       if Position.Container /= Container'Unrestricted_Access then
 322          raise Program_Error with
 323            "Position cursor of Delete designates wrong map";
 324       end if;
 325
 326       if Container.HT.Busy > 0 then
 327          raise Program_Error with
 328            "Delete attempted to tamper with cursors (map is busy)";
 329       end if;
 330
 331       pragma Assert (Vet (Position), "bad cursor in Delete");
 332
 333       HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node);
 334
 335       Free (Position.Node);
 336       Position.Container := null;
 337    end Delete;
 338
 339    -------------
 340    -- Element --
 341    -------------
 342
 343    function Element (Container : Map; Key : Key_Type) return Element_Type is
 344       Node : constant Node_Access := Key_Ops.Find (Container.HT, Key);
 345
 346    begin
 347       if Node = null then
 348          raise Constraint_Error with
 349            "no element available because key not in map";
 350       end if;
 351
 352       return Node.Element.all;
 353    end Element;
 354
 355    function Element (Position : Cursor) return Element_Type is
 356    begin
 357       if Position.Node = null then
 358          raise Constraint_Error with
 359            "Position cursor of function Element equals No_Element";
 360       end if;
 361
 362       if Position.Node.Element = null then
 363          raise Program_Error with
 364            "Position cursor of function Element is bad";
 365       end if;
 366
 367       pragma Assert (Vet (Position), "bad cursor in function Element");
 368
 369       return Position.Node.Element.all;
 370    end Element;
 371
 372    -------------------------
 373    -- Equivalent_Key_Node --
 374    -------------------------
 375
 376    function Equivalent_Key_Node
 377      (Key  : Key_Type;
 378       Node : Node_Access) return Boolean
 379    is
 380    begin
 381       return Equivalent_Keys (Key, Node.Key.all);
 382    end Equivalent_Key_Node;
 383
 384    ---------------------
 385    -- Equivalent_Keys --
 386    ---------------------
 387
 388    function Equivalent_Keys (Left, Right : Cursor) return Boolean is
 389    begin
 390       if Left.Node = null then
 391          raise Constraint_Error with
 392            "Left cursor of Equivalent_Keys equals No_Element";
 393       end if;
 394
 395       if Right.Node = null then
 396          raise Constraint_Error with
 397            "Right cursor of Equivalent_Keys equals No_Element";
 398       end if;
 399
 400       if Left.Node.Key = null then
 401          raise Program_Error with
 402            "Left cursor of Equivalent_Keys is bad";
 403       end if;
 404
 405       if Right.Node.Key = null then
 406          raise Program_Error with
 407            "Right cursor of Equivalent_Keys is bad";
 408       end if;
 409
 410       pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Keys");
 411       pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Keys");
 412
 413       return Equivalent_Keys (Left.Node.Key.all, Right.Node.Key.all);
 414    end Equivalent_Keys;
 415
 416    function Equivalent_Keys
 417      (Left  : Cursor;
 418       Right : Key_Type) return Boolean
 419    is
 420    begin
 421       if Left.Node = null then
 422          raise Constraint_Error with
 423            "Left cursor of Equivalent_Keys equals No_Element";
 424       end if;
 425
 426       if Left.Node.Key = null then
 427          raise Program_Error with
 428            "Left cursor of Equivalent_Keys is bad";
 429       end if;
 430
 431       pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Keys");
 432
 433       return Equivalent_Keys (Left.Node.Key.all, Right);
 434    end Equivalent_Keys;
 435
 436    function Equivalent_Keys
 437      (Left  : Key_Type;
 438       Right : Cursor) return Boolean
 439    is
 440    begin
 441       if Right.Node = null then
 442          raise Constraint_Error with
 443            "Right cursor of Equivalent_Keys equals No_Element";
 444       end if;
 445
 446       if Right.Node.Key = null then
 447          raise Program_Error with
 448            "Right cursor of Equivalent_Keys is bad";
 449       end if;
 450
 451       pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Keys");
 452
 453       return Equivalent_Keys (Left, Right.Node.Key.all);
 454    end Equivalent_Keys;
 455
 456    -------------
 457    -- Exclude --
 458    -------------
 459
 460    procedure Exclude (Container : in out Map; Key : Key_Type) is
 461       X : Node_Access;
 462    begin
 463       Key_Ops.Delete_Key_Sans_Free (Container.HT, Key, X);
 464       Free (X);
 465    end Exclude;
 466
 467    --------------
 468    -- Finalize --
 469    --------------
 470
 471    procedure Finalize (Container : in out Map) is
 472    begin
 473       HT_Ops.Finalize (Container.HT);
 474    end Finalize;
 475
 476    procedure Finalize (Object : in out Iterator) is
 477    begin
 478       if Object.Container /= null then
 479          declare
 480             B : Natural renames Object.Container.all.HT.Busy;
 481          begin
 482             B := B - 1;
 483          end;
 484       end if;
 485    end Finalize;
 486
 487    ----------
 488    -- Find --
 489    ----------
 490
 491    function Find (Container : Map; Key : Key_Type) return Cursor is
 492       Node : constant Node_Access := Key_Ops.Find (Container.HT, Key);
 493
 494    begin
 495       if Node = null then
 496          return No_Element;
 497       end if;
 498
 499       return Cursor'(Container'Unrestricted_Access, Node);
 500    end Find;
 501
 502    --------------------
 503    -- Find_Equal_Key --
 504    --------------------
 505
 506    function Find_Equal_Key
 507      (R_HT   : Hash_Table_Type;
 508       L_Node : Node_Access) return Boolean
 509    is
 510       R_Index : constant Hash_Type := Key_Ops.Index (R_HT, L_Node.Key.all);
 511       R_Node  : Node_Access := R_HT.Buckets (R_Index);
 512
 513    begin
 514       while R_Node /= null loop
 515          if Equivalent_Keys (L_Node.Key.all, R_Node.Key.all) then
 516             return L_Node.Element.all = R_Node.Element.all;
 517          end if;
 518
 519          R_Node := R_Node.Next;
 520       end loop;
 521
 522       return False;
 523    end Find_Equal_Key;
 524
 525    -----------
 526    -- First --
 527    -----------
 528
 529    function First (Container : Map) return Cursor is
 530       Node : constant Node_Access := HT_Ops.First (Container.HT);
 531    begin
 532       if Node = null then
 533          return No_Element;
 534       else
 535          return Cursor'(Container'Unrestricted_Access, Node);
 536       end if;
 537    end First;
 538
 539    function First (Object : Iterator) return Cursor is
 540    begin
 541       return Object.Container.First;
 542    end First;
 543
 544    ----------
 545    -- Free --
 546    ----------
 547
 548    procedure Free (X : in out Node_Access) is
 549       procedure Deallocate is
 550          new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
 551
 552    begin
 553       if X = null then
 554          return;
 555       end if;
 556
 557       X.Next := X;  --  detect mischief (in Vet)
 558
 559       begin
 560          Free_Key (X.Key);
 561       exception
 562          when others =>
 563             X.Key := null;
 564
 565             begin
 566                Free_Element (X.Element);
 567             exception
 568                when others =>
 569                   X.Element := null;
 570             end;
 571
 572             Deallocate (X);
 573             raise;
 574       end;
 575
 576       begin
 577          Free_Element (X.Element);
 578       exception
 579          when others =>
 580             X.Element := null;
 581
 582             Deallocate (X);
 583             raise;
 584       end;
 585
 586       Deallocate (X);
 587    end Free;
 588
 589    -----------------
 590    -- Has_Element --
 591    -----------------
 592
 593    function Has_Element (Position : Cursor) return Boolean is
 594    begin
 595       pragma Assert (Vet (Position), "bad cursor in Has_Element");
 596       return Position.Node /= null;
 597    end Has_Element;
 598
 599    ---------------
 600    -- Hash_Node --
 601    ---------------
 602
 603    function Hash_Node (Node : Node_Access) return Hash_Type is
 604    begin
 605       return Hash (Node.Key.all);
 606    end Hash_Node;
 607
 608    -------------
 609    -- Include --
 610    -------------
 611
 612    procedure Include
 613      (Container : in out Map;
 614       Key       : Key_Type;
 615       New_Item  : Element_Type)
 616    is
 617       Position : Cursor;
 618       Inserted : Boolean;
 619
 620       K : Key_Access;
 621       E : Element_Access;
 622
 623    begin
 624       Insert (Container, Key, New_Item, Position, Inserted);
 625
 626       if not Inserted then
 627          if Container.HT.Lock > 0 then
 628             raise Program_Error with
 629               "Include attempted to tamper with elements (map is locked)";
 630          end if;
 631
 632          K := Position.Node.Key;
 633          E := Position.Node.Element;
 634
 635          Position.Node.Key := new Key_Type'(Key);
 636
 637          begin
 638             Position.Node.Element := new Element_Type'(New_Item);
 639          exception
 640             when others =>
 641                Free_Key (K);
 642                raise;
 643          end;
 644
 645          Free_Key (K);
 646          Free_Element (E);
 647       end if;
 648    end Include;
 649
 650    ------------
 651    -- Insert --
 652    ------------
 653
 654    procedure Insert
 655      (Container : in out Map;
 656       Key       : Key_Type;
 657       New_Item  : Element_Type;
 658       Position  : out Cursor;
 659       Inserted  : out Boolean)
 660    is
 661       function New_Node (Next : Node_Access) return Node_Access;
 662
 663       procedure Local_Insert is
 664         new Key_Ops.Generic_Conditional_Insert (New_Node);
 665
 666       --------------
 667       -- New_Node --
 668       --------------
 669
 670       function New_Node (Next : Node_Access) return Node_Access is
 671          K  : Key_Access := new Key_Type'(Key);
 672          E  : Element_Access;
 673
 674       begin
 675          E := new Element_Type'(New_Item);
 676          return new Node_Type'(K, E, Next);
 677       exception
 678          when others =>
 679             Free_Key (K);
 680             Free_Element (E);
 681             raise;
 682       end New_Node;
 683
 684       HT : Hash_Table_Type renames Container.HT;
 685
 686    --  Start of processing for Insert
 687
 688    begin
 689       if HT_Ops.Capacity (HT) = 0 then
 690          HT_Ops.Reserve_Capacity (HT, 1);
 691       end if;
 692
 693       Local_Insert (HT, Key, Position.Node, Inserted);
 694
 695       if Inserted
 696         and then HT.Length > HT_Ops.Capacity (HT)
 697       then
 698          HT_Ops.Reserve_Capacity (HT, HT.Length);
 699       end if;
 700
 701       Position.Container := Container'Unchecked_Access;
 702    end Insert;
 703
 704    procedure Insert
 705      (Container : in out Map;
 706       Key       : Key_Type;
 707       New_Item  : Element_Type)
 708    is
 709       Position : Cursor;
 710       pragma Unreferenced (Position);
 711
 712       Inserted : Boolean;
 713
 714    begin
 715       Insert (Container, Key, New_Item, Position, Inserted);
 716
 717       if not Inserted then
 718          raise Constraint_Error with
 719            "attempt to insert key already in map";
 720       end if;
 721    end Insert;
 722
 723    --------------
 724    -- Is_Empty --
 725    --------------
 726
 727    function Is_Empty (Container : Map) return Boolean is
 728    begin
 729       return Container.HT.Length = 0;
 730    end Is_Empty;
 731
 732    -------------
 733    -- Iterate --
 734    -------------
 735
 736    procedure Iterate
 737      (Container : Map;
 738       Process   : not null access procedure (Position : Cursor))
 739    is
 740       procedure Process_Node (Node : Node_Access);
 741       pragma Inline (Process_Node);
 742
 743       procedure Local_Iterate is
 744          new HT_Ops.Generic_Iteration (Process_Node);
 745
 746       ------------------
 747       -- Process_Node --
 748       ------------------
 749
 750       procedure Process_Node (Node : Node_Access) is
 751       begin
 752          Process (Cursor'(Container'Unrestricted_Access, Node));
 753       end Process_Node;
 754
 755       B : Natural renames Container'Unrestricted_Access.all.HT.Busy;
 756
 757    --  Start of processing Iterate
 758
 759    begin
 760       B := B + 1;
 761
 762       begin
 763          Local_Iterate (Container.HT);
 764       exception
 765          when others =>
 766             B := B - 1;
 767             raise;
 768       end;
 769
 770       B := B - 1;
 771    end Iterate;
 772
 773    function Iterate
 774      (Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'Class
 775    is
 776       B  : Natural renames Container'Unrestricted_Access.all.HT.Busy;
 777    begin
 778       return It : constant Iterator :=
 779                     (Limited_Controlled with
 780                        Container => Container'Unrestricted_Access)
 781       do
 782          B := B + 1;
 783       end return;
 784    end Iterate;
 785
 786    ---------
 787    -- Key --
 788    ---------
 789
 790    function Key (Position : Cursor) return Key_Type is
 791    begin
 792       if Position.Node = null then
 793          raise Constraint_Error with
 794            "Position cursor of function Key equals No_Element";
 795       end if;
 796
 797       if Position.Node.Key = null then
 798          raise Program_Error with
 799            "Position cursor of function Key is bad";
 800       end if;
 801
 802       pragma Assert (Vet (Position), "bad cursor in function Key");
 803
 804       return Position.Node.Key.all;
 805    end Key;
 806
 807    ------------
 808    -- Length --
 809    ------------
 810
 811    function Length (Container : Map) return Count_Type is
 812    begin
 813       return Container.HT.Length;
 814    end Length;
 815
 816    ----------
 817    -- Move --
 818    ----------
 819
 820    procedure Move
 821      (Target : in out Map;
 822       Source : in out Map)
 823    is
 824    begin
 825       HT_Ops.Move (Target => Target.HT, Source => Source.HT);
 826    end Move;
 827
 828    ----------
 829    -- Next --
 830    ----------
 831
 832    function Next (Node : Node_Access) return Node_Access is
 833    begin
 834       return Node.Next;
 835    end Next;
 836
 837    procedure Next (Position : in out Cursor) is
 838    begin
 839       Position := Next (Position);
 840    end Next;
 841
 842    function Next (Position : Cursor) return Cursor is
 843    begin
 844       if Position.Node = null then
 845          return No_Element;
 846       end if;
 847
 848       if Position.Node.Key = null
 849         or else Position.Node.Element = null
 850       then
 851          raise Program_Error with "Position cursor of Next is bad";
 852       end if;
 853
 854       pragma Assert (Vet (Position), "Position cursor of Next is bad");
 855
 856       declare
 857          HT   : Hash_Table_Type renames Position.Container.HT;
 858          Node : constant Node_Access := HT_Ops.Next (HT, Position.Node);
 859       begin
 860          if Node = null then
 861             return No_Element;
 862          else
 863             return Cursor'(Position.Container, Node);
 864          end if;
 865       end;
 866    end Next;
 867
 868    function Next (Object : Iterator; Position : Cursor) return Cursor is
 869    begin
 870       if Position.Container = null then
 871          return No_Element;
 872       end if;
 873
 874       if Position.Container /= Object.Container then
 875          raise Program_Error with
 876            "Position cursor of Next designates wrong map";
 877       end if;
 878
 879       return Next (Position);
 880    end Next;
 881
 882    -------------------
 883    -- Query_Element --
 884    -------------------
 885
 886    procedure Query_Element
 887      (Position : Cursor;
 888       Process  : not null access procedure (Key     : Key_Type;
 889                                             Element : Element_Type))
 890    is
 891    begin
 892       if Position.Node = null then
 893          raise Constraint_Error with
 894            "Position cursor of Query_Element equals No_Element";
 895       end if;
 896
 897       if Position.Node.Key = null
 898         or else Position.Node.Element = null
 899       then
 900          raise Program_Error with
 901            "Position cursor of Query_Element is bad";
 902       end if;
 903
 904       pragma Assert (Vet (Position), "bad cursor in Query_Element");
 905
 906       declare
 907          M  : Map renames Position.Container.all;
 908          HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
 909
 910          B : Natural renames HT.Busy;
 911          L : Natural renames HT.Lock;
 912
 913       begin
 914          B := B + 1;
 915          L := L + 1;
 916
 917          declare
 918             K : Key_Type renames Position.Node.Key.all;
 919             E : Element_Type renames Position.Node.Element.all;
 920
 921          begin
 922             Process (K, E);
 923          exception
 924             when others =>
 925                L := L - 1;
 926                B := B - 1;
 927                raise;
 928          end;
 929
 930          L := L - 1;
 931          B := B - 1;
 932       end;
 933    end Query_Element;
 934
 935    ----------
 936    -- Read --
 937    ----------
 938
 939    procedure Read_Nodes is new HT_Ops.Generic_Read (Read_Node);
 940
 941    procedure Read
 942      (Stream    : not null access Root_Stream_Type'Class;
 943       Container : out Map)
 944    is
 945    begin
 946       Read_Nodes (Stream, Container.HT);
 947    end Read;
 948
 949    procedure Read
 950      (Stream : not null access Root_Stream_Type'Class;
 951       Item   : out Cursor)
 952    is
 953    begin
 954       raise Program_Error with "attempt to stream map cursor";
 955    end Read;
 956
 957    procedure Read
 958      (Stream : not null access Root_Stream_Type'Class;
 959       Item   : out Reference_Type)
 960    is
 961    begin
 962       raise Program_Error with "attempt to stream reference";
 963    end Read;
 964
 965    procedure Read
 966      (Stream : not null access Root_Stream_Type'Class;
 967       Item   : out Constant_Reference_Type)
 968    is
 969    begin
 970       raise Program_Error with "attempt to stream reference";
 971    end Read;
 972
 973    ---------------
 974    -- Read_Node --
 975    ---------------
 976
 977    function Read_Node
 978      (Stream : not null access Root_Stream_Type'Class) return Node_Access
 979    is
 980       Node : Node_Access := new Node_Type;
 981
 982    begin
 983       begin
 984          Node.Key := new Key_Type'(Key_Type'Input (Stream));
 985       exception
 986          when others =>
 987             Free (Node);
 988             raise;
 989       end;
 990
 991       begin
 992          Node.Element := new Element_Type'(Element_Type'Input (Stream));
 993       exception
 994          when others =>
 995             Free_Key (Node.Key);
 996             Free (Node);
 997             raise;
 998       end;
 999
1000       return Node;
1001    end Read_Node;
1002
1003    ---------------
1004    -- Reference --
1005    ---------------
1006
1007    function Reference
1008      (Container : aliased in out Map;
1009       Position  : Cursor) return Reference_Type
1010    is
1011    begin
1012       if Position.Container = null then
1013          raise Constraint_Error with
1014            "Position cursor has no element";
1015       end if;
1016
1017       if Position.Container /= Container'Unrestricted_Access then
1018          raise Program_Error with
1019            "Position cursor designates wrong map";
1020       end if;
1021
1022       if Position.Node.Element = null then
1023          raise Program_Error with
1024            "Position cursor has no element";
1025       end if;
1026
1027       pragma Assert
1028         (Vet (Position),
1029          "Position cursor in function Reference is bad");
1030
1031       return (Element => Position.Node.Element.all'Access);
1032    end Reference;
1033
1034    function Reference
1035      (Container : aliased in out Map;
1036       Key       : Key_Type) return Reference_Type
1037    is
1038       Node : constant Node_Access := Key_Ops.Find (Container.HT, Key);
1039
1040    begin
1041       if Node = null then
1042          raise Constraint_Error with "key not in map";
1043       end if;
1044
1045       if Node.Element = null then
1046          raise Program_Error with "key has no element";
1047       end if;
1048
1049       return (Element => Node.Element.all'Access);
1050    end Reference;
1051
1052    -------------
1053    -- Replace --
1054    -------------
1055
1056    procedure Replace
1057      (Container : in out Map;
1058       Key       : Key_Type;
1059       New_Item  : Element_Type)
1060    is
1061       Node : constant Node_Access := Key_Ops.Find (Container.HT, Key);
1062
1063       K : Key_Access;
1064       E : Element_Access;
1065
1066    begin
1067       if Node = null then
1068          raise Constraint_Error with
1069            "attempt to replace key not in map";
1070       end if;
1071
1072       if Container.HT.Lock > 0 then
1073          raise Program_Error with
1074            "Replace attempted to tamper with elements (map is locked)";
1075       end if;
1076
1077       K := Node.Key;
1078       E := Node.Element;
1079
1080       Node.Key := new Key_Type'(Key);
1081
1082       begin
1083          Node.Element := new Element_Type'(New_Item);
1084       exception
1085          when others =>
1086             Free_Key (K);
1087             raise;
1088       end;
1089
1090       Free_Key (K);
1091       Free_Element (E);
1092    end Replace;
1093
1094    ---------------------
1095    -- Replace_Element --
1096    ---------------------
1097
1098    procedure Replace_Element
1099      (Container : in out Map;
1100       Position  : Cursor;
1101       New_Item  : Element_Type)
1102    is
1103    begin
1104       if Position.Node = null then
1105          raise Constraint_Error with
1106            "Position cursor of Replace_Element equals No_Element";
1107       end if;
1108
1109       if Position.Node.Key = null
1110         or else Position.Node.Element = null
1111       then
1112          raise Program_Error with
1113            "Position cursor of Replace_Element is bad";
1114       end if;
1115
1116       if Position.Container /= Container'Unrestricted_Access then
1117          raise Program_Error with
1118            "Position cursor of Replace_Element designates wrong map";
1119       end if;
1120
1121       if Position.Container.HT.Lock > 0 then
1122          raise Program_Error with
1123            "Replace_Element attempted to tamper with elements (map is locked)";
1124       end if;
1125
1126       pragma Assert (Vet (Position), "bad cursor in Replace_Element");
1127
1128       declare
1129          X : Element_Access := Position.Node.Element;
1130
1131       begin
1132          Position.Node.Element := new Element_Type'(New_Item);
1133          Free_Element (X);
1134       end;
1135    end Replace_Element;
1136
1137    ----------------------
1138    -- Reserve_Capacity --
1139    ----------------------
1140
1141    procedure Reserve_Capacity
1142      (Container : in out Map;
1143       Capacity  : Count_Type)
1144    is
1145    begin
1146       HT_Ops.Reserve_Capacity (Container.HT, Capacity);
1147    end Reserve_Capacity;
1148
1149    --------------
1150    -- Set_Next --
1151    --------------
1152
1153    procedure Set_Next (Node : Node_Access; Next : Node_Access) is
1154    begin
1155       Node.Next := Next;
1156    end Set_Next;
1157
1158    --------------------
1159    -- Update_Element --
1160    --------------------
1161
1162    procedure Update_Element
1163      (Container : in out Map;
1164       Position  : Cursor;
1165       Process   : not null access procedure (Key     : Key_Type;
1166                                              Element : in out Element_Type))
1167    is
1168    begin
1169       if Position.Node = null then
1170          raise Constraint_Error with
1171            "Position cursor of Update_Element equals No_Element";
1172       end if;
1173
1174       if Position.Node.Key = null
1175         or else Position.Node.Element = null
1176       then
1177          raise Program_Error with
1178            "Position cursor of Update_Element is bad";
1179       end if;
1180
1181       if Position.Container /= Container'Unrestricted_Access then
1182          raise Program_Error with
1183            "Position cursor of Update_Element designates wrong map";
1184       end if;
1185
1186       pragma Assert (Vet (Position), "bad cursor in Update_Element");
1187
1188       declare
1189          HT : Hash_Table_Type renames Container.HT;
1190
1191          B : Natural renames HT.Busy;
1192          L : Natural renames HT.Lock;
1193
1194       begin
1195          B := B + 1;
1196          L := L + 1;
1197
1198          declare
1199             K : Key_Type renames Position.Node.Key.all;
1200             E : Element_Type renames Position.Node.Element.all;
1201
1202          begin
1203             Process (K, E);
1204
1205          exception
1206             when others =>
1207                L := L - 1;
1208                B := B - 1;
1209                raise;
1210          end;
1211
1212          L := L - 1;
1213          B := B - 1;
1214       end;
1215    end Update_Element;
1216
1217    ---------
1218    -- Vet --
1219    ---------
1220
1221    function Vet (Position : Cursor) return Boolean is
1222    begin
1223       if Position.Node = null then
1224          return Position.Container = null;
1225       end if;
1226
1227       if Position.Container = null then
1228          return False;
1229       end if;
1230
1231       if Position.Node.Next = Position.Node then
1232          return False;
1233       end if;
1234
1235       if Position.Node.Key = null then
1236          return False;
1237       end if;
1238
1239       if Position.Node.Element = null then
1240          return False;
1241       end if;
1242
1243       declare
1244          HT : Hash_Table_Type renames Position.Container.HT;
1245          X  : Node_Access;
1246
1247       begin
1248          if HT.Length = 0 then
1249             return False;
1250          end if;
1251
1252          if HT.Buckets = null
1253            or else HT.Buckets'Length = 0
1254          then
1255             return False;
1256          end if;
1257
1258          X := HT.Buckets (Key_Ops.Index (HT, Position.Node.Key.all));
1259
1260          for J in 1 .. HT.Length loop
1261             if X = Position.Node then
1262                return True;
1263             end if;
1264
1265             if X = null then
1266                return False;
1267             end if;
1268
1269             if X = X.Next then  --  to prevent unnecessary looping
1270                return False;
1271             end if;
1272
1273             X := X.Next;
1274          end loop;
1275
1276          return False;
1277       end;
1278    end Vet;
1279
1280    -----------
1281    -- Write --
1282    -----------
1283
1284    procedure Write_Nodes is new HT_Ops.Generic_Write (Write_Node);
1285
1286    procedure Write
1287      (Stream    : not null access Root_Stream_Type'Class;
1288       Container : Map)
1289    is
1290    begin
1291       Write_Nodes (Stream, Container.HT);
1292    end Write;
1293
1294    procedure Write
1295      (Stream : not null access Root_Stream_Type'Class;
1296       Item   : Cursor)
1297    is
1298    begin
1299       raise Program_Error with "attempt to stream map cursor";
1300    end Write;
1301
1302    procedure Write
1303      (Stream : not null access Root_Stream_Type'Class;
1304       Item   : Reference_Type)
1305    is
1306    begin
1307       raise Program_Error with "attempt to stream reference";
1308    end Write;
1309
1310    procedure Write
1311      (Stream : not null access Root_Stream_Type'Class;
1312       Item   : Constant_Reference_Type)
1313    is
1314    begin
1315       raise Program_Error with "attempt to stream reference";
1316    end Write;
1317
1318    ----------------
1319    -- Write_Node --
1320    ----------------
1321
1322    procedure Write_Node
1323      (Stream : not null access Root_Stream_Type'Class;
1324       Node   : Node_Access)
1325    is
1326    begin
1327       Key_Type'Output (Stream, Node.Key.all);
1328       Element_Type'Output (Stream, Node.Element.all);
1329    end Write_Node;
1330
1331 end Ada.Containers.Indefinite_Hashed_Maps;