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