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 --                                                                          --
  10 --           Copyright (C) 1995-1999 Ada Core Technologies, Inc.            --
  11 --                                                                          --
  12 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  20 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  21 -- MA 02111-1307, USA.                                                      --
  22 --                                                                          --
  23 -- As a special exception,  if other files  instantiate  generics from this --
  24 -- unit, or you link  this unit with other files  to produce an executable, --
  25 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  26 -- covered  by the  GNU  General  Public  License.  This exception does not --
  27 -- however invalidate  any other reasons why  the executable file  might be --
  28 -- covered by the  GNU Public License.                                      --
  29 --                                                                          --
  30 -- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com).   --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 with Ada.Unchecked_Deallocation;
  35 package body GNAT.HTable is
  36
  37    --------------------
  38    --  Static_HTable --
  39    --------------------
  40
  41    package body Static_HTable is
  42
  43       Table : array (Header_Num) of Elmt_Ptr;
  44
  45       Iterator_Index   : Header_Num;
  46       Iterator_Ptr     : Elmt_Ptr;
  47       Iterator_Started : Boolean := False;
  48
  49       function Get_Non_Null return Elmt_Ptr;
  50       --  Returns Null_Ptr if Iterator_Started is false of the Table is
  51       --  empty. Returns Iterator_Ptr if non null, or the next non null
  52       --  element in table if any.
  53
  54       ---------
  55       -- Get --
  56       ---------
  57
  58       function  Get (K : Key) return Elmt_Ptr is
  59          Elmt  : Elmt_Ptr;
  60
  61       begin
  62          Elmt := Table (Hash (K));
  63
  64          loop
  65             if Elmt = Null_Ptr then
  66                return Null_Ptr;
  67
  68             elsif Equal (Get_Key (Elmt), K) then
  69                return Elmt;
  70
  71             else
  72                Elmt := Next (Elmt);
  73             end if;
  74          end loop;
  75       end Get;
  76
  77       ---------------
  78       -- Get_First --
  79       ---------------
  80
  81       function Get_First return Elmt_Ptr is
  82       begin
  83          Iterator_Started := True;
  84          Iterator_Index := Table'First;
  85          Iterator_Ptr := Table (Iterator_Index);
  86          return Get_Non_Null;
  87       end Get_First;
  88
  89       --------------
  90       -- Get_Next --
  91       --------------
  92
  93       function Get_Next return Elmt_Ptr is
  94       begin
  95          if not Iterator_Started then
  96             return Null_Ptr;
  97          end if;
  98
  99          Iterator_Ptr := Next (Iterator_Ptr);
 100          return Get_Non_Null;
 101       end Get_Next;
 102
 103       ------------------
 104       -- Get_Non_Null --
 105       ------------------
 106
 107       function Get_Non_Null return Elmt_Ptr is
 108       begin
 109          while Iterator_Ptr = Null_Ptr  loop
 110             if Iterator_Index = Table'Last then
 111                Iterator_Started := False;
 112                return Null_Ptr;
 113             end if;
 114
 115             Iterator_Index := Iterator_Index + 1;
 116             Iterator_Ptr   := Table (Iterator_Index);
 117          end loop;
 118
 119          return Iterator_Ptr;
 120       end Get_Non_Null;
 121
 122       ------------
 123       -- Remove --
 124       ------------
 125
 126       procedure Remove  (K : Key) is
 127          Index     : constant Header_Num := Hash (K);
 128          Elmt      : Elmt_Ptr;
 129          Next_Elmt : Elmt_Ptr;
 130
 131       begin
 132          Elmt := Table (Index);
 133
 134          if Elmt = Null_Ptr then
 135             return;
 136
 137          elsif Equal (Get_Key (Elmt), K) then
 138             Table (Index) := Next (Elmt);
 139
 140          else
 141             loop
 142                Next_Elmt :=  Next (Elmt);
 143
 144                if Next_Elmt = Null_Ptr then
 145                   return;
 146
 147                elsif Equal (Get_Key (Next_Elmt), K) then
 148                   Set_Next (Elmt, Next (Next_Elmt));
 149                   return;
 150
 151                else
 152                   Elmt := Next_Elmt;
 153                end if;
 154             end loop;
 155          end if;
 156       end Remove;
 157
 158       -----------
 159       -- Reset --
 160       -----------
 161
 162       procedure Reset is
 163       begin
 164          for J in Table'Range loop
 165             Table (J) := Null_Ptr;
 166          end loop;
 167       end Reset;
 168
 169       ---------
 170       -- Set --
 171       ---------
 172
 173       procedure Set (E : Elmt_Ptr) is
 174          Index : Header_Num;
 175
 176       begin
 177          Index := Hash (Get_Key (E));
 178          Set_Next (E, Table (Index));
 179          Table (Index) := E;
 180       end Set;
 181
 182    end Static_HTable;
 183
 184    --------------------
 185    --  Simple_HTable --
 186    --------------------
 187
 188    package body Simple_HTable is
 189
 190       type Element_Wrapper;
 191       type Elmt_Ptr is access all Element_Wrapper;
 192       type Element_Wrapper is record
 193          K    : Key;
 194          E    : Element;
 195          Next : Elmt_Ptr;
 196       end record;
 197
 198       procedure Free is new
 199         Ada.Unchecked_Deallocation (Element_Wrapper, Elmt_Ptr);
 200
 201       procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr);
 202       function  Next     (E : Elmt_Ptr) return Elmt_Ptr;
 203       function  Get_Key  (E : Elmt_Ptr) return Key;
 204
 205       package Tab is new Static_HTable (
 206         Header_Num => Header_Num,
 207         Element    => Element_Wrapper,
 208         Elmt_Ptr   => Elmt_Ptr,
 209         Null_Ptr   => null,
 210         Set_Next   => Set_Next,
 211         Next       => Next,
 212         Key        => Key,
 213         Get_Key    => Get_Key,
 214         Hash       => Hash,
 215         Equal      => Equal);
 216
 217       ---------
 218       -- Get --
 219       ---------
 220
 221       function  Get (K : Key) return Element is
 222          Tmp : constant Elmt_Ptr := Tab.Get (K);
 223
 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
 239       begin
 240          if Tmp = null then
 241             return No_Element;
 242          else
 243             return Tmp.E;
 244          end if;
 245       end Get_First;
 246
 247       -------------
 248       -- Get_Key --
 249       -------------
 250
 251       function Get_Key (E : Elmt_Ptr) return Key is
 252       begin
 253          return E.K;
 254       end Get_Key;
 255
 256       --------------
 257       -- Get_Next --
 258       --------------
 259
 260       function Get_Next return Element is
 261          Tmp : constant Elmt_Ptr := Tab.Get_Next;
 262
 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
 321       begin
 322          if Tmp = null then
 323             Tab.Set (new Element_Wrapper'(K, E, null));
 324          else
 325             Tmp.E := E;
 326          end if;
 327       end Set;
 328
 329       --------------
 330       -- Set_Next --
 331       --------------
 332
 333       procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr) is
 334       begin
 335          E.Next := Next;
 336       end Set_Next;
 337    end Simple_HTable;
 338
 339    ----------
 340    -- Hash --
 341    ----------
 342
 343    function Hash (Key : String) return Header_Num is
 344
 345       type Uns is mod 2 ** 32;
 346
 347       function Rotate_Left (Value : Uns; Amount : Natural) return Uns;
 348       pragma Import (Intrinsic, Rotate_Left);
 349
 350       Tmp : Uns := 0;
 351
 352    begin
 353       for J in Key'Range loop
 354          Tmp := Rotate_Left (Tmp, 1) + Character'Pos (Key (J));
 355       end loop;
 356
 357       return Header_Num'First +
 358                Header_Num'Base (Tmp mod Header_Num'Range_Length);
 359    end Hash;
 360
 361 end GNAT.HTable;