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