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-2006, 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 2,  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.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- GNAT was originally developed  by the GNAT team at  New York University. --
  30 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 with Ada.Unchecked_Deallocation;
  35
  36 package body System.HTable is
  37
  38    -------------------
  39    -- Static_HTable --
  40    -------------------
  41
  42    package body Static_HTable is
  43
  44       Table : array (Header_Num) of Elmt_Ptr;
  45
  46       Iterator_Index   : Header_Num;
  47       Iterator_Ptr     : Elmt_Ptr;
  48       Iterator_Started : Boolean := False;
  49
  50       function Get_Non_Null return Elmt_Ptr;
  51       --  Returns Null_Ptr if Iterator_Started is false or the Table is empty.
  52       --  Returns Iterator_Ptr if non null, or the next non null element in
  53       --  table if any.
  54
  55       ---------
  56       -- Get --
  57       ---------
  58
  59       function Get (K : Key) return Elmt_Ptr is
  60          Elmt : Elmt_Ptr;
  61
  62       begin
  63          Elmt := Table (Hash (K));
  64
  65          loop
  66             if Elmt = Null_Ptr then
  67                return Null_Ptr;
  68
  69             elsif Equal (Get_Key (Elmt), K) then
  70                return Elmt;
  71
  72             else
  73                Elmt := Next (Elmt);
  74             end if;
  75          end loop;
  76       end Get;
  77
  78       ---------------
  79       -- Get_First --
  80       ---------------
  81
  82       function Get_First return Elmt_Ptr is
  83       begin
  84          Iterator_Started := True;
  85          Iterator_Index := Table'First;
  86          Iterator_Ptr := Table (Iterator_Index);
  87          return Get_Non_Null;
  88       end Get_First;
  89
  90       --------------
  91       -- Get_Next --
  92       --------------
  93
  94       function Get_Next return Elmt_Ptr is
  95       begin
  96          if not Iterator_Started then
  97             return Null_Ptr;
  98          end if;
  99
 100          Iterator_Ptr := Next (Iterator_Ptr);
 101          return Get_Non_Null;
 102       end Get_Next;
 103
 104       ------------------
 105       -- Get_Non_Null --
 106       ------------------
 107
 108       function Get_Non_Null return Elmt_Ptr is
 109       begin
 110          while Iterator_Ptr = Null_Ptr  loop
 111             if Iterator_Index = Table'Last then
 112                Iterator_Started := False;
 113                return Null_Ptr;
 114             end if;
 115
 116             Iterator_Index := Iterator_Index + 1;
 117             Iterator_Ptr   := Table (Iterator_Index);
 118          end loop;
 119
 120          return Iterator_Ptr;
 121       end Get_Non_Null;
 122
 123       ------------
 124       -- Remove --
 125       ------------
 126
 127       procedure Remove  (K : Key) is
 128          Index     : constant Header_Num := Hash (K);
 129          Elmt      : Elmt_Ptr;
 130          Next_Elmt : Elmt_Ptr;
 131
 132       begin
 133          Elmt := Table (Index);
 134
 135          if Elmt = Null_Ptr then
 136             return;
 137
 138          elsif Equal (Get_Key (Elmt), K) then
 139             Table (Index) := Next (Elmt);
 140
 141          else
 142             loop
 143                Next_Elmt :=  Next (Elmt);
 144
 145                if Next_Elmt = Null_Ptr then
 146                   return;
 147
 148                elsif Equal (Get_Key (Next_Elmt), K) then
 149                   Set_Next (Elmt, Next (Next_Elmt));
 150                   return;
 151
 152                else
 153                   Elmt := Next_Elmt;
 154                end if;
 155             end loop;
 156          end if;
 157       end Remove;
 158
 159       -----------
 160       -- Reset --
 161       -----------
 162
 163       procedure Reset is
 164       begin
 165          for J in Table'Range loop
 166             Table (J) := Null_Ptr;
 167          end loop;
 168       end Reset;
 169
 170       ---------
 171       -- Set --
 172       ---------
 173
 174       procedure Set (E : Elmt_Ptr) is
 175          Index : Header_Num;
 176
 177       begin
 178          Index := Hash (Get_Key (E));
 179          Set_Next (E, Table (Index));
 180          Table (Index) := E;
 181       end Set;
 182
 183    end Static_HTable;
 184
 185    -------------------
 186    -- Simple_HTable --
 187    -------------------
 188
 189    package body Simple_HTable is
 190
 191       type Element_Wrapper;
 192       type Elmt_Ptr is access all Element_Wrapper;
 193       type Element_Wrapper is record
 194          K    : Key;
 195          E    : Element;
 196          Next : Elmt_Ptr;
 197       end record;
 198
 199       procedure Free is new
 200         Ada.Unchecked_Deallocation (Element_Wrapper, Elmt_Ptr);
 201
 202       procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr);
 203       function  Next     (E : Elmt_Ptr) return Elmt_Ptr;
 204       function  Get_Key  (E : Elmt_Ptr) return Key;
 205
 206       package Tab is new Static_HTable (
 207         Header_Num => Header_Num,
 208         Element    => Element_Wrapper,
 209         Elmt_Ptr   => Elmt_Ptr,
 210         Null_Ptr   => null,
 211         Set_Next   => Set_Next,
 212         Next       => Next,
 213         Key        => Key,
 214         Get_Key    => Get_Key,
 215         Hash       => Hash,
 216         Equal      => Equal);
 217
 218       ---------
 219       -- Get --
 220       ---------
 221
 222       function  Get (K : Key) return Element is
 223          Tmp : constant Elmt_Ptr := Tab.Get (K);
 224       begin
 225          if Tmp = null then
 226             return No_Element;
 227          else
 228             return Tmp.E;
 229          end if;
 230       end Get;
 231
 232       ---------------
 233       -- Get_First --
 234       ---------------
 235
 236       function Get_First return Element is
 237          Tmp : constant Elmt_Ptr := Tab.Get_First;
 238       begin
 239          if Tmp = null then
 240             return No_Element;
 241          else
 242             return Tmp.E;
 243          end if;
 244       end Get_First;
 245
 246       -------------
 247       -- Get_Key --
 248       -------------
 249
 250       function Get_Key (E : Elmt_Ptr) return Key is
 251       begin
 252          return E.K;
 253       end Get_Key;
 254
 255       --------------
 256       -- Get_Next --
 257       --------------
 258
 259       function Get_Next return Element is
 260          Tmp : constant Elmt_Ptr := Tab.Get_Next;
 261       begin
 262          if Tmp = null then
 263             return No_Element;
 264          else
 265             return Tmp.E;
 266          end if;
 267       end Get_Next;
 268
 269       ----------
 270       -- Next --
 271       ----------
 272
 273       function Next (E : Elmt_Ptr) return Elmt_Ptr is
 274       begin
 275          return E.Next;
 276       end Next;
 277
 278       ------------
 279       -- Remove --
 280       ------------
 281
 282       procedure Remove  (K : Key) is
 283          Tmp : Elmt_Ptr;
 284
 285       begin
 286          Tmp := Tab.Get (K);
 287
 288          if Tmp /= null then
 289             Tab.Remove (K);
 290             Free (Tmp);
 291          end if;
 292       end Remove;
 293
 294       -----------
 295       -- Reset --
 296       -----------
 297
 298       procedure Reset is
 299          E1, E2 : Elmt_Ptr;
 300
 301       begin
 302          E1 := Tab.Get_First;
 303          while E1 /= null loop
 304             E2 := Tab.Get_Next;
 305             Free (E1);
 306             E1 := E2;
 307          end loop;
 308
 309          Tab.Reset;
 310       end Reset;
 311
 312       ---------
 313       -- Set --
 314       ---------
 315
 316       procedure Set (K : Key; E : Element) is
 317          Tmp : constant Elmt_Ptr := Tab.Get (K);
 318       begin
 319          if Tmp = null then
 320             Tab.Set (new Element_Wrapper'(K, E, null));
 321          else
 322             Tmp.E := E;
 323          end if;
 324       end Set;
 325
 326       --------------
 327       -- Set_Next --
 328       --------------
 329
 330       procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr) is
 331       begin
 332          E.Next := Next;
 333       end Set_Next;
 334    end Simple_HTable;
 335
 336    ----------
 337    -- Hash --
 338    ----------
 339
 340    function Hash (Key : String) return Header_Num is
 341
 342       type Uns is mod 2 ** 32;
 343
 344       function Rotate_Left (Value : Uns; Amount : Natural) return Uns;
 345       pragma Import (Intrinsic, Rotate_Left);
 346
 347       Hash_Value : Uns;
 348
 349    begin
 350       Hash_Value := 0;
 351       for J in Key'Range loop
 352          Hash_Value := Rotate_Left (Hash_Value, 3) + Character'Pos (Key (J));
 353       end loop;
 354
 355       return Header_Num'First +
 356                Header_Num'Base (Hash_Value mod Header_Num'Range_Length);
 357    end Hash;
 358
 359 end System.HTable;