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