gcc/ada/a-cohama.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT LIBRARY COMPONENTS                          --
   4 --                                                                          --
   5 --                        ADA.CONTAINERS.HASHED_MAPS                        --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --             Copyright (C) 2004 Free Software Foundation, Inc.            --
  10 --                                                                          --
  11 -- This specification is derived from the Ada Reference Manual for use with --
  12 -- GNAT. The copyright notice above, and the license provisions that follow --
  13 -- apply solely to the  contents of the part following the private keyword. --
  14 --                                                                          --
  15 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  16 -- terms of the  GNU General Public License as published  by the Free Soft- --
  17 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  18 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  19 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  20 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  21 -- for  more details.  You should have  received  a copy of the GNU General --
  22 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  23 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  24 -- MA 02111-1307, USA.                                                      --
  25 --                                                                          --
  26 -- As a special exception,  if other files  instantiate  generics from this --
  27 -- unit, or you link  this unit with other files  to produce an executable, --
  28 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  29 -- covered  by the  GNU  General  Public  License.  This exception does not --
  30 -- however invalidate  any other reasons why  the executable file  might be --
  31 -- covered by the  GNU Public License.                                      --
  32 --                                                                          --
  33 -- This unit was originally developed by Matthew J Heaney.                  --
  34 ------------------------------------------------------------------------------
  35
  36 with Ada.Unchecked_Deallocation;
  37
  38 with Ada.Containers.Hash_Tables.Generic_Operations;
  39 pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Operations);
  40
  41 with Ada.Containers.Hash_Tables.Generic_Keys;
  42 pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys);
  43
  44 package body Ada.Containers.Hashed_Maps is
  45
  46    type Node_Type is limited record
  47       Key     : Key_Type;
  48       Element : Element_Type;
  49       Next    : Node_Access;
  50    end record;
  51
  52    -----------------------
  53    -- Local Subprograms --
  54    -----------------------
  55
  56    function Copy_Node
  57      (Source : Node_Access) return Node_Access;
  58    pragma Inline (Copy_Node);
  59
  60    function Equivalent_Keys
  61      (Key  : Key_Type;
  62       Node : Node_Access) return Boolean;
  63    pragma Inline (Equivalent_Keys);
  64
  65    function Find_Equal_Key
  66      (R_Map  : Map;
  67       L_Node : Node_Access) return Boolean;
  68
  69    function Hash_Node (Node : Node_Access) return Hash_Type;
  70    pragma Inline (Hash_Node);
  71
  72    function Next (Node : Node_Access) return Node_Access;
  73    pragma Inline (Next);
  74
  75    function Read_Node
  76      (Stream : access Root_Stream_Type'Class) return Node_Access;
  77    pragma Inline (Read_Node);
  78
  79    procedure Set_Next (Node : Node_Access; Next : Node_Access);
  80    pragma Inline (Set_Next);
  81
  82    procedure Write_Node
  83      (Stream : access Root_Stream_Type'Class;
  84       Node   : Node_Access);
  85    pragma Inline (Write_Node);
  86
  87    --------------------------
  88    -- Local Instantiations --
  89    --------------------------
  90
  91    procedure Free is
  92      new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
  93
  94    package HT_Ops is
  95       new Hash_Tables.Generic_Operations
  96        (HT_Types          => HT_Types,
  97         Hash_Table_Type   => Map,
  98         Null_Node         => null,
  99         Hash_Node         => Hash_Node,
 100         Next              => Next,
 101         Set_Next          => Set_Next,
 102         Copy_Node         => Copy_Node,
 103         Free              => Free);
 104
 105    package Key_Ops is
 106       new Hash_Tables.Generic_Keys
 107        (HT_Types  => HT_Types,
 108         HT_Type   => Map,
 109         Null_Node => null,
 110         Next      => Next,
 111         Set_Next  => Set_Next,
 112         Key_Type  => Key_Type,
 113         Hash      => Hash,
 114         Equivalent_Keys => Equivalent_Keys);
 115
 116    function Is_Equal is new HT_Ops.Generic_Equal (Find_Equal_Key);
 117
 118    procedure Read_Nodes  is new HT_Ops.Generic_Read (Read_Node);
 119    procedure Write_Nodes is new HT_Ops.Generic_Write (Write_Node);
 120
 121    ---------
 122    -- "=" --
 123    ---------
 124
 125    function "=" (Left, Right : Map) return Boolean renames Is_Equal;
 126
 127    ------------
 128    -- Adjust --
 129    ------------
 130
 131    procedure Adjust (Container : in out Map) renames HT_Ops.Adjust;
 132
 133    --------------
 134    -- Capacity --
 135    --------------
 136
 137    function Capacity (Container : Map) return Count_Type
 138      renames HT_Ops.Capacity;
 139
 140    -----------
 141    -- Clear --
 142    -----------
 143
 144    procedure Clear (Container : in out Map) renames HT_Ops.Clear;
 145
 146    --------------
 147    -- Contains --
 148    --------------
 149
 150    function Contains (Container : Map; Key : Key_Type) return Boolean is
 151    begin
 152       return Find (Container, Key) /= No_Element;
 153    end Contains;
 154
 155    ---------------
 156    -- Copy_Node --
 157    ---------------
 158
 159    function Copy_Node
 160      (Source : Node_Access) return Node_Access
 161    is
 162       Target : constant Node_Access :=
 163                  new Node_Type'(Key     => Source.Key,
 164                                 Element => Source.Element,
 165                                 Next    => null);
 166    begin
 167       return Target;
 168    end Copy_Node;
 169
 170    ------------
 171    -- Delete --
 172    ------------
 173
 174    procedure Delete (Container : in out Map; Key : Key_Type) is
 175       X : Node_Access;
 176
 177    begin
 178       Key_Ops.Delete_Key_Sans_Free (Container, Key, X);
 179
 180       if X = null then
 181          raise Constraint_Error;
 182       end if;
 183
 184       Free (X);
 185    end Delete;
 186
 187    procedure Delete (Container : in out Map; Position : in out Cursor) is
 188    begin
 189       if Position = No_Element then
 190          return;
 191       end if;
 192
 193       if Position.Container /= Map_Access'(Container'Unchecked_Access) then
 194          raise Program_Error;
 195       end if;
 196
 197       HT_Ops.Delete_Node_Sans_Free (Container, Position.Node);
 198       Free (Position.Node);
 199
 200       Position.Container := null;
 201    end Delete;
 202
 203    -------------
 204    -- Element --
 205    -------------
 206
 207    function Element (Container : Map; Key : Key_Type) return Element_Type is
 208       C : constant Cursor := Find (Container, Key);
 209    begin
 210       return C.Node.Element;
 211    end Element;
 212
 213    function Element (Position : Cursor) return Element_Type is
 214    begin
 215       return Position.Node.Element;
 216    end Element;
 217
 218    ---------------------
 219    -- Equivalent_Keys --
 220    ---------------------
 221
 222    function Equivalent_Keys
 223      (Key  : Key_Type;
 224       Node : Node_Access) return Boolean is
 225    begin
 226       return Equivalent_Keys (Key, Node.Key);
 227    end Equivalent_Keys;
 228
 229    ---------------------
 230    -- Equivalent_Keys --
 231    ---------------------
 232
 233    function Equivalent_Keys (Left, Right : Cursor)
 234      return Boolean is
 235    begin
 236       return Equivalent_Keys (Left.Node.Key, Right.Node.Key);
 237    end Equivalent_Keys;
 238
 239    function Equivalent_Keys (Left : Cursor; Right : Key_Type) return Boolean is
 240    begin
 241       return Equivalent_Keys (Left.Node.Key, Right);
 242    end Equivalent_Keys;
 243
 244    function Equivalent_Keys (Left : Key_Type; Right : Cursor) return Boolean is
 245    begin
 246       return Equivalent_Keys (Left, Right.Node.Key);
 247    end Equivalent_Keys;
 248
 249    -------------
 250    -- Exclude --
 251    -------------
 252
 253    procedure Exclude (Container : in out Map; Key : Key_Type) is
 254       X : Node_Access;
 255    begin
 256       Key_Ops.Delete_Key_Sans_Free (Container, Key, X);
 257       Free (X);
 258    end Exclude;
 259
 260    --------------
 261    -- Finalize --
 262    --------------
 263
 264    procedure Finalize (Container : in out Map) renames HT_Ops.Finalize;
 265
 266    ----------
 267    -- Find --
 268    ----------
 269
 270    function Find (Container : Map; Key : Key_Type) return Cursor is
 271       Node : constant Node_Access := Key_Ops.Find (Container, Key);
 272
 273    begin
 274       if Node = null then
 275          return No_Element;
 276       end if;
 277
 278       return Cursor'(Container'Unchecked_Access, Node);
 279    end Find;
 280
 281    --------------------
 282    -- Find_Equal_Key --
 283    --------------------
 284
 285    function Find_Equal_Key
 286      (R_Map  : Map;
 287       L_Node : Node_Access) return Boolean
 288    is
 289       R_Index : constant Hash_Type := Key_Ops.Index (R_Map, L_Node.Key);
 290       R_Node  : Node_Access := R_Map.Buckets (R_Index);
 291
 292    begin
 293       while R_Node /= null loop
 294          if Equivalent_Keys (L_Node.Key, R_Node.Key) then
 295             return L_Node.Element = R_Node.Element;
 296          end if;
 297
 298          R_Node := R_Node.Next;
 299       end loop;
 300
 301       return False;
 302    end Find_Equal_Key;
 303
 304    -----------
 305    -- First --
 306    -----------
 307
 308    function First (Container : Map) return Cursor is
 309       Node : constant Node_Access := HT_Ops.First (Container);
 310
 311    begin
 312       if Node = null then
 313          return No_Element;
 314       end if;
 315
 316       return Cursor'(Container'Unchecked_Access, Node);
 317    end First;
 318
 319    -----------------
 320    -- Has_Element --
 321    -----------------
 322
 323    function Has_Element (Position : Cursor) return Boolean is
 324    begin
 325       return Position /= No_Element;
 326    end Has_Element;
 327
 328    ---------------
 329    -- Hash_Node --
 330    ---------------
 331
 332    function Hash_Node (Node : Node_Access) return Hash_Type is
 333    begin
 334       return Hash (Node.Key);
 335    end Hash_Node;
 336
 337    -------------
 338    -- Include --
 339    -------------
 340
 341    procedure Include
 342      (Container : in out Map;
 343       Key       : Key_Type;
 344       New_Item  : Element_Type)
 345    is
 346       Position : Cursor;
 347       Inserted : Boolean;
 348
 349    begin
 350       Insert (Container, Key, New_Item, Position, Inserted);
 351
 352       if not Inserted then
 353          Position.Node.Key := Key;
 354          Position.Node.Element := New_Item;
 355       end if;
 356    end Include;
 357
 358    ------------
 359    -- Insert --
 360    ------------
 361
 362    procedure Insert
 363      (Container : in out Map;
 364       Key       : Key_Type;
 365       Position  : out Cursor;
 366       Inserted  : out Boolean)
 367    is
 368       function New_Node (Next : Node_Access) return Node_Access;
 369       pragma Inline (New_Node);
 370
 371       procedure Local_Insert is
 372         new Key_Ops.Generic_Conditional_Insert (New_Node);
 373
 374       --------------
 375       -- New_Node --
 376       --------------
 377
 378       function New_Node (Next : Node_Access) return Node_Access is
 379          Node : Node_Access := new Node_Type; --  Ada 2005 aggregate possible?
 380
 381       begin
 382          Node.Key := Key;
 383          Node.Next := Next;
 384
 385          return Node;
 386
 387       exception
 388          when others =>
 389             Free (Node);
 390             raise;
 391       end New_Node;
 392
 393    --  Start of processing for Insert
 394
 395    begin
 396       HT_Ops.Ensure_Capacity (Container, Container.Length + 1);
 397       Local_Insert (Container, Key, Position.Node, Inserted);
 398       Position.Container := Container'Unchecked_Access;
 399    end Insert;
 400
 401    procedure Insert
 402      (Container : in out Map;
 403       Key       : Key_Type;
 404       New_Item  : Element_Type;
 405       Position  : out Cursor;
 406       Inserted  : out Boolean)
 407    is
 408       function New_Node (Next : Node_Access) return Node_Access;
 409       pragma Inline (New_Node);
 410
 411       procedure Local_Insert is
 412         new Key_Ops.Generic_Conditional_Insert (New_Node);
 413
 414       --------------
 415       -- New_Node --
 416       --------------
 417
 418       function New_Node (Next : Node_Access) return Node_Access is
 419          Node : constant Node_Access := new Node_Type'(Key, New_Item, Next);
 420       begin
 421          return Node;
 422       end New_Node;
 423
 424    --  Start of processing for Insert
 425
 426    begin
 427       HT_Ops.Ensure_Capacity (Container, Container.Length + 1);
 428       Local_Insert (Container, Key, Position.Node, Inserted);
 429       Position.Container := Container'Unchecked_Access;
 430    end Insert;
 431
 432    procedure Insert
 433      (Container : in out Map;
 434       Key       : Key_Type;
 435       New_Item  : Element_Type)
 436    is
 437       Position : Cursor;
 438       Inserted : Boolean;
 439
 440    begin
 441       Insert (Container, Key, New_Item, Position, Inserted);
 442
 443       if not Inserted then
 444          raise Constraint_Error;
 445       end if;
 446    end Insert;
 447
 448    --------------
 449    -- Is_Empty --
 450    --------------
 451
 452    function Is_Empty (Container : Map) return Boolean is
 453    begin
 454       return Container.Length = 0;
 455    end Is_Empty;
 456
 457    -------------
 458    -- Iterate --
 459    -------------
 460
 461    procedure Iterate
 462      (Container : Map;
 463       Process   : not null access procedure (Position : Cursor))
 464    is
 465       procedure Process_Node (Node : Node_Access);
 466       pragma Inline (Process_Node);
 467
 468       procedure Local_Iterate is new HT_Ops.Generic_Iteration (Process_Node);
 469
 470       ------------------
 471       -- Process_Node --
 472       ------------------
 473
 474       procedure Process_Node (Node : Node_Access) is
 475       begin
 476          Process (Cursor'(Container'Unchecked_Access, Node));
 477       end Process_Node;
 478
 479    --  Start of processing for Iterate
 480
 481    begin
 482       Local_Iterate (Container);
 483    end Iterate;
 484
 485    ---------
 486    -- Key --
 487    ---------
 488
 489    function Key (Position : Cursor) return Key_Type is
 490    begin
 491       return Position.Node.Key;
 492    end Key;
 493
 494    ------------
 495    -- Length --
 496    ------------
 497
 498    function Length (Container : Map) return Count_Type is
 499    begin
 500       return Container.Length;
 501    end Length;
 502
 503    ----------
 504    -- Move --
 505    ----------
 506
 507    procedure Move
 508      (Target : in out Map;
 509       Source : in out Map) renames HT_Ops.Move;
 510
 511    ----------
 512    -- Next --
 513    ----------
 514
 515    function Next (Node : Node_Access) return Node_Access is
 516    begin
 517       return Node.Next;
 518    end Next;
 519
 520    function Next (Position : Cursor) return Cursor is
 521    begin
 522       if Position = No_Element then
 523          return No_Element;
 524       end if;
 525
 526       declare
 527          M    : Map renames Position.Container.all;
 528          Node : constant Node_Access := HT_Ops.Next (M, Position.Node);
 529
 530       begin
 531          if Node = null then
 532             return No_Element;
 533          end if;
 534
 535          return Cursor'(Position.Container, Node);
 536       end;
 537    end Next;
 538
 539    procedure Next (Position : in out Cursor) is
 540    begin
 541       Position := Next (Position);
 542    end Next;
 543
 544    -------------------
 545    -- Query_Element --
 546    -------------------
 547
 548    procedure Query_Element
 549      (Position : Cursor;
 550       Process  : not null access procedure (Element : Element_Type))
 551    is
 552    begin
 553       Process (Position.Node.Key, Position.Node.Element);
 554    end Query_Element;
 555
 556    ----------
 557    -- Read --
 558    ----------
 559
 560    procedure Read
 561      (Stream    : access Root_Stream_Type'Class;
 562       Container : out Map) renames Read_Nodes;
 563
 564    ---------------
 565    -- Read_Node --
 566    ---------------
 567
 568    function Read_Node
 569      (Stream : access Root_Stream_Type'Class) return Node_Access
 570    is
 571       Node : Node_Access := new Node_Type;
 572
 573    begin
 574       Key_Type'Read (Stream, Node.Key);
 575       Element_Type'Read (Stream, Node.Element);
 576       return Node;
 577
 578    exception
 579       when others =>
 580          Free (Node);
 581          raise;
 582    end Read_Node;
 583
 584    -------------
 585    -- Replace --
 586    -------------
 587
 588    procedure Replace
 589      (Container : in out Map;
 590       Key       : Key_Type;
 591       New_Item  : Element_Type)
 592    is
 593       Node : constant Node_Access := Key_Ops.Find (Container, Key);
 594
 595    begin
 596       if Node = null then
 597          raise Constraint_Error;
 598       end if;
 599
 600       Node.Key := Key;
 601       Node.Element := New_Item;
 602    end Replace;
 603
 604    ---------------------
 605    -- Replace_Element --
 606    ---------------------
 607
 608    procedure Replace_Element (Position : Cursor; By : Element_Type) is
 609    begin
 610       Position.Node.Element := By;
 611    end Replace_Element;
 612
 613    ----------------------
 614    -- Reserve_Capacity --
 615    ----------------------
 616
 617    procedure Reserve_Capacity
 618      (Container : in out Map;
 619       Capacity  : Count_Type) renames HT_Ops.Ensure_Capacity;
 620
 621    --------------
 622    -- Set_Next --
 623    --------------
 624
 625    procedure Set_Next (Node : Node_Access; Next : Node_Access) is
 626    begin
 627       Node.Next := Next;
 628    end Set_Next;
 629
 630    --------------------
 631    -- Update_Element --
 632    --------------------
 633
 634    procedure Update_Element
 635      (Position : Cursor;
 636       Process  : not null access procedure (Element : in out Element_Type))
 637    is
 638    begin
 639       Process (Position.Node.Key, Position.Node.Element);
 640    end Update_Element;
 641
 642    -----------
 643    -- Write --
 644    -----------
 645
 646    procedure Write
 647      (Stream    : access Root_Stream_Type'Class;
 648       Container : Map) renames Write_Nodes;
 649
 650    ----------------
 651    -- Write_Node --
 652    ----------------
 653
 654    procedure Write_Node
 655      (Stream : access Root_Stream_Type'Class;
 656       Node   : Node_Access)
 657    is
 658    begin
 659       Key_Type'Write (Stream, Node.Key);
 660       Element_Type'Write (Stream, Node.Element);
 661    end Write_Node;
 662
 663 end Ada.Containers.Hashed_Maps;