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