gcc/ada/s-htable.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --                        S Y S T E M . H T A B L E                         --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --                    Copyright (C) 1995-2011, AdaCore                      --
  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 -- GNAT was originally developed  by the GNAT team at  New York University. --
  28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 pragma Compiler_Unit;
  33
  34 with Ada.Unchecked_Deallocation;
  35 with System.String_Hash;
  36
  37 package body System.HTable is
  38
  39    -------------------
  40    -- Static_HTable --
  41    -------------------
  42
  43    package body Static_HTable is
  44
  45       Table : array (Header_Num) of Elmt_Ptr;
  46
  47       Iterator_Index   : Header_Num;
  48       Iterator_Ptr     : Elmt_Ptr;
  49       Iterator_Started : Boolean := False;
  50
  51       function Get_Non_Null return Elmt_Ptr;
  52       --  Returns Null_Ptr if Iterator_Started is false or the Table is empty.
  53       --  Returns Iterator_Ptr if non null, or the next non null element in
  54       --  table if any.
  55
  56       ---------
  57       -- Get --
  58       ---------
  59
  60       function Get (K : Key) return Elmt_Ptr is
  61          Elmt : Elmt_Ptr;
  62
  63       begin
  64          Elmt := Table (Hash (K));
  65
  66          loop
  67             if Elmt = Null_Ptr then
  68                return Null_Ptr;
  69
  70             elsif Equal (Get_Key (Elmt), K) then
  71                return Elmt;
  72
  73             else
  74                Elmt := Next (Elmt);
  75             end if;
  76          end loop;
  77       end Get;
  78
  79       ---------------
  80       -- Get_First --
  81       ---------------
  82
  83       function Get_First return Elmt_Ptr is
  84       begin
  85          Iterator_Started := True;
  86          Iterator_Index := Table'First;
  87          Iterator_Ptr := Table (Iterator_Index);
  88          return Get_Non_Null;
  89       end Get_First;
  90
  91       --------------
  92       -- Get_Next --
  93       --------------
  94
  95       function Get_Next return Elmt_Ptr is
  96       begin
  97          if not Iterator_Started then
  98             return Null_Ptr;
  99          end if;
 100
 101          Iterator_Ptr := Next (Iterator_Ptr);
 102          return Get_Non_Null;
 103       end Get_Next;
 104
 105       ------------------
 106       -- Get_Non_Null --
 107       ------------------
 108
 109       function Get_Non_Null return Elmt_Ptr is
 110       begin
 111          while Iterator_Ptr = Null_Ptr loop
 112             if Iterator_Index = Table'Last then
 113                Iterator_Started := False;
 114                return Null_Ptr;
 115             end if;
 116
 117             Iterator_Index := Iterator_Index + 1;
 118             Iterator_Ptr   := Table (Iterator_Index);
 119          end loop;
 120
 121          return Iterator_Ptr;
 122       end Get_Non_Null;
 123
 124       -------------
 125       -- Present --
 126       -------------
 127
 128       function Present (K : Key) return Boolean is
 129       begin
 130          return Get (K) /= Null_Ptr;
 131       end Present;
 132
 133       ------------
 134       -- Remove --
 135       ------------
 136
 137       procedure Remove  (K : Key) is
 138          Index     : constant Header_Num := Hash (K);
 139          Elmt      : Elmt_Ptr;
 140          Next_Elmt : Elmt_Ptr;
 141
 142       begin
 143          Elmt := Table (Index);
 144
 145          if Elmt = Null_Ptr then
 146             return;
 147
 148          elsif Equal (Get_Key (Elmt), K) then
 149             Table (Index) := Next (Elmt);
 150
 151          else
 152             loop
 153                Next_Elmt :=  Next (Elmt);
 154
 155                if Next_Elmt = Null_Ptr then
 156                   return;
 157
 158                elsif Equal (Get_Key (Next_Elmt), K) then
 159                   Set_Next (Elmt, Next (Next_Elmt));
 160                   return;
 161
 162                else
 163                   Elmt := Next_Elmt;
 164                end if;
 165             end loop;
 166          end if;
 167       end Remove;
 168
 169       -----------
 170       -- Reset --
 171       -----------
 172
 173       procedure Reset is
 174       begin
 175          for J in Table'Range loop
 176             Table (J) := Null_Ptr;
 177          end loop;
 178       end Reset;
 179
 180       ---------
 181       -- Set --
 182       ---------
 183
 184       procedure Set (E : Elmt_Ptr) is
 185          Index : Header_Num;
 186
 187       begin
 188          Index := Hash (Get_Key (E));
 189          Set_Next (E, Table (Index));
 190          Table (Index) := E;
 191       end Set;
 192
 193       ------------------------
 194       -- Set_If_Not_Present --
 195       ------------------------
 196
 197       function Set_If_Not_Present (E : Elmt_Ptr) return Boolean is
 198          K : Key renames Get_Key (E);
 199          --  Note that it is important to use a renaming here rather than
 200          --  define a constant initialized by the call, because the latter
 201          --  construct runs into bootstrap problems with earlier versions
 202          --  of the GNAT compiler.
 203
 204          Index : constant Header_Num := Hash (K);
 205          Elmt  : Elmt_Ptr;
 206
 207       begin
 208          Elmt := Table (Index);
 209          loop
 210             if Elmt = Null_Ptr then
 211                Set_Next (E, Table (Index));
 212                Table (Index) := E;
 213                return True;
 214
 215             elsif Equal (Get_Key (Elmt), K) then
 216                return False;
 217
 218             else
 219                Elmt := Next (Elmt);
 220             end if;
 221          end loop;
 222       end Set_If_Not_Present;
 223
 224    end Static_HTable;
 225
 226    -------------------
 227    -- Simple_HTable --
 228    -------------------
 229
 230    package body Simple_HTable is
 231
 232       type Element_Wrapper;
 233       type Elmt_Ptr is access all Element_Wrapper;
 234       type Element_Wrapper is record
 235          K    : Key;
 236          E    : Element;
 237          Next : Elmt_Ptr;
 238       end record;
 239
 240       procedure Free is new
 241         Ada.Unchecked_Deallocation (Element_Wrapper, Elmt_Ptr);
 242
 243       procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr);
 244       function  Next     (E : Elmt_Ptr) return Elmt_Ptr;
 245       function  Get_Key  (E : Elmt_Ptr) return Key;
 246
 247       package Tab is new Static_HTable (
 248         Header_Num => Header_Num,
 249         Element    => Element_Wrapper,
 250         Elmt_Ptr   => Elmt_Ptr,
 251         Null_Ptr   => null,
 252         Set_Next   => Set_Next,
 253         Next       => Next,
 254         Key        => Key,
 255         Get_Key    => Get_Key,
 256         Hash       => Hash,
 257         Equal      => Equal);
 258
 259       ---------
 260       -- Get --
 261       ---------
 262
 263       function  Get (K : Key) return Element is
 264          Tmp : constant Elmt_Ptr := Tab.Get (K);
 265       begin
 266          if Tmp = null then
 267             return No_Element;
 268          else
 269             return Tmp.E;
 270          end if;
 271       end Get;
 272
 273       ---------------
 274       -- Get_First --
 275       ---------------
 276
 277       function Get_First return Element is
 278          Tmp : constant Elmt_Ptr := Tab.Get_First;
 279       begin
 280          if Tmp = null then
 281             return No_Element;
 282          else
 283             return Tmp.E;
 284          end if;
 285       end Get_First;
 286
 287       procedure Get_First (K : in out Key; E : out Element) is
 288          Tmp : constant Elmt_Ptr := Tab.Get_First;
 289       begin
 290          if Tmp = null then
 291             E := No_Element;
 292          else
 293             K := Tmp.K;
 294             E := Tmp.E;
 295          end if;
 296       end Get_First;
 297
 298       -------------
 299       -- Get_Key --
 300       -------------
 301
 302       function Get_Key (E : Elmt_Ptr) return Key is
 303       begin
 304          return E.K;
 305       end Get_Key;
 306
 307       --------------
 308       -- Get_Next --
 309       --------------
 310
 311       function Get_Next return Element is
 312          Tmp : constant Elmt_Ptr := Tab.Get_Next;
 313       begin
 314          if Tmp = null then
 315             return No_Element;
 316          else
 317             return Tmp.E;
 318          end if;
 319       end Get_Next;
 320
 321       procedure Get_Next (K : in out Key; E : out Element) is
 322          Tmp : constant Elmt_Ptr := Tab.Get_Next;
 323       begin
 324          if Tmp = null then
 325             E := No_Element;
 326          else
 327             K := Tmp.K;
 328             E := Tmp.E;
 329          end if;
 330       end Get_Next;
 331
 332       ----------
 333       -- Next --
 334       ----------
 335
 336       function Next (E : Elmt_Ptr) return Elmt_Ptr is
 337       begin
 338          return E.Next;
 339       end Next;
 340
 341       ------------
 342       -- Remove --
 343       ------------
 344
 345       procedure Remove  (K : Key) is
 346          Tmp : Elmt_Ptr;
 347
 348       begin
 349          Tmp := Tab.Get (K);
 350
 351          if Tmp /= null then
 352             Tab.Remove (K);
 353             Free (Tmp);
 354          end if;
 355       end Remove;
 356
 357       -----------
 358       -- Reset --
 359       -----------
 360
 361       procedure Reset is
 362          E1, E2 : Elmt_Ptr;
 363
 364       begin
 365          E1 := Tab.Get_First;
 366          while E1 /= null loop
 367             E2 := Tab.Get_Next;
 368             Free (E1);
 369             E1 := E2;
 370          end loop;
 371
 372          Tab.Reset;
 373       end Reset;
 374
 375       ---------
 376       -- Set --
 377       ---------
 378
 379       procedure Set (K : Key; E : Element) is
 380          Tmp : constant Elmt_Ptr := Tab.Get (K);
 381       begin
 382          if Tmp = null then
 383             Tab.Set (new Element_Wrapper'(K, E, null));
 384          else
 385             Tmp.E := E;
 386          end if;
 387       end Set;
 388
 389       --------------
 390       -- Set_Next --
 391       --------------
 392
 393       procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr) is
 394       begin
 395          E.Next := Next;
 396       end Set_Next;
 397    end Simple_HTable;
 398
 399    ----------
 400    -- Hash --
 401    ----------
 402
 403    function Hash (Key : String) return Header_Num is
 404       type Uns is mod 2 ** 32;
 405
 406       function Hash_Fun is
 407          new System.String_Hash.Hash (Character, String, Uns);
 408
 409    begin
 410       return Header_Num'First +
 411         Header_Num'Base (Hash_Fun (Key) mod Header_Num'Range_Length);
 412    end Hash;
 413
 414 end System.HTable;