gcc/ada/s-htable.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUNTIME 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-2002 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 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 of the Table is
  52       --  empty. Returns Iterator_Ptr if non null, or the next non null
  53       --  element in 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
 225       begin
 226          if Tmp = null then
 227             return No_Element;
 228          else
 229             return Tmp.E;
 230          end if;
 231       end Get;
 232
 233       ---------------
 234       -- Get_First --
 235       ---------------
 236
 237       function Get_First return Element is
 238          Tmp : constant Elmt_Ptr := Tab.Get_First;
 239
 240       begin
 241          if Tmp = null then
 242             return No_Element;
 243          else
 244             return Tmp.E;
 245          end if;
 246       end Get_First;
 247
 248       -------------
 249       -- Get_Key --
 250       -------------
 251
 252       function Get_Key (E : Elmt_Ptr) return Key is
 253       begin
 254          return E.K;
 255       end Get_Key;
 256
 257       --------------
 258       -- Get_Next --
 259       --------------
 260
 261       function Get_Next return Element is
 262          Tmp : constant Elmt_Ptr := Tab.Get_Next;
 263
 264       begin
 265          if Tmp = null then
 266             return No_Element;
 267          else
 268             return Tmp.E;
 269          end if;
 270       end Get_Next;
 271
 272       ----------
 273       -- Next --
 274       ----------
 275
 276       function Next (E : Elmt_Ptr) return Elmt_Ptr is
 277       begin
 278          return E.Next;
 279       end Next;
 280
 281       ------------
 282       -- Remove --
 283       ------------
 284
 285       procedure Remove  (K : Key) is
 286          Tmp : Elmt_Ptr;
 287
 288       begin
 289          Tmp := Tab.Get (K);
 290
 291          if Tmp /= null then
 292             Tab.Remove (K);
 293             Free (Tmp);
 294          end if;
 295       end Remove;
 296
 297       -----------
 298       -- Reset --
 299       -----------
 300
 301       procedure Reset is
 302          E1, E2 : Elmt_Ptr;
 303
 304       begin
 305          E1 := Tab.Get_First;
 306          while E1 /= null loop
 307             E2 := Tab.Get_Next;
 308             Free (E1);
 309             E1 := E2;
 310          end loop;
 311
 312          Tab.Reset;
 313       end Reset;
 314
 315       ---------
 316       -- Set --
 317       ---------
 318
 319       procedure Set (K : Key; E : Element) is
 320          Tmp : constant Elmt_Ptr := Tab.Get (K);
 321
 322       begin
 323          if Tmp = null then
 324             Tab.Set (new Element_Wrapper'(K, E, null));
 325          else
 326             Tmp.E := E;
 327          end if;
 328       end Set;
 329
 330       --------------
 331       -- Set_Next --
 332       --------------
 333
 334       procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr) is
 335       begin
 336          E.Next := Next;
 337       end Set_Next;
 338    end Simple_HTable;
 339
 340    ----------
 341    -- Hash --
 342    ----------
 343
 344    function Hash (Key : String) return Header_Num is
 345
 346       type Uns is mod 2 ** 32;
 347
 348       function Rotate_Left (Value : Uns; Amount : Natural) return Uns;
 349       pragma Import (Intrinsic, Rotate_Left);
 350
 351       Tmp : Uns := 0;
 352
 353    begin
 354       for J in Key'Range loop
 355          Tmp := Rotate_Left (Tmp, 1) + Character'Pos (Key (J));
 356       end loop;
 357
 358       return Header_Num'First +
 359                Header_Num'Base (Tmp mod Header_Num'Range_Length);
 360    end Hash;
 361
 362 end System.HTable;