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