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