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
 312    begin
 313       E := new Element_Type'(Node.Element.all);
 314       return new Node_Type'(K, E, null);
 315
 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       exception
 607          when others =>
 608             X.Key := null;
 609
 610             begin
 611                Free_Element (X.Element);
 612             exception
 613                when others =>
 614                   X.Element := null;
 615             end;
 616
 617             Deallocate (X);
 618             raise;
 619       end;
 620
 621       begin
 622          Free_Element (X.Element);
 623       exception
 624          when others =>
 625             X.Element := null;
 626
 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          exception
 983             when others =>
 984                L := L - 1;
 985                B := B - 1;
 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;