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