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