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          begin
 698             Position.Node.Element := new Element_Type'(New_Item);
 699          exception
 700             when others =>
 701                Free_Key (K);
 702                raise;
 703          end;
 704
 705          Free_Key (K);
 706          Free_Element (E);
 707       end if;
 708    end Include;
 709
 710    ------------
 711    -- Insert --
 712    ------------
 713
 714    procedure Insert
 715      (Container : in out Map;
 716       Key       : Key_Type;
 717       New_Item  : Element_Type;
 718       Position  : out Cursor;
 719       Inserted  : out Boolean)
 720    is
 721       function New_Node (Next : Node_Access) return Node_Access;
 722
 723       procedure Local_Insert is
 724         new Key_Ops.Generic_Conditional_Insert (New_Node);
 725
 726       --------------
 727       -- New_Node --
 728       --------------
 729
 730       function New_Node (Next : Node_Access) return Node_Access is
 731          K  : Key_Access := new Key_Type'(Key);
 732          E  : Element_Access;
 733
 734       begin
 735          E := new Element_Type'(New_Item);
 736          return new Node_Type'(K, E, Next);
 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
 840                        Container => Container'Unrestricted_Access)
 841       do
 842          B := B + 1;
 843       end return;
 844    end Iterate;
 845
 846    ---------
 847    -- Key --
 848    ---------
 849
 850    function Key (Position : Cursor) return Key_Type is
 851    begin
 852       if Position.Node = null then
 853          raise Constraint_Error with
 854            "Position cursor of function Key equals No_Element";
 855       end if;
 856
 857       if Position.Node.Key = null then
 858          raise Program_Error with
 859            "Position cursor of function Key is bad";
 860       end if;
 861
 862       pragma Assert (Vet (Position), "bad cursor in function Key");
 863
 864       return Position.Node.Key.all;
 865    end Key;
 866
 867    ------------
 868    -- Length --
 869    ------------
 870
 871    function Length (Container : Map) return Count_Type is
 872    begin
 873       return Container.HT.Length;
 874    end Length;
 875
 876    ----------
 877    -- Move --
 878    ----------
 879
 880    procedure Move
 881      (Target : in out Map;
 882       Source : in out Map)
 883    is
 884    begin
 885       HT_Ops.Move (Target => Target.HT, Source => Source.HT);
 886    end Move;
 887
 888    ----------
 889    -- Next --
 890    ----------
 891
 892    function Next (Node : Node_Access) return Node_Access is
 893    begin
 894       return Node.Next;
 895    end Next;
 896
 897    procedure Next (Position : in out Cursor) is
 898    begin
 899       Position := Next (Position);
 900    end Next;
 901
 902    function Next (Position : Cursor) return Cursor is
 903    begin
 904       if Position.Node = null then
 905          return No_Element;
 906       end if;
 907
 908       if Position.Node.Key = null
 909         or else Position.Node.Element = null
 910       then
 911          raise Program_Error with "Position cursor of Next is bad";
 912       end if;
 913
 914       pragma Assert (Vet (Position), "Position cursor of Next is bad");
 915
 916       declare
 917          HT   : Hash_Table_Type renames Position.Container.HT;
 918          Node : constant Node_Access := HT_Ops.Next (HT, Position.Node);
 919       begin
 920          if Node = null then
 921             return No_Element;
 922          else
 923             return Cursor'(Position.Container, Node);
 924          end if;
 925       end;
 926    end Next;
 927
 928    function Next (Object : Iterator; Position : Cursor) return Cursor is
 929    begin
 930       if Position.Container = null then
 931          return No_Element;
 932       end if;
 933
 934       if Position.Container /= Object.Container then
 935          raise Program_Error with
 936            "Position cursor of Next designates wrong map";
 937       end if;
 938
 939       return Next (Position);
 940    end Next;
 941
 942    -------------------
 943    -- Query_Element --
 944    -------------------
 945
 946    procedure Query_Element
 947      (Position : Cursor;
 948       Process  : not null access procedure (Key     : Key_Type;
 949                                             Element : Element_Type))
 950    is
 951    begin
 952       if Position.Node = null then
 953          raise Constraint_Error with
 954            "Position cursor of Query_Element equals No_Element";
 955       end if;
 956
 957       if Position.Node.Key = null
 958         or else Position.Node.Element = null
 959       then
 960          raise Program_Error with
 961            "Position cursor of Query_Element is bad";
 962       end if;
 963
 964       pragma Assert (Vet (Position), "bad cursor in Query_Element");
 965
 966       declare
 967          M  : Map renames Position.Container.all;
 968          HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
 969
 970          B : Natural renames HT.Busy;
 971          L : Natural renames HT.Lock;
 972
 973       begin
 974          B := B + 1;
 975          L := L + 1;
 976
 977          declare
 978             K : Key_Type renames Position.Node.Key.all;
 979             E : Element_Type renames Position.Node.Element.all;
 980
 981          begin
 982             Process (K, E);
 983          exception
 984             when others =>
 985                L := L - 1;
 986                B := B - 1;
 987                raise;
 988          end;
 989
 990          L := L - 1;
 991          B := B - 1;
 992       end;
 993    end Query_Element;
 994
 995    ----------
 996    -- Read --
 997    ----------
 998
 999    procedure Read_Nodes is new HT_Ops.Generic_Read (Read_Node);
