gcc/ada/a-cihama.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT LIBRARY COMPONENTS                          --
   4 --                                                                          --
   5 --                  ADA.CONTAINERS.INDEFINITE_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 has originally being developed by Matthew J Heaney.            --
  34 ------------------------------------------------------------------------------
  35
  36 with Ada.Containers.Hash_Tables.Generic_Operations;
  37 pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Operations);
  38
  39 with Ada.Containers.Hash_Tables.Generic_Keys;
  40 pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys);
  41
  42 with Ada.Unchecked_Deallocation;
  43
  44 package body Ada.Containers.Indefinite_Hashed_Maps is
  45
  46    type Key_Access is access Key_Type;
  47    type Element_Access is access Element_Type;
  48
  49    type Node_Type is limited record
  50       Key     : Key_Access;
  51       Element : Element_Access;
  52       Next    : Node_Access;
  53    end record;
  54
  55    procedure Free_Key is
  56       new Ada.Unchecked_Deallocation (Key_Type, Key_Access);
  57
  58    procedure Free_Element is
  59       new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
  60
  61    -----------------------
  62    -- Local Subprograms --
  63    -----------------------
  64
  65    function Copy_Node (Node : Node_Access) return Node_Access;
  66    pragma Inline (Copy_Node);
  67
  68    function Equivalent_Keys
  69      (Key  : Key_Type;
  70       Node : Node_Access) return Boolean;
  71    pragma Inline (Equivalent_Keys);
  72
  73    function Find_Equal_Key
  74      (R_Map  : Map;
  75       L_Node : Node_Access) return Boolean;
  76
  77    procedure Free (X : in out Node_Access);
  78    pragma Inline (Free);
  79
  80    function Hash_Node (Node : Node_Access) return Hash_Type;
  81    pragma Inline (Hash_Node);
  82
  83    function Next (Node : Node_Access) return Node_Access;
  84    pragma Inline (Next);
  85
  86    function Read_Node
  87      (Stream : access Root_Stream_Type'Class) return Node_Access;
  88
  89    procedure Set_Next (Node : Node_Access; Next : Node_Access);
  90    pragma Inline (Set_Next);
  91
  92    procedure Write_Node
  93      (Stream : access Root_Stream_Type'Class;
  94       Node   : Node_Access);
  95
  96    --------------------------
  97    -- Local Instantiations --
  98    --------------------------
  99
 100    package HT_Ops is
 101       new Ada.Containers.Hash_Tables.Generic_Operations
 102         (HT_Types          => HT_Types,
 103          Hash_Table_Type   => Map,
 104          Null_Node         => null,
 105          Hash_Node         => Hash_Node,
 106          Next              => Next,
 107          Set_Next          => Set_Next,
 108          Copy_Node         => Copy_Node,
 109          Free              => Free);
 110
 111    package Key_Ops is
 112       new Hash_Tables.Generic_Keys
 113        (HT_Types  => HT_Types,
 114         HT_Type   => Map,
 115         Null_Node => null,
 116         Next      => Next,
 117         Set_Next  => Set_Next,
 118         Key_Type  => Key_Type,
 119         Hash      => Hash,
 120         Equivalent_Keys => Equivalent_Keys);
 121
 122    ---------
 123    -- "=" --
 124    ---------
 125
 126    function Is_Equal is new HT_Ops.Generic_Equal (Find_Equal_Key);
 127
 128    function "=" (Left, Right : Map) return Boolean renames Is_Equal;
 129
 130    ------------
 131    -- Adjust --
 132    ------------
 133
 134    procedure Adjust (Container : in out Map) renames HT_Ops.Adjust;
 135
 136    --------------
 137    -- Capacity --
 138    --------------
 139
 140    function Capacity (Container : Map)
 141      return Count_Type renames HT_Ops.Capacity;
 142
 143    -----------
 144    -- Clear --
 145    -----------
 146
 147    procedure Clear (Container : in out Map) renames HT_Ops.Clear;
 148
 149    --------------
 150    -- Contains --
 151    --------------
 152
 153    function Contains (Container : Map; Key : Key_Type) return Boolean is
 154    begin
 155       return Find (Container, Key) /= No_Element;
 156    end Contains;
 157
 158    ---------------
 159    -- Copy_Node --
 160    ---------------
 161
 162    function Copy_Node (Node : Node_Access) return Node_Access is
 163       K : Key_Access := new Key_Type'(Node.Key.all);
 164       E : Element_Access;
 165
 166    begin
 167       E := new Element_Type'(Node.Element.all);
 168       return new Node_Type'(K, E, null);
 169
 170    exception
 171       when others =>
 172          Free_Key (K);
 173          Free_Element (E);
 174          raise;
 175    end Copy_Node;
 176
 177    ------------
 178    -- Delete --
 179    ------------
 180
 181    procedure Delete (Container : in out Map; Key : Key_Type) is
 182       X : Node_Access;
 183
 184    begin
 185       Key_Ops.Delete_Key_Sans_Free (Container, Key, X);
 186
 187       if X = null then
 188          raise Constraint_Error;
 189       end if;
 190
 191       Free (X);
 192    end Delete;
 193
 194    procedure Delete (Container : in out Map; Position : in out Cursor) is
 195    begin
 196       if Position = No_Element then
 197          return;
 198       end if;
 199
 200       if Position.Container /= Map_Access'(Container'Unchecked_Access) then
 201          raise Program_Error;
 202       end if;
 203
 204       HT_Ops.Delete_Node_Sans_Free (Container, Position.Node);
 205       Free (Position.Node);
 206
 207       Position.Container := null;
 208    end Delete;
 209
 210    -------------
 211    -- Element --
 212    -------------
 213
 214    function Element (Container : Map; Key : Key_Type) return Element_Type is
 215       C : constant Cursor := Find (Container, Key);
 216    begin
 217       return C.Node.Element.all;
 218    end Element;
 219
 220    function Element (Position : Cursor) return Element_Type is
 221    begin
 222       return Position.Node.Element.all;
 223    end Element;
 224
 225    ---------------------
 226    -- Equivalent_Keys --
 227    ---------------------
 228
 229    function Equivalent_Keys
 230      (Key  : Key_Type;
 231       Node : Node_Access) return Boolean
 232    is
 233    begin
 234       return Equivalent_Keys (Key, Node.Key.all);
 235    end Equivalent_Keys;
 236
 237    function Equivalent_Keys (Left, Right : Cursor) return Boolean is
 238    begin
 239       return Equivalent_Keys (Left.Node.Key.all, Right.Node.Key.all);
 240    end Equivalent_Keys;
 241
 242    function Equivalent_Keys
 243      (Left  : Cursor;
 244       Right : Key_Type) return Boolean
 245    is
 246    begin
 247       return Equivalent_Keys (Left.Node.Key.all, Right);
 248    end Equivalent_Keys;
 249
 250    function Equivalent_Keys
 251      (Left  : Key_Type;
 252       Right : Cursor) return Boolean
 253    is
 254    begin
 255       return Equivalent_Keys (Left, Right.Node.Key.all);
 256    end Equivalent_Keys;
 257
 258    -------------
 259    -- Exclude --
 260    -------------
 261
 262    procedure Exclude (Container : in out Map; Key : Key_Type) is
 263       X : Node_Access;
 264    begin
 265       Key_Ops.Delete_Key_Sans_Free (Container, Key, X);
 266       Free (X);
 267    end Exclude;
 268
 269    --------------
 270    -- Finalize --
 271    --------------
 272
 273    procedure Finalize (Container : in out Map) renames HT_Ops.Finalize;
 274
 275    ----------
 276    -- Find --
 277    ----------
 278
 279    function Find (Container : Map; Key : Key_Type) return Cursor is
 280       Node : constant Node_Access := Key_Ops.Find (Container, Key);
 281
 282    begin
 283       if Node = null then
 284          return No_Element;
 285       end if;
 286
 287       return Cursor'(Container'Unchecked_Access, Node);
 288    end Find;
 289
 290    --------------------
 291    -- Find_Equal_Key --
 292    --------------------
 293
 294    function Find_Equal_Key
 295      (R_Map  : Map;
 296       L_Node : Node_Access) return Boolean
 297    is
 298       R_Index : constant Hash_Type := Key_Ops.Index (R_Map, L_Node.Key.all);
 299       R_Node  : Node_Access := R_Map.Buckets (R_Index);
 300
 301    begin
 302       while R_Node /= null loop
 303          if Equivalent_Keys (L_Node.Key.all, R_Node.Key.all) then
 304             return L_Node.Element.all = R_Node.Element.all;
 305          end if;
 306
 307          R_Node := R_Node.Next;
 308       end loop;
 309
 310       return False;
 311    end Find_Equal_Key;
 312
 313    -----------
 314    -- First --
 315    -----------
 316
 317    function First (Container : Map) return Cursor is
 318       Node : constant Node_Access := HT_Ops.First (Container);
 319    begin
 320       if Node = null then
 321          return No_Element;
 322       end if;
 323
 324       return Cursor'(Container'Unchecked_Access, Node);
 325    end First;
 326
 327    ----------
 328    -- Free --
 329    ----------
 330
 331    procedure Free (X : in out Node_Access) is
 332       procedure Deallocate is
 333          new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
 334    begin
 335       if X /= null then
 336          Free_Key (X.Key);
 337          Free_Element (X.Element);
 338          Deallocate (X);
 339       end if;
 340    end Free;
 341
 342    -----------------
 343    -- Has_Element --
 344    -----------------
 345
 346    function Has_Element (Position : Cursor) return Boolean is
 347    begin
 348       return Position /= No_Element;
 349    end Has_Element;
 350
 351    ---------------
 352    -- Hash_Node --
 353    ---------------
 354
 355    function Hash_Node (Node : Node_Access) return Hash_Type is
 356    begin
 357       return Hash (Node.Key.all);
 358    end Hash_Node;
 359
 360    -------------
 361    -- Include --
 362    -------------
 363
 364    procedure Include
 365      (Container : in out Map;
 366       Key       : Key_Type;
 367       New_Item  : Element_Type)
 368    is
 369       Position : Cursor;
 370       Inserted : Boolean;
 371
 372       K : Key_Access;
 373       E : Element_Access;
 374
 375    begin
 376       Insert (Container, Key, New_Item, Position, Inserted);
 377
 378       if not Inserted then
 379          K := Position.Node.Key;
 380          E := Position.Node.Element;
 381
 382          Position.Node.Key := new Key_Type'(Key);
 383          Position.Node.Element := new Element_Type'(New_Item);
 384
 385          Free_Key (K);
 386          Free_Element (E);
 387       end if;
 388    end Include;
 389
 390    ------------
 391    -- Insert --
 392    ------------
 393
 394    procedure Insert
 395      (Container : in out Map;
 396       Key       : Key_Type;
 397       New_Item  : Element_Type;
 398       Position  : out Cursor;
 399       Inserted  : out Boolean)
 400    is
 401       function New_Node (Next : Node_Access) return Node_Access;
 402
 403       procedure Insert is
 404         new Key_Ops.Generic_Conditional_Insert (New_Node);
 405
 406       --------------
 407       -- New_Node --
 408       --------------
 409
 410       function New_Node (Next : Node_Access) return Node_Access is
 411          K  : Key_Access := new Key_Type'(Key);
 412          E  : Element_Access;
 413       begin
 414          E := new Element_Type'(New_Item);
 415          return new Node_Type'(K, E, Next);
 416       exception
 417          when others =>
 418             Free_Key (K);
 419             Free_Element (E);
 420             raise;
 421       end New_Node;
 422
 423    --  Start of processing for Insert
 424
 425    begin
 426       HT_Ops.Ensure_Capacity (Container, Container.Length + 1);
 427       Insert (Container, Key, Position.Node, Inserted);
 428       Position.Container := Container'Unchecked_Access;
 429    end Insert;
 430
 431    procedure Insert
 432      (Container : in out Map;
 433       Key       : Key_Type;
 434       New_Item  : Element_Type)
 435    is
 436       Position : Cursor;
 437       Inserted : Boolean;
 438
 439    begin
 440       Insert (Container, Key, New_Item, Position, Inserted);
 441
 442       if not Inserted then
 443          raise Constraint_Error;
 444       end if;
 445    end Insert;
 446
 447    --------------
 448    -- Is_Empty --
 449    --------------
 450
 451    function Is_Empty (Container : Map) return Boolean is
 452    begin
 453       return Container.Length = 0;
 454    end Is_Empty;
 455
 456    -------------
 457    -- Iterate --
 458    -------------
 459
 460    procedure Iterate
 461      (Container : Map;
 462       Process   : not null access procedure (Position : Cursor))
 463    is
 464       procedure Process_Node (Node : Node_Access);
 465       pragma Inline (Process_Node);
 466
 467       procedure Iterate is
 468          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 Iterate
 480
 481    begin
 482       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.all;
 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    procedure Next (Position : in out Cursor) is
 521    begin
 522       Position := Next (Position);
 523    end Next;
 524
 525    function Next (Position : Cursor) return Cursor is
 526    begin
 527       if Position = No_Element then
 528          return No_Element;
 529       end if;
 530
 531       declare
 532          M    : Map renames Position.Container.all;
 533          Node : constant Node_Access := HT_Ops.Next (M, Position.Node);
 534
 535       begin
 536          if Node = null then
 537             return No_Element;
 538          end if;
 539
 540          return Cursor'(Position.Container, Node);
 541       end;
 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.all, Position.Node.Element.all);
 554    end Query_Element;
 555
 556    ----------
 557    -- Read --
 558    ----------
 559
 560    procedure Read_Nodes is new HT_Ops.Generic_Read (Read_Node);
 561
 562    procedure Read
 563      (Stream    : access Root_Stream_Type'Class;
 564       Container : out Map) renames Read_Nodes;
 565
 566    ---------------
 567    -- Read_Node --
 568    ---------------
 569
 570    function Read_Node
 571      (Stream : access Root_Stream_Type'Class) return Node_Access
 572    is
 573       Node : Node_Access := new Node_Type;
 574
 575    begin
 576       begin
 577          Node.Key := new Key_Type'(Key_Type'Input (Stream));
 578       exception
 579          when others =>
 580             Free (Node);
 581             raise;
 582       end;
 583
 584       begin
 585          Node.Element := new Element_Type'(Element_Type'Input (Stream));
 586       exception
 587          when others =>
 588             Free_Key (Node.Key);
 589             Free (Node);
 590             raise;
 591       end;
 592
 593       return Node;
 594    end Read_Node;
 595
 596    -------------
 597    -- Replace --
 598    -------------
 599
 600    procedure Replace
 601      (Container : in out Map;
 602       Key       : Key_Type;
 603       New_Item  : Element_Type)
 604    is
 605       Node : constant Node_Access := Key_Ops.Find (Container, Key);
 606
 607       K : Key_Access;
 608       E : Element_Access;
 609
 610    begin
 611       if Node = null then
 612          raise Constraint_Error;
 613       end if;
 614
 615       K := Node.Key;
 616       E := Node.Element;
 617
 618       Node.Key := new Key_Type'(Key);
 619       Node.Element := new Element_Type'(New_Item);
 620
 621       Free_Key (K);
 622       Free_Element (E);
 623    end Replace;
 624
 625    ---------------------
 626    -- Replace_Element --
 627    ---------------------
 628
 629    procedure Replace_Element (Position : Cursor; By : Element_Type) is
 630       X : Element_Access := Position.Node.Element;
 631    begin
 632       Position.Node.Element := new Element_Type'(By);
 633       Free_Element (X);
 634    end Replace_Element;
 635
 636    ----------------------
 637    -- Reserve_Capacity --
 638    ----------------------
 639
 640    procedure Reserve_Capacity
 641      (Container : in out Map;
 642       Capacity  : Count_Type) renames HT_Ops.Ensure_Capacity;
 643
 644    --------------
 645    -- Set_Next --
 646    --------------
 647
 648    procedure Set_Next (Node : Node_Access; Next : Node_Access) is
 649    begin
 650       Node.Next := Next;
 651    end Set_Next;
 652
 653    --------------------
 654    -- Update_Element --
 655    --------------------
 656
 657    procedure Update_Element
 658      (Position : Cursor;
 659       Process  : not null access procedure (Element : in out Element_Type))
 660    is
 661    begin
 662       Process (Position.Node.Key.all, Position.Node.Element.all);
 663    end Update_Element;
 664
 665    -----------
 666    -- Write --
 667    -----------
 668
 669    procedure Write_Nodes is new HT_Ops.Generic_Write (Write_Node);
 670
 671    procedure Write
 672      (Stream    : access Root_Stream_Type'Class;
 673       Container : Map) renames Write_Nodes;
 674
 675    ----------------
 676    -- Write_Node --
 677    ----------------
 678
 679    procedure Write_Node
 680      (Stream : access Root_Stream_Type'Class;
 681       Node   : Node_Access)
 682    is
 683    begin
 684       Key_Type'Output (Stream, Node.Key.all);
 685       Element_Type'Output (Stream, Node.Element.all);
 686    end Write_Node;
 687
 688 end Ada.Containers.Indefinite_Hashed_Maps;
 689