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