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