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-2013, 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 3,  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.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- GNAT was originally developed  by the GNAT team at  New York University. --
  28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 pragma Compiler_Unit_Warning;
  33
  34 with Ada.Unchecked_Deallocation;
  35 with System.String_Hash;
  36
  37 package body System.HTable is
  38
  39    -------------------
  40    -- Static_HTable --
  41    -------------------
  42
  43    package body Static_HTable is
  44
  45       Table : array (Header_Num) of Elmt_Ptr;
  46
  47       Iterator_Index   : Header_Num;
  48       Iterator_Ptr     : Elmt_Ptr;
  49       Iterator_Started : Boolean := False;
  50
  51       function Get_Non_Null return Elmt_Ptr;
  52       --  Returns Null_Ptr if Iterator_Started is false or the Table is empty.
  53       --  Returns Iterator_Ptr if non null, or the next non null element in
  54       --  table if any.
  55
  56       ---------
  57       -- Get --
  58       ---------
  59
  60       function Get (K : Key) return Elmt_Ptr is
  61          Elmt : Elmt_Ptr;
  62
  63       begin
  64          Elmt := Table (Hash (K));
  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          else
  99             Iterator_Ptr := Next (Iterator_Ptr);
 100             return Get_Non_Null;
 101          end if;
 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       -- Present --
 125       -------------
 126
 127       function Present (K : Key) return Boolean is
 128       begin
 129          return Get (K) /= Null_Ptr;
 130       end Present;
 131
 132       ------------
 133       -- Remove --
 134       ------------
 135
 136       procedure Remove  (K : Key) is
 137          Index     : constant Header_Num := Hash (K);
 138          Elmt      : Elmt_Ptr;
 139          Next_Elmt : Elmt_Ptr;
 140
 141       begin
 142          Elmt := Table (Index);
 143
 144          if Elmt = Null_Ptr then
 145             return;
 146
 147          elsif Equal (Get_Key (Elmt), K) then
 148             Table (Index) := Next (Elmt);
 149
 150          else
 151             loop
 152                Next_Elmt :=  Next (Elmt);
 153
 154                if Next_Elmt = Null_Ptr then
 155                   return;
 156
 157                elsif Equal (Get_Key (Next_Elmt), K) then
 158                   Set_Next (Elmt, Next (Next_Elmt));
 159                   return;
 160
 161                else
 162                   Elmt := Next_Elmt;
 163                end if;
 164             end loop;
 165          end if;
 166       end Remove;
 167
 168       -----------
 169       -- Reset --
 170       -----------
 171
 172       procedure Reset is
 173       begin
 174          for J in Table'Range loop
 175             Table (J) := Null_Ptr;
 176          end loop;
 177       end Reset;
 178
 179       ---------
 180       -- Set --
 181       ---------
 182
 183       procedure Set (E : Elmt_Ptr) is
 184          Index : Header_Num;
 185       begin
 186          Index := Hash (Get_Key (E));
 187          Set_Next (E, Table (Index));
 188          Table (Index) := E;
 189       end Set;
 190
 191       ------------------------
 192       -- Set_If_Not_Present --
 193       ------------------------
 194
 195       function Set_If_Not_Present (E : Elmt_Ptr) return Boolean is
 196          K : Key renames Get_Key (E);
 197          --  Note that it is important to use a renaming here rather than
 198          --  define a constant initialized by the call, because the latter
 199          --  construct runs into bootstrap problems with earlier versions
 200          --  of the GNAT compiler.
 201
 202          Index : constant Header_Num := Hash (K);
 203          Elmt  : Elmt_Ptr;
 204
 205       begin
 206          Elmt := Table (Index);
 207          loop
 208             if Elmt = Null_Ptr then
 209                Set_Next (E, Table (Index));
 210                Table (Index) := E;
 211                return True;
 212
 213             elsif Equal (Get_Key (Elmt), K) then
 214                return False;
 215
 216             else
 217                Elmt := Next (Elmt);
 218             end if;
 219          end loop;
 220       end Set_If_Not_Present;
 221
 222    end Static_HTable;
 223
 224    -------------------
 225    -- Simple_HTable --
 226    -------------------
 227
 228    package body Simple_HTable is
 229
 230       type Element_Wrapper;
 231       type Elmt_Ptr is access all Element_Wrapper;
 232       type Element_Wrapper is record
 233          K    : Key;
 234          E    : Element;
 235          Next : Elmt_Ptr;
 236       end record;
 237
 238       procedure Free is new
 239         Ada.Unchecked_Deallocation (Element_Wrapper, Elmt_Ptr);
 240
 241       procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr);
 242       function  Next     (E : Elmt_Ptr) return Elmt_Ptr;
 243       function  Get_Key  (E : Elmt_Ptr) return Key;
 244
 245       package Tab is new Static_HTable (
 246         Header_Num => Header_Num,
 247         Element    => Element_Wrapper,
 248         Elmt_Ptr   => Elmt_Ptr,
 249         Null_Ptr   => null,
 250         Set_Next   => Set_Next,
 251         Next       => Next,
 252         Key        => Key,
 253         Get_Key    => Get_Key,
 254         Hash       => Hash,
 255         Equal      => Equal);
 256
 257       ---------
 258       -- Get --
 259       ---------
 260
 261       function  Get (K : Key) return Element is
 262          Tmp : constant Elmt_Ptr := Tab.Get (K);
 263       begin
 264          if Tmp = null then
 265             return No_Element;
 266          else
 267             return Tmp.E;
 268          end if;
 269       end Get;
 270
 271       ---------------
 272       -- Get_First --
 273       ---------------
 274
 275       function Get_First return Element is
 276          Tmp : constant Elmt_Ptr := Tab.Get_First;
 277       begin
 278          if Tmp = null then
 279             return No_Element;
 280          else
 281             return Tmp.E;
 282          end if;
 283       end Get_First;
 284
 285       procedure Get_First (K : in out Key; E : out Element) is
 286          Tmp : constant Elmt_Ptr := Tab.Get_First;
 287       begin
 288          if Tmp = null then
 289             E := No_Element;
 290          else
 291             K := Tmp.K;
 292             E := Tmp.E;
 293          end if;
 294       end Get_First;
 295
 296       -------------
 297       -- Get_Key --
 298       -------------
 299
 300       function Get_Key (E : Elmt_Ptr) return Key is
 301       begin
 302          return E.K;
 303       end Get_Key;
 304
 305       --------------
 306       -- Get_Next --
 307       --------------
 308
 309       function Get_Next return Element is
 310          Tmp : constant Elmt_Ptr := Tab.Get_Next;
 311       begin
 312          if Tmp = null then
 313             return No_Element;
 314          else
 315             return Tmp.E;
 316          end if;
 317       end Get_Next;
 318
 319       procedure Get_Next (K : in out Key; E : out Element) is
 320          Tmp : constant Elmt_Ptr := Tab.Get_Next;
 321       begin
 322          if Tmp = null then
 323             E := No_Element;
 324          else
 325             K := Tmp.K;
 326             E := Tmp.E;
 327          end if;
 328       end Get_Next;
 329
 330       ----------
 331       -- Next --
 332       ----------
 333
 334       function Next (E : Elmt_Ptr) return Elmt_Ptr is
 335       begin
 336          return E.Next;
 337       end Next;
 338
 339       ------------
 340       -- Remove --
 341       ------------
 342
 343       procedure Remove  (K : Key) is
 344          Tmp : Elmt_Ptr;
 345
 346       begin
 347          Tmp := Tab.Get (K);
 348
 349          if Tmp /= null then
 350             Tab.Remove (K);
 351             Free (Tmp);
 352          end if;
 353       end Remove;
 354
 355       -----------
 356       -- Reset --
 357       -----------
 358
 359       procedure Reset is
 360          E1, E2 : Elmt_Ptr;
 361
 362       begin
 363          E1 := Tab.Get_First;
 364          while E1 /= null loop
 365             E2 := Tab.Get_Next;
 366             Free (E1);
 367             E1 := E2;
 368          end loop;
 369
 370          Tab.Reset;
 371       end Reset;
 372
 373       ---------
 374       -- Set --
 375       ---------
 376
 377       procedure Set (K : Key; E : Element) is
 378          Tmp : constant Elmt_Ptr := Tab.Get (K);
 379       begin
 380          if Tmp = null then
 381             Tab.Set (new Element_Wrapper'(K, E, null));
 382          else
 383             Tmp.E := E;
 384          end if;
 385       end Set;
 386
 387       --------------
 388       -- Set_Next --
 389       --------------
 390
 391       procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr) is
 392       begin
 393          E.Next := Next;
 394       end Set_Next;
 395    end Simple_HTable;
 396
 397    ----------
 398    -- Hash --
 399    ----------
 400
 401    function Hash (Key : String) return Header_Num is
 402       type Uns is mod 2 ** 32;
 403
 404       function Hash_Fun is
 405          new System.String_Hash.Hash (Character, String, Uns);
 406
 407    begin
 408       return Header_Num'First +
 409         Header_Num'Base (Hash_Fun (Key) mod Header_Num'Range_Length);
 410    end Hash;
 411
 412 end System.HTable;