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