1000
1001    procedure Read
1002      (Stream    : not null access Root_Stream_Type'Class;
1003       Container : out Map)
1004    is
1005    begin
1006       Read_Nodes (Stream, Container.HT);
1007    end Read;
1008
1009    procedure Read
1010      (Stream : not null access Root_Stream_Type'Class;
1011       Item   : out Cursor)
1012    is
1013    begin
1014       raise Program_Error with "attempt to stream map cursor";
1015    end Read;
1016
1017    procedure Read
1018      (Stream : not null access Root_Stream_Type'Class;
1019       Item   : out Reference_Type)
1020    is
1021    begin
1022       raise Program_Error with "attempt to stream reference";
1023    end Read;
1024
1025    procedure Read
1026      (Stream : not null access Root_Stream_Type'Class;
1027       Item   : out Constant_Reference_Type)
1028    is
1029    begin
1030       raise Program_Error with "attempt to stream reference";
1031    end Read;
1032
1033    ---------------
1034    -- Read_Node --
1035    ---------------
1036
1037    function Read_Node
1038      (Stream : not null access Root_Stream_Type'Class) return Node_Access
1039    is
1040       Node : Node_Access := new Node_Type;
1041
1042    begin
1043       begin
1044          Node.Key := new Key_Type'(Key_Type'Input (Stream));
1045       exception
1046          when others =>
1047             Free (Node);
1048             raise;
1049       end;
1050
1051       begin
1052          Node.Element := new Element_Type'(Element_Type'Input (Stream));
1053       exception
1054          when others =>
1055             Free_Key (Node.Key);
1056             Free (Node);
1057             raise;
1058       end;
1059
1060       return Node;
1061    end Read_Node;
1062
1063    ---------------
1064    -- Reference --
1065    ---------------
1066
1067    function Reference
1068      (Container : aliased in out Map;
1069       Position  : Cursor) return Reference_Type
1070    is
1071    begin
1072       if Position.Container = null then
1073          raise Constraint_Error with
1074            "Position cursor has no element";
1075       end if;
1076
1077       if Position.Container /= Container'Unrestricted_Access then
1078          raise Program_Error with
1079            "Position cursor designates wrong map";
1080       end if;
1081
1082       if Position.Node.Element = null then
1083          raise Program_Error with
1084            "Position cursor has no element";
1085       end if;
1086
1087       pragma Assert
1088         (Vet (Position),
1089          "Position cursor in function Reference is bad");
1090
1091       declare
1092          M : Map renames Position.Container.all;
1093          HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
1094          B : Natural renames HT.Busy;
1095          L : Natural renames HT.Lock;
1096       begin
1097          return R : constant Reference_Type :=
1098                       (Element => Position.Node.Element.all'Access,
1099                        Control => (Controlled with Position.Container))
1100          do
1101             B := B + 1;
1102             L := L + 1;
1103          end return;
1104       end;
1105    end Reference;
1106
1107    function Reference
1108      (Container : aliased in out Map;
1109       Key       : Key_Type) return Reference_Type
1110    is
1111       Node : constant Node_Access := Key_Ops.Find (Container.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          M : Map renames Container'Unrestricted_Access.all;
1124          HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
1125          B : Natural renames HT.Busy;
1126          L : Natural renames HT.Lock;
1127       begin
1128          return R : constant Reference_Type :=
1129                       (Element => Node.Element.all'Access,
1130                        Control =>
1131                          (Controlled with Container'Unrestricted_Access))
1132          do
1133             B := B + 1;
1134             L := L + 1;
1135          end return;
1136       end;
1137    end Reference;
1138
1139    -------------
1140    -- Replace --
1141    -------------
1142
1143    procedure Replace
1144      (Container : in out Map;
1145       Key       : Key_Type;
1146       New_Item  : Element_Type)
1147    is
1148       Node : constant Node_Access := Key_Ops.Find (Container.HT, Key);
1149
1150       K : Key_Access;
1151       E : Element_Access;
1152
1153    begin
1154       if Node = null then
1155          raise Constraint_Error with
1156            "attempt to replace key not in map";
1157       end if;
1158
1159       if Container.HT.Lock > 0 then
1160          raise Program_Error with
1161            "Replace attempted to tamper with elements (map is locked)";
1162       end if;
1163
1164       K := Node.Key;
1165       E := Node.Element;
1166
1167       Node.Key := new Key_Type'(Key);
1168
1169       begin
1170          Node.Element := new Element_Type'(New_Item);
1171       exception
1172          when others =>
1173             Free_Key (K);
1174             raise;
1175       end;
1176
1177       Free_Key (K);
1178       Free_Element (E);
1179    end Replace;
1180
1181    ---------------------
1182    -- Replace_Element --
1183    ---------------------
1184
1185    procedure Replace_Element
1186      (Container : in out Map;
1187       Position  : Cursor;
1188       New_Item  : Element_Type)
1189    is
1190    begin
1191       if Position.Node = null then
1192          raise Constraint_Error with
1193            "Position cursor of Replace_Element equals No_Element";
1194       end if;
1195
1196       if Position.Node.Key = null
1197         or else Position.Node.Element = null
1198       then
1199          raise Program_Error with
1200            "Position cursor of Replace_Element is bad";
1201       end if;
1202
1203       if Position.Container /= Container'Unrestricted_Access then
1204          raise Program_Error with
1205            "Position cursor of Replace_Element designates wrong map";
1206       end if;
1207
1208       if Position.Container.HT.Lock > 0 then
1209          raise Program_Error with
1210            "Replace_Element attempted to tamper with elements (map is locked)";
1211       end if;
1212
1213       pragma Assert (Vet (Position), "bad cursor in Replace_Element");
1214
1215       declare
1216          X : Element_Access := Position.Node.Element;
1217
1218       begin
1219          Position.Node.Element := new Element_Type'(New_Item);
1220          Free_Element (X);
1221       end;
1222    end Replace_Element;
1223
1224    ----------------------
1225    -- Reserve_Capacity --
1226    ----------------------
1227
1228    procedure Reserve_Capacity
1229      (Container : in out Map;
1230       Capacity  : Count_Type)
1231    is
1232    begin
1233       HT_Ops.Reserve_Capacity (Container.HT, Capacity);
1234    end Reserve_Capacity;
1235
1236    --------------
1237    -- Set_Next --
1238    --------------
1239
1240    procedure Set_Next (Node : Node_Access; Next : Node_Access) is
1241    begin
1242       Node.Next := Next;
1243    end Set_Next;
1244
1245    --------------------
1246    -- Update_Element --
1247    --------------------
1248
1249    procedure Update_Element
1250      (Container : in out Map;
1251       Position  : Cursor;
1252       Process   : not null access procedure (Key     : Key_Type;
1253                                              Element : in out Element_Type))
1254    is
1255    begin
1256       if Position.Node = null then
1257          raise Constraint_Error with
1258            "Position cursor of Update_Element equals No_Element";
1259       end if;
1260
1261       if Position.Node.Key = null
1262         or else Position.Node.Element = null
1263       then
1264          raise Program_Error with
1265            "Position cursor of Update_Element is bad";
1266       end if;
1267
1268       if Position.Container /= Container'Unrestricted_Access then
1269          raise Program_Error with
1270            "Position cursor of Update_Element designates wrong map";
1271       end if;
1272
1273       pragma Assert (Vet (Position), "bad cursor in Update_Element");
1274
1275       declare
1276          HT : Hash_Table_Type renames Container.HT;
1277
1278          B : Natural renames HT.Busy;
1279          L : Natural renames HT.Lock;
1280
1281       begin
1282          B := B + 1;
1283          L := L + 1;
1284
1285          declare
1286             K : Key_Type renames Position.Node.Key.all;
1287             E : Element_Type renames Position.Node.Element.all;
1288
1289          begin
1290             Process (K, E);
1291
1292          exception
1293             when others =>
1294                L := L - 1;
1295                B := B - 1;
1296                raise;
1297          end;
1298
1299          L := L - 1;
1300          B := B - 1;
1301       end;
1302    end Update_Element;
1303
1304    ---------
1305    -- Vet --
1306    ---------
1307
1308    function Vet (Position : Cursor) return Boolean is
1309    begin
1310       if Position.Node = null then
1311          return Position.Container = null;
1312       end if;
1313
1314       if Position.Container = null then
1315          return False;
1316       end if;
1317
1318       if Position.Node.Next = Position.Node then
1319          return False;
1320       end if;
1321
1322       if Position.Node.Key = null then
1323          return False;
1324       end if;
1325
1326       if Position.Node.Element = null then
1327          return False;
1328       end if;
1329
1330       declare
1331          HT : Hash_Table_Type renames Position.Container.HT;
1332          X  : Node_Access;
1333
1334       begin
1335          if HT.Length = 0 then
1336             return False;
1337          end if;
1338
1339          if HT.Buckets = null
1340            or else HT.Buckets'Length = 0
1341          then
1342             return False;
1343          end if;
1344
1345          X := HT.Buckets (Key_Ops.Index (HT, Position.Node.Key.all));
1346
1347          for J in 1 .. HT.Length loop
1348             if X = Position.Node then
1349                return True;
1350             end if;
1351
1352             if X = null then
1353                return False;
1354             end if;
1355
1356             if X = X.Next then  --  to prevent unnecessary looping
1357                return False;
1358             end if;
1359
1360             X := X.Next;
1361          end loop;
1362
1363          return False;
1364       end;
1365    end Vet;
1366
1367    -----------
1368    -- Write --
1369    -----------
1370
1371    procedure Write_Nodes is new HT_Ops.Generic_Write (Write_Node);
1372
1373    procedure Write
1374      (Stream    : not null access Root_Stream_Type'Class;
1375       Container : Map)
1376    is
1377    begin
1378       Write_Nodes (Stream, Container.HT);
1379    end Write;
1380
1381    procedure Write
1382      (Stream : not null access Root_Stream_Type'Class;
1383       Item   : Cursor)
1384    is
1385    begin
1386       raise Program_Error with "attempt to stream map cursor";
1387    end Write;
1388
1389    procedure Write
1390      (Stream : not null access Root_Stream_Type'Class;
1391       Item   : Reference_Type)
1392    is
1393    begin
1394       raise Program_Error with "attempt to stream reference";
1395    end Write;
1396
1397    procedure Write
1398      (Stream : not null access Root_Stream_Type'Class;
1399       Item   : Constant_Reference_Type)
1400    is
1401    begin
1402       raise Program_Error with "attempt to stream reference";
1403    end Write;
1404
1405    ----------------
1406    -- Write_Node --
1407    ----------------
1408
1409    procedure Write_Node
1410      (Stream : not null access Root_Stream_Type'Class;
1411       Node   : Node_Access)
1412    is
1413    begin
1414       Key_Type'Output (Stream, Node.Key.all);
1415       Element_Type'Output (Stream, Node.Element.all);
1416    end Write_Node;
1417
1418 end Ada.Containers.Indefinite_Hashed_Maps;