gcc/ada/a-cbhama.adb

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