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