gcc/ada/a-cihama.adb

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