gcc/ada/g-htable.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUNTIME COMPONENTS                          --
   4 --                                                                          --
   5 --                          G N A T . H T A B L E                           --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --           Copyright (C) 1995-1999 Ada Core Technologies, 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 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,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com).   --
  30 --                                                                          --
  31 ------------------------------------------------------------------------------
  32
  33 with Ada.Unchecked_Deallocation;
  34 package body GNAT.HTable is
  35
  36    --------------------
  37    --  Static_HTable --
  38    --------------------
  39
  40    package body Static_HTable is
  41
  42       Table : array (Header_Num) of Elmt_Ptr;
  43
  44       Iterator_Index   : Header_Num;
  45       Iterator_Ptr     : Elmt_Ptr;
  46       Iterator_Started : Boolean := False;
  47
  48       function Get_Non_Null return Elmt_Ptr;
  49       --  Returns Null_Ptr if Iterator_Started is false of the Table is
  50       --  empty. Returns Iterator_Ptr if non null, or the next non null
  51       --  element in table if any.
  52
  53       ---------
  54       -- Get --
  55       ---------
  56
  57       function  Get (K : Key) return Elmt_Ptr is
  58          Elmt  : Elmt_Ptr;
  59
  60       begin
  61          Elmt := Table (Hash (K));
  62
  63          loop
  64             if Elmt = Null_Ptr then
  65                return Null_Ptr;
  66
  67             elsif Equal (Get_Key (Elmt), K) then
  68                return Elmt;
  69
  70             else
  71                Elmt := Next (Elmt);
  72             end if;
  73          end loop;
  74       end Get;
  75
  76       ---------------
  77       -- Get_First --
  78       ---------------
  79
  80       function Get_First return Elmt_Ptr is
  81       begin
  82          Iterator_Started := True;
  83          Iterator_Index := Table'First;
  84          Iterator_Ptr := Table (Iterator_Index);
  85          return Get_Non_Null;
  86       end Get_First;
  87
  88       --------------
  89       -- Get_Next --
  90       --------------
  91
  92       function Get_Next return Elmt_Ptr is
  93       begin
  94          if not Iterator_Started then
  95             return Null_Ptr;
  96          end if;
  97
  98          Iterator_Ptr := Next (Iterator_Ptr);
  99          return Get_Non_Null;
 100       end Get_Next;
 101
 102       ------------------
 103       -- Get_Non_Null --
 104       ------------------
 105
 106       function Get_Non_Null return Elmt_Ptr is
 107       begin
 108          while Iterator_Ptr = Null_Ptr  loop
 109             if Iterator_Index = Table'Last then
 110                Iterator_Started := False;
 111                return Null_Ptr;
 112             end if;
 113
 114             Iterator_Index := Iterator_Index + 1;
 115             Iterator_Ptr   := Table (Iterator_Index);
 116          end loop;
 117
 118          return Iterator_Ptr;
 119       end Get_Non_Null;
 120
 121       ------------
 122       -- Remove --
 123       ------------
 124
 125       procedure Remove  (K : Key) is
 126          Index     : constant Header_Num := Hash (K);
 127          Elmt      : Elmt_Ptr;
 128          Next_Elmt : Elmt_Ptr;
 129
 130       begin
 131          Elmt := Table (Index);
 132
 133          if Elmt = Null_Ptr then
 134             return;
 135
 136          elsif Equal (Get_Key (Elmt), K) then
 137             Table (Index) := Next (Elmt);
 138
 139          else
 140             loop
 141                Next_Elmt :=  Next (Elmt);
 142
 143                if Next_Elmt = Null_Ptr then
 144                   return;
 145
 146                elsif Equal (Get_Key (Next_Elmt), K) then
 147                   Set_Next (Elmt, Next (Next_Elmt));
 148                   return;
 149
 150                else
 151                   Elmt := Next_Elmt;
 152                end if;
 153             end loop;
 154          end if;
 155       end Remove;
 156
 157       -----------
 158       -- Reset --
 159       -----------
 160
 161       procedure Reset is
 162       begin
 163          for J in Table'Range loop
 164             Table (J) := Null_Ptr;
 165          end loop;
 166       end Reset;
 167
 168       ---------
 169       -- Set --
 170       ---------
 171
 172       procedure Set (E : Elmt_Ptr) is
 173          Index : Header_Num;
 174
 175       begin
 176          Index := Hash (Get_Key (E));
 177          Set_Next (E, Table (Index));
 178          Table (Index) := E;
 179       end Set;
 180
 181    end Static_HTable;
 182
 183    --------------------
 184    --  Simple_HTable --
 185    --------------------
 186
 187    package body Simple_HTable is
 188
 189       type Element_Wrapper;
 190       type Elmt_Ptr is access all Element_Wrapper;
 191       type Element_Wrapper is record
 192          K    : Key;
 193          E    : Element;
 194          Next : Elmt_Ptr;
 195       end record;
 196
 197       procedure Free is new
 198         Ada.Unchecked_Deallocation (Element_Wrapper, Elmt_Ptr);
 199
 200       procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr);
 201       function  Next     (E : Elmt_Ptr) return Elmt_Ptr;
 202       function  Get_Key  (E : Elmt_Ptr) return Key;
 203
 204       package Tab is new Static_HTable (
 205         Header_Num => Header_Num,
 206         Element    => Element_Wrapper,
 207         Elmt_Ptr   => Elmt_Ptr,
 208         Null_Ptr   => null,
 209         Set_Next   => Set_Next,
 210         Next       => Next,
 211         Key        => Key,
 212         Get_Key    => Get_Key,
 213         Hash       => Hash,
 214         Equal      => Equal);
 215
 216       ---------
 217       -- Get --
 218       ---------
 219
 220       function  Get (K : Key) return Element is
 221          Tmp : constant Elmt_Ptr := Tab.Get (K);
 222
 223       begin
 224          if Tmp = null then
 225             return No_Element;
 226          else
 227             return Tmp.E;
 228          end if;
 229       end Get;
 230
 231       ---------------
 232       -- Get_First --
 233       ---------------
 234
 235       function Get_First return Element is
 236          Tmp : constant Elmt_Ptr := Tab.Get_First;
 237
 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
 262       begin
 263          if Tmp = null then
 264             return No_Element;
 265          else
 266             return Tmp.E;
 267          end if;
 268       end Get_Next;
 269
 270       ----------
 271       -- Next --
 272       ----------
 273
 274       function Next (E : Elmt_Ptr) return Elmt_Ptr is
 275       begin
 276          return E.Next;
 277       end Next;
 278
 279       ------------
 280       -- Remove --
 281       ------------
 282
 283       procedure Remove  (K : Key) is
 284          Tmp : Elmt_Ptr;
 285
 286       begin
 287          Tmp := Tab.Get (K);
 288
 289          if Tmp /= null then
 290             Tab.Remove (K);
 291             Free (Tmp);
 292          end if;
 293       end Remove;
 294
 295       -----------
 296       -- Reset --
 297       -----------
 298
 299       procedure Reset is
 300          E1, E2 : Elmt_Ptr;
 301
 302       begin
 303          E1 := Tab.Get_First;
 304          while E1 /= null loop
 305             E2 := Tab.Get_Next;
 306             Free (E1);
 307             E1 := E2;
 308          end loop;
 309
 310          Tab.Reset;
 311       end Reset;
 312
 313       ---------
 314       -- Set --
 315       ---------
 316
 317       procedure Set (K : Key; E : Element) is
 318          Tmp : constant Elmt_Ptr := Tab.Get (K);
 319
 320       begin
 321          if Tmp = null then
 322             Tab.Set (new Element_Wrapper'(K, E, null));
 323          else
 324             Tmp.E := E;
 325          end if;
 326       end Set;
 327
 328       --------------
 329       -- Set_Next --
 330       --------------
 331
 332       procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr) is
 333       begin
 334          E.Next := Next;
 335       end Set_Next;
 336    end Simple_HTable;
 337
 338    ----------
 339    -- Hash --
 340    ----------
 341
 342    function Hash (Key : String) return Header_Num is
 343
 344       type Uns is mod 2 ** 32;
 345
 346       function Rotate_Left (Value : Uns; Amount : Natural) return Uns;
 347       pragma Import (Intrinsic, Rotate_Left);
 348
 349       Tmp : Uns := 0;
 350
 351    begin
 352       for J in Key'Range loop
 353          Tmp := Rotate_Left (Tmp, 1) + Character'Pos (Key (J));
 354       end loop;
 355
 356       return Header_Num'First +
 357                Header_Num'Base (Tmp mod Header_Num'Range_Length);
 358    end Hash;
 359
 360 end GNAT.HTable;