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