gcc/ada/g-dynhta.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --                 G N A T . D Y N A M I C _ H T A B L E S                  --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --                     Copyright (C) 2002-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 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 package body GNAT.Dynamic_HTables is
  33
  34    -------------------
  35    -- Static_HTable --
  36    -------------------
  37
  38    package body Static_HTable is
  39
  40       type Table_Type is array (Header_Num) of Elmt_Ptr;
  41
  42       type Instance_Data is record
  43          Table            : Table_Type;
  44          Iterator_Index   : Header_Num;
  45          Iterator_Ptr     : Elmt_Ptr;
  46          Iterator_Started : Boolean := False;
  47       end record;
  48
  49       function Get_Non_Null (T : Instance) return Elmt_Ptr;
  50       --  Returns Null_Ptr if Iterator_Started is False or if 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 (T : Instance; K : Key) return Elmt_Ptr is
  59          Elmt  : Elmt_Ptr;
  60
  61       begin
  62          if T = null then
  63             return Null_Ptr;
  64          end if;
  65
  66          Elmt := T.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 (T : Instance) return Elmt_Ptr is
  86       begin
  87          if T = null then
  88             return Null_Ptr;
  89          end if;
  90
  91          T.Iterator_Started := True;
  92          T.Iterator_Index := T.Table'First;
  93          T.Iterator_Ptr := T.Table (T.Iterator_Index);
  94          return Get_Non_Null (T);
  95       end Get_First;
  96
  97       --------------
  98       -- Get_Next --
  99       --------------
 100
 101       function Get_Next (T : Instance) return Elmt_Ptr is
 102       begin
 103          if T = null or else not T.Iterator_Started then
 104             return Null_Ptr;
 105          end if;
 106
 107          T.Iterator_Ptr := Next (T.Iterator_Ptr);
 108          return Get_Non_Null (T);
 109       end Get_Next;
 110
 111       ------------------
 112       -- Get_Non_Null --
 113       ------------------
 114
 115       function Get_Non_Null (T : Instance) return Elmt_Ptr is
 116       begin
 117          if T = null then
 118             return Null_Ptr;
 119          end if;
 120
 121          while T.Iterator_Ptr = Null_Ptr  loop
 122             if T.Iterator_Index = T.Table'Last then
 123                T.Iterator_Started := False;
 124                return Null_Ptr;
 125             end if;
 126
 127             T.Iterator_Index := T.Iterator_Index + 1;
 128             T.Iterator_Ptr   := T.Table (T.Iterator_Index);
 129          end loop;
 130
 131          return T.Iterator_Ptr;
 132       end Get_Non_Null;
 133
 134       ------------
 135       -- Remove --
 136       ------------
 137
 138       procedure Remove  (T : Instance; K : Key) is
 139          Index     : constant Header_Num := Hash (K);
 140          Elmt      : Elmt_Ptr;
 141          Next_Elmt : Elmt_Ptr;
 142
 143       begin
 144          if T = null then
 145             return;
 146          end if;
 147
 148          Elmt := T.Table (Index);
 149
 150          if Elmt = Null_Ptr then
 151             return;
 152
 153          elsif Equal (Get_Key (Elmt), K) then
 154             T.Table (Index) := Next (Elmt);
 155
 156          else
 157             loop
 158                Next_Elmt :=  Next (Elmt);
 159
 160                if Next_Elmt = Null_Ptr then
 161                   return;
 162
 163                elsif Equal (Get_Key (Next_Elmt), K) then
 164                   Set_Next (Elmt, Next (Next_Elmt));
 165                   return;
 166
 167                else
 168                   Elmt := Next_Elmt;
 169                end if;
 170             end loop;
 171          end if;
 172       end Remove;
 173
 174       -----------
 175       -- Reset --
 176       -----------
 177
 178       procedure Reset (T : in out Instance) is
 179          procedure Free is
 180            new Ada.Unchecked_Deallocation (Instance_Data, Instance);
 181
 182       begin
 183          if T = null then
 184             return;
 185          end if;
 186
 187          for J in T.Table'Range loop
 188             T.Table (J) := Null_Ptr;
 189          end loop;
 190
 191          Free (T);
 192       end Reset;
 193
 194       ---------
 195       -- Set --
 196       ---------
 197
 198       procedure Set (T : in out Instance; E : Elmt_Ptr) is
 199          Index : Header_Num;
 200
 201       begin
 202          if T = null then
 203             T := new Instance_Data;
 204          end if;
 205
 206          Index := Hash (Get_Key (E));
 207          Set_Next (E, T.Table (Index));
 208          T.Table (Index) := E;
 209       end Set;
 210
 211    end Static_HTable;
 212
 213    -------------------
 214    -- Simple_HTable --
 215    -------------------
 216
 217    package body Simple_HTable is
 218
 219       ---------
 220       -- Get --
 221       ---------
 222
 223       function  Get (T : Instance; K : Key) return Element is
 224          Tmp : Elmt_Ptr;
 225
 226       begin
 227          if T = Nil then
 228             return No_Element;
 229          end if;
 230
 231          Tmp := Tab.Get (Tab.Instance (T), K);
 232
 233          if Tmp = null then
 234             return No_Element;
 235          else
 236             return Tmp.E;
 237          end if;
 238       end Get;
 239
 240       ---------------
 241       -- Get_First --
 242       ---------------
 243
 244       function Get_First (T : Instance) return Element is
 245          Tmp : constant Elmt_Ptr := Tab.Get_First (Tab.Instance (T));
 246
 247       begin
 248          if Tmp = null then
 249             return No_Element;
 250          else
 251             return Tmp.E;
 252          end if;
 253       end Get_First;
 254
 255       -------------
 256       -- Get_Key --
 257       -------------
 258
 259       function Get_Key (E : Elmt_Ptr) return Key is
 260       begin
 261          return E.K;
 262       end Get_Key;
 263
 264       --------------
 265       -- Get_Next --
 266       --------------
 267
 268       function Get_Next (T : Instance) return Element is
 269          Tmp : constant Elmt_Ptr := Tab.Get_Next (Tab.Instance (T));
 270       begin
 271          if Tmp = null then
 272             return No_Element;
 273          else
 274             return Tmp.E;
 275          end if;
 276       end Get_Next;
 277
 278       ----------
 279       -- Next --
 280       ----------
 281
 282       function Next (E : Elmt_Ptr) return Elmt_Ptr is
 283       begin
 284          return E.Next;
 285       end Next;
 286
 287       ------------
 288       -- Remove --
 289       ------------
 290
 291       procedure Remove  (T : Instance; K : Key) is
 292          Tmp : Elmt_Ptr;
 293
 294       begin
 295          Tmp := Tab.Get (Tab.Instance (T), K);
 296
 297          if Tmp /= null then
 298             Tab.Remove (Tab.Instance (T), K);
 299             Free (Tmp);
 300          end if;
 301       end Remove;
 302
 303       -----------
 304       -- Reset --
 305       -----------
 306
 307       procedure Reset (T : in out Instance) is
 308          E1, E2 : Elmt_Ptr;
 309
 310       begin
 311          E1 := Tab.Get_First (Tab.Instance (T));
 312          while E1 /= null loop
 313             E2 := Tab.Get_Next (Tab.Instance (T));
 314             Free (E1);
 315             E1 := E2;
 316          end loop;
 317
 318          Tab.Reset (Tab.Instance (T));
 319       end Reset;
 320
 321       ---------
 322       -- Set --
 323       ---------
 324
 325       procedure Set (T : in out Instance; K : Key; E : Element) is
 326          Tmp : constant Elmt_Ptr := Tab.Get (Tab.Instance (T), K);
 327       begin
 328          if Tmp = null then
 329             Tab.Set (Tab.Instance (T), new Element_Wrapper'(K, E, null));
 330          else
 331             Tmp.E := E;
 332          end if;
 333       end Set;
 334
 335       --------------
 336       -- Set_Next --
 337       --------------
 338
 339       procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr) is
 340       begin
 341          E.Next := Next;
 342       end Set_Next;
 343
 344    end Simple_HTable;
 345
 346 end GNAT.Dynamic_HTables;