gcc/ada/libgnat/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-2017, 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, Hash_Type'Last);
 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       Pos  : Hash_Type;
 541       Node : constant Node_Access := HT_Ops.First (Container.HT, Pos);
 542    begin
 543       if Node = null then
 544          return No_Element;
 545       else
 546          return Cursor'(Container'Unrestricted_Access, Node, Pos);
 547       end if;
 548    end First;
 549
 550    function First (Object : Iterator) return Cursor is
 551    begin
 552       return Object.Container.First;
 553    end First;
 554
 555    ----------
 556    -- Free --
 557    ----------
 558
 559    procedure Free (X : in out Node_Access) is
 560       procedure Deallocate is
 561          new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
 562
 563    begin
 564       if X = null then
 565          return;
 566       end if;
 567
 568       X.Next := X;  --  detect mischief (in Vet)
 569
 570       begin
 571          Free_Key (X.Key);
 572
 573       exception
 574          when others =>
 575             X.Key := null;
 576
 577             begin
 578                Free_Element (X.Element);
 579             exception
 580                when others =>
 581                   X.Element := null;
 582             end;
 583
 584             Deallocate (X);
 585             raise;
 586       end;
 587
 588       begin
 589          Free_Element (X.Element);
 590       exception
 591          when others =>
 592             X.Element := null;
 593             Deallocate (X);
 594             raise;
 595       end;
 596
 597       Deallocate (X);
 598    end Free;
 599
 600    ------------------------
 601    -- Get_Element_Access --
 602    ------------------------
 603
 604    function Get_Element_Access
 605      (Position : Cursor) return not null Element_Access is
 606    begin
 607       return Position.Node.Element;
 608    end Get_Element_Access;
 609
 610    -----------------
 611    -- Has_Element --
 612    -----------------
 613
 614    function Has_Element (Position : Cursor) return Boolean is
 615    begin
 616       pragma Assert (Vet (Position), "bad cursor in Has_Element");
 617       return Position.Node /= null;
 618    end Has_Element;
 619
 620    ---------------
 621    -- Hash_Node --
 622    ---------------
 623
 624    function Hash_Node (Node : Node_Access) return Hash_Type is
 625    begin
 626       return Hash (Node.Key.all);
 627    end Hash_Node;
 628
 629    -------------
 630    -- Include --
 631    -------------
 632
 633    procedure Include
 634      (Container : in out Map;
 635       Key       : Key_Type;
 636       New_Item  : Element_Type)
 637    is
 638       Position : Cursor;
 639       Inserted : Boolean;
 640
 641       K : Key_Access;
 642       E : Element_Access;
 643
 644    begin
 645       Insert (Container, Key, New_Item, Position, Inserted);
 646
 647       if not Inserted then
 648          TE_Check (Container.HT.TC);
 649
 650          K := Position.Node.Key;
 651          E := Position.Node.Element;
 652
 653          Position.Node.Key := new Key_Type'(Key);
 654
 655          declare
 656             --  The element allocator may need an accessibility check in the
 657             --  case the actual type is class-wide or has access discriminants
 658             --  (see RM 4.8(10.1) and AI12-0035).
 659
 660             pragma Unsuppress (Accessibility_Check);
 661
 662          begin
 663             Position.Node.Element := new Element_Type'(New_Item);
 664
 665          exception
 666             when others =>
 667                Free_Key (K);
 668                raise;
 669          end;
 670
 671          Free_Key (K);
 672          Free_Element (E);
 673       end if;
 674    end Include;
 675
 676    ------------
 677    -- Insert --
 678    ------------
 679
 680    procedure Insert
 681      (Container : in out Map;
 682       Key       : Key_Type;
 683       New_Item  : Element_Type;
 684       Position  : out Cursor;
 685       Inserted  : out Boolean)
 686    is
 687       function New_Node (Next : Node_Access) return Node_Access;
 688
 689       procedure Local_Insert is
 690         new Key_Ops.Generic_Conditional_Insert (New_Node);
 691
 692       --------------
 693       -- New_Node --
 694       --------------
 695
 696       function New_Node (Next : Node_Access) return Node_Access is
 697          K  : Key_Access := new Key_Type'(Key);
 698          E  : Element_Access;
 699
 700          --  The element allocator may need an accessibility check in the case
 701          --  the actual type is class-wide or has access discriminants (see
 702          --  RM 4.8(10.1) and AI12-0035).
 703
 704          pragma Unsuppress (Accessibility_Check);
 705
 706       begin
 707          E := new Element_Type'(New_Item);
 708          return new Node_Type'(K, E, Next);
 709
 710       exception
 711          when others =>
 712             Free_Key (K);
 713             Free_Element (E);
 714             raise;
 715       end New_Node;
 716
 717       HT : Hash_Table_Type renames Container.HT;
 718
 719    --  Start of processing for Insert
 720
 721    begin
 722       if HT_Ops.Capacity (HT) = 0 then
 723          HT_Ops.Reserve_Capacity (HT, 1);
 724       end if;
 725
 726       Local_Insert (HT, Key, Position.Node, Inserted);
 727
 728       if Inserted
 729         and then HT.Length > HT_Ops.Capacity (HT)
 730       then
 731          HT_Ops.Reserve_Capacity (HT, HT.Length);
 732       end if;
 733
 734       Position.Container := Container'Unchecked_Access;
 735    end Insert;
 736
 737    procedure Insert
 738      (Container : in out Map;
 739       Key       : Key_Type;
 740       New_Item  : Element_Type)
 741    is
 742       Position : Cursor;
 743       pragma Unreferenced (Position);
 744
 745       Inserted : Boolean;
 746
 747    begin
 748       Insert (Container, Key, New_Item, Position, Inserted);
 749
 750       if Checks and then not Inserted then
 751          raise Constraint_Error with
 752            "attempt to insert key already in map";
 753       end if;
 754    end Insert;
 755
 756    --------------
 757    -- Is_Empty --
 758    --------------
 759
 760    function Is_Empty (Container : Map) return Boolean is
 761    begin
 762       return Container.HT.Length = 0;
 763    end Is_Empty;
 764
 765    -------------
 766    -- Iterate --
 767    -------------
 768
 769    procedure Iterate
 770      (Container : Map;
 771       Process   : not null access procedure (Position : Cursor))
 772    is
 773       procedure Process_Node (Node : Node_Access; Position : Hash_Type);
 774       pragma Inline (Process_Node);
 775
 776       procedure Local_Iterate is
 777         new HT_Ops.Generic_Iteration_With_Position (Process_Node);
 778
 779       ------------------
 780       -- Process_Node --
 781       ------------------
 782
 783       procedure Process_Node (Node : Node_Access; Position : Hash_Type) is
 784       begin
 785          Process (Cursor'(Container'Unrestricted_Access, Node, Position));
 786       end Process_Node;
 787
 788       Busy : With_Busy (Container.HT.TC'Unrestricted_Access);
 789
 790    --  Start of processing for Iterate
 791
 792    begin
 793       Local_Iterate (Container.HT);
 794    end Iterate;
 795
 796    function Iterate
 797      (Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'Class
 798    is
 799    begin
 800       return It : constant Iterator :=
 801         (Limited_Controlled with Container => Container'Unrestricted_Access)
 802       do
 803          Busy (Container.HT.TC'Unrestricted_Access.all);
 804       end return;
 805    end Iterate;
 806
 807    ---------
 808    -- Key --
 809    ---------
 810
 811    function Key (Position : Cursor) return Key_Type is
 812    begin
 813       if Checks and then Position.Node = null then
 814          raise Constraint_Error with
 815            "Position cursor of function Key equals No_Element";
 816       end if;
 817
 818       if Checks and then Position.Node.Key = null then
 819          raise Program_Error with
 820            "Position cursor of function Key is bad";
 821       end if;
 822
 823       pragma Assert (Vet (Position), "bad cursor in function Key");
 824
 825       return Position.Node.Key.all;
 826    end Key;
 827
 828    ------------
 829    -- Length --
 830    ------------
 831
 832    function Length (Container : Map) return Count_Type is
 833    begin
 834       return Container.HT.Length;
 835    end Length;
 836
 837    ----------
 838    -- Move --
 839    ----------
 840
 841    procedure Move
 842      (Target : in out Map;
 843       Source : in out Map)
 844    is
 845    begin
 846       HT_Ops.Move (Target => Target.HT, Source => Source.HT);
 847    end Move;
 848
 849    ----------
 850    -- Next --
 851    ----------
 852
 853    function Next (Node : Node_Access) return Node_Access is
 854    begin
 855       return Node.Next;
 856    end Next;
 857
 858    procedure Next (Position : in out Cursor) is
 859    begin
 860       Position := Next (Position);
 861    end Next;
 862
 863    function Next (Position : Cursor) return Cursor is
 864       Node : Node_Access;
 865       Pos  : Hash_Type;
 866    begin
 867       if Position.Node = null then
 868          return No_Element;
 869       end if;
 870
 871       if Checks and then
 872         (Position.Node.Key = null or else Position.Node.Element = null)
 873       then
 874          raise Program_Error with "Position cursor of Next is bad";
 875       end if;
 876
 877       pragma Assert (Vet (Position), "Position cursor of Next is bad");
 878
 879       Pos := Position.Position;
 880       Node := HT_Ops.Next (Position.Container.HT, Position.Node, Pos);
 881
 882       if Node = null then
 883          return No_Element;
 884       else
 885          return Cursor'(Position.Container, Node, Pos);
 886       end if;
 887    end Next;
 888
 889    function Next (Object : Iterator; Position : Cursor) return Cursor is
 890    begin
 891       if Position.Container = null then
 892          return No_Element;
 893       end if;
 894
 895       if Checks and then Position.Container /= Object.Container then
 896          raise Program_Error with
 897            "Position cursor of Next designates wrong map";
 898       end if;
 899
 900       return Next (Position);
 901    end Next;
 902
 903    ----------------------
 904    -- Pseudo_Reference --
 905    ----------------------
 906
 907    function Pseudo_Reference
 908      (Container : aliased Map'Class) return Reference_Control_Type
 909    is
 910       TC : constant Tamper_Counts_Access :=
 911         Container.HT.TC'Unrestricted_Access;
 912    begin
 913       return R : constant Reference_Control_Type := (Controlled with TC) do
 914          Lock (TC.all);
 915       end return;
 916    end Pseudo_Reference;
 917
 918    -------------------
 919    -- Query_Element --
 920    -------------------
 921
 922    procedure Query_Element
 923      (Position : Cursor;
 924       Process  : not null access procedure (Key     : Key_Type;
 925                                             Element : Element_Type))
 926    is
 927    begin
 928       if Checks and then Position.Node = null then
 929          raise Constraint_Error with
 930            "Position cursor of Query_Element equals No_Element";
 931       end if;
 932
 933       if Checks and then
 934         (Position.Node.Key = null or else Position.Node.Element = null)
 935       then
 936          raise Program_Error with
 937            "Position cursor of Query_Element is bad";
 938       end if;
 939
 940       pragma Assert (Vet (Position), "bad cursor in Query_Element");
 941
 942       declare
 943          M  : Map renames Position.Container.all;
 944          HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
 945          Lock : With_Lock (HT.TC'Unrestricted_Access);
 946          K : Key_Type renames Position.Node.Key.all;
 947          E : Element_Type renames Position.Node.Element.all;
 948       begin
 949          Process (K, E);
 950       end;
 951    end Query_Element;
 952
 953    ----------
 954    -- Read --
 955    ----------
 956
 957    procedure Read_Nodes is new HT_Ops.Generic_Read (Read_Node);
 958
 959    procedure Read
 960      (Stream    : not null access Root_Stream_Type'Class;
 961       Container : out Map)
 962    is
 963    begin
 964       Read_Nodes (Stream, Container.HT);
 965    end Read;
 966
 967    procedure Read
 968      (Stream : not null access Root_Stream_Type'Class;
 969       Item   : out Cursor)
 970    is
 971    begin
 972       raise Program_Error with "attempt to stream map cursor";
 973    end Read;
 974
 975    procedure Read
 976      (Stream : not null access Root_Stream_Type'Class;
 977       Item   : out Reference_Type)
 978    is
 979    begin
 980       raise Program_Error with "attempt to stream reference";
 981    end Read;
 982
 983    procedure Read
 984      (Stream : not null access Root_Stream_Type'Class;
 985       Item   : out Constant_Reference_Type)
 986    is
 987    begin
 988       raise Program_Error with "attempt to stream reference";
 989    end Read;
 990
 991    ---------------
 992    -- Read_Node --
 993    ---------------
 994
 995    function Read_Node
 996      (Stream : not null access Root_Stream_Type'Class) return Node_Access
 997    is
 998       Node : Node_Access := new Node_Type;
 999
1000    begin
1001       begin
1002          Node.Key := new Key_Type'(Key_Type'Input (Stream));
1003       exception
1004          when others =>
1005             Free (Node);
1006             raise;
1007       end;
1008
1009       begin
1010          Node.Element := new Element_Type'(Element_Type'Input (Stream));
1011       exception
1012          when others =>
1013             Free_Key (Node.Key);
1014             Free (Node);
1015             raise;
1016       end;
1017
1018       return Node;
1019    end Read_Node;
1020
1021    ---------------
1022    -- Reference --
1023    ---------------
1024
1025    function Reference
1026      (Container : aliased in out Map;
1027       Position  : Cursor) return Reference_Type
1028    is
1029    begin
1030       if Checks and then Position.Container = null then
1031          raise Constraint_Error with
1032            "Position cursor has no element";
1033       end if;
1034
1035       if Checks and then Position.Container /= Container'Unrestricted_Access
1036       then
1037          raise Program_Error with
1038            "Position cursor designates wrong map";
1039       end if;
1040
1041       if Checks and then Position.Node.Element = null then
1042          raise Program_Error with
1043            "Position cursor has no element";
1044       end if;
1045
1046       pragma Assert
1047         (Vet (Position),
1048          "Position cursor in function Reference is bad");
1049
1050       declare
1051          M : Map renames Position.Container.all;
1052          HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
1053          TC : constant Tamper_Counts_Access :=
1054            HT.TC'Unrestricted_Access;
1055       begin
1056          return R : constant Reference_Type :=
1057            (Element => Position.Node.Element.all'Access,
1058             Control => (Controlled with TC))
1059          do
1060             Lock (TC.all);
1061          end return;
1062       end;
1063    end Reference;
1064
1065    function Reference
1066      (Container : aliased in out Map;
1067       Key       : Key_Type) return Reference_Type
1068    is
1069       HT   : Hash_Table_Type renames Container.HT;
1070       Node : constant Node_Access := Key_Ops.Find (HT, Key);
1071
1072    begin
1073       if Checks and then Node = null then
1074          raise Constraint_Error with "key not in map";
1075       end if;
1076
1077       if Checks and then Node.Element = null then
1078          raise Program_Error with "key has no element";
1079       end if;
1080
1081       declare
1082          TC : constant Tamper_Counts_Access :=
1083            HT.TC'Unrestricted_Access;
1084       begin
1085          return R : constant Reference_Type :=
1086            (Element => Node.Element.all'Access,
1087             Control => (Controlled with TC))
1088          do
1089             Lock (TC.all);
1090          end return;
1091       end;
1092    end Reference;
1093
1094    -------------
1095    -- Replace --
1096    -------------
1097
1098    procedure Replace
1099      (Container : in out Map;
1100       Key       : Key_Type;
1101       New_Item  : Element_Type)
1102    is
1103       Node : constant Node_Access := Key_Ops.Find (Container.HT, Key);
1104
1105       K : Key_Access;
1106       E : Element_Access;
1107
1108    begin
1109       if Checks and then Node = null then
1110          raise Constraint_Error with
1111            "attempt to replace key not in map";
1112       end if;
1113
1114       TE_Check (Container.HT.TC);
1115
1116       K := Node.Key;
1117       E := Node.Element;
1118
1119       Node.Key := new Key_Type'(Key);
1120
1121       declare
1122          --  The element allocator may need an accessibility check in the case
1123          --  the actual type is class-wide or has access discriminants (see
1124          --  RM 4.8(10.1) and AI12-0035).
1125
1126          pragma Unsuppress (Accessibility_Check);
1127
1128       begin
1129          Node.Element := new Element_Type'(New_Item);
1130
1131       exception
1132          when others =>
1133             Free_Key (K);
1134             raise;
1135       end;
1136
1137       Free_Key (K);
1138       Free_Element (E);
1139    end Replace;
1140
1141    ---------------------
1142    -- Replace_Element --
1143    ---------------------
1144
1145    procedure Replace_Element
1146      (Container : in out Map;
1147       Position  : Cursor;
1148       New_Item  : Element_Type)
1149    is
1150    begin
1151       if Checks and then Position.Node = null then
1152          raise Constraint_Error with
1153            "Position cursor of Replace_Element equals No_Element";
1154       end if;
1155
1156       if Checks and then
1157         (Position.Node.Key = null or else Position.Node.Element = null)
1158       then
1159          raise Program_Error with
1160            "Position cursor of Replace_Element is bad";
1161       end if;
1162
1163       if Checks and then Position.Container /= Container'Unrestricted_Access
1164       then
1165          raise Program_Error with
1166            "Position cursor of Replace_Element designates wrong map";
1167       end if;
1168
1169       TE_Check (Position.Container.HT.TC);
1170
1171       pragma Assert (Vet (Position), "bad cursor in Replace_Element");
1172
1173       declare
1174          X : Element_Access := Position.Node.Element;
1175
1176          --  The element allocator may need an accessibility check in the case
1177          --  the actual type is class-wide or has access discriminants (see
1178          --  RM 4.8(10.1) and AI12-0035).
1179
1180          pragma Unsuppress (Accessibility_Check);
1181
1182       begin
1183          Position.Node.Element := new Element_Type'(New_Item);
1184          Free_Element (X);
1185       end;
1186    end Replace_Element;
1187
1188    ----------------------
1189    -- Reserve_Capacity --
1190    ----------------------
1191
1192    procedure Reserve_Capacity
1193      (Container : in out Map;
1194       Capacity  : Count_Type)
1195    is
1196    begin
1197       HT_Ops.Reserve_Capacity (Container.HT, Capacity);
1198    end Reserve_Capacity;
1199
1200    --------------
1201    -- Set_Next --
1202    --------------
1203
1204    procedure Set_Next (Node : Node_Access; Next : Node_Access) is
1205    begin
1206       Node.Next := Next;
1207    end Set_Next;
1208
1209    --------------------
1210    -- Update_Element --
1211    --------------------
1212
1213    procedure Update_Element
1214      (Container : in out Map;
1215       Position  : Cursor;
1216       Process   : not null access procedure (Key     : Key_Type;
1217                                              Element : in out Element_Type))
1218    is
1219    begin
1220       if Checks and then Position.Node = null then
1221          raise Constraint_Error with
1222            "Position cursor of Update_Element equals No_Element";
1223       end if;
1224
1225       if Checks and then
1226         (Position.Node.Key = null or else Position.Node.Element = null)
1227       then
1228          raise Program_Error with
1229            "Position cursor of Update_Element is bad";
1230       end if;
1231
1232       if Checks and then Position.Container /= Container'Unrestricted_Access
1233       then
1234          raise Program_Error with
1235            "Position cursor of Update_Element designates wrong map";
1236       end if;
1237
1238       pragma Assert (Vet (Position), "bad cursor in Update_Element");
1239
1240       declare
1241          HT : Hash_Table_Type renames Container.HT;
1242          Lock : With_Lock (HT.TC'Unrestricted_Access);
1243          K : Key_Type renames Position.Node.Key.all;
1244          E : Element_Type renames Position.Node.Element.all;
1245       begin
1246          Process (K, E);
1247       end;
1248    end Update_Element;
1249
1250    ---------
1251    -- Vet --
1252    ---------
1253
1254    function Vet (Position : Cursor) return Boolean is
1255    begin
1256       if Position.Node = null then
1257          return Position.Container = null;
1258       end if;
1259
1260       if Position.Container = null then
1261          return False;
1262       end if;
1263
1264       if Position.Node.Next = Position.Node then
1265          return False;
1266       end if;
1267
1268       if Position.Node.Key = null then
1269          return False;
1270       end if;
1271
1272       if Position.Node.Element = null then
1273          return False;
1274       end if;
1275
1276       declare
1277          HT : Hash_Table_Type renames Position.Container.HT;
1278          X  : Node_Access;
1279
1280       begin
1281          if HT.Length = 0 then
1282             return False;
1283          end if;
1284
1285          if HT.Buckets = null
1286            or else HT.Buckets'Length = 0
1287          then
1288             return False;
1289          end if;
1290
1291          X := HT.Buckets (Key_Ops.Checked_Index (HT, Position.Node.Key.all));
1292
1293          for J in 1 .. HT.Length loop
1294             if X = Position.Node then
1295                return True;
1296             end if;
1297
1298             if X = null then
1299                return False;
1300             end if;
1301
1302             if X = X.Next then  --  to prevent unnecessary looping
1303                return False;
1304             end if;
1305
1306             X := X.Next;
1307          end loop;
1308
1309          return False;
1310       end;
1311    end Vet;
1312
1313    -----------
1314    -- Write --
1315    -----------
1316
1317    procedure Write_Nodes is new HT_Ops.Generic_Write (Write_Node);
1318
1319    procedure Write
1320      (Stream    : not null access Root_Stream_Type'Class;
1321       Container : Map)
1322    is
1323    begin
1324       Write_Nodes (Stream, Container.HT);
1325    end Write;
1326
1327    procedure Write
1328      (Stream : not null access Root_Stream_Type'Class;
1329       Item   : Cursor)
1330    is
1331    begin
1332       raise Program_Error with "attempt to stream map cursor";
1333    end Write;
1334
1335    procedure Write
1336      (Stream : not null access Root_Stream_Type'Class;
1337       Item   : Reference_Type)
1338    is
1339    begin
1340       raise Program_Error with "attempt to stream reference";
1341    end Write;
1342
1343    procedure Write
1344      (Stream : not null access Root_Stream_Type'Class;
1345       Item   : Constant_Reference_Type)
1346    is
1347    begin
1348       raise Program_Error with "attempt to stream reference";
1349    end Write;
1350
1351    ----------------
1352    -- Write_Node --
1353    ----------------
1354
1355    procedure Write_Node
1356      (Stream : not null access Root_Stream_Type'Class;
1357       Node   : Node_Access)
1358    is
1359    begin
1360       Key_Type'Output (Stream, Node.Key.all);
1361       Element_Type'Output (Stream, Node.Element.all);
1362    end Write_Node;
1363
1364 end Ada.Containers.Indefinite_Hashed_Maps;