gcc/ada/g-table.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUNTIME COMPONENTS                          --
   4 --                                                                          --
   5 --                            G N A T .  T A B L E                          --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --                                                                          --
  10 --            Copyright (C) 1998-2001 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 System;        use System;
  35 with System.Memory; use System.Memory;
  36 with System.Address_To_Access_Conversions;
  37
  38 package body GNAT.Table is
  39
  40    Min : constant Integer := Integer (Table_Low_Bound);
  41    --  Subscript of the minimum entry in the currently allocated table
  42
  43    Max : Integer;
  44    --  Subscript of the maximum entry in the currently allocated table
  45
  46    Length : Integer := 0;
  47    --  Number of entries in currently allocated table. The value of zero
  48    --  ensures that we initially allocate the table.
  49
  50    Last_Val : Integer;
  51    --  Current value of Last.
  52
  53    -----------------------
  54    -- Local Subprograms --
  55    -----------------------
  56
  57    procedure Reallocate;
  58    --  Reallocate the existing table according to the current value stored
  59    --  in Max. Works correctly to do an initial allocation if the table
  60    --  is currently null.
  61
  62    package Table_Conversions is
  63       new System.Address_To_Access_Conversions (Big_Table_Type);
  64    --  Address and Access conversions for a Table object.
  65
  66    function To_Address (Table : Table_Ptr) return Address;
  67    pragma Inline (To_Address);
  68    --  Returns the Address for the Table object.
  69
  70    function To_Pointer (Table : Address) return Table_Ptr;
  71    pragma Inline (To_Pointer);
  72    --  Returns the Access pointer for the Table object.
  73
  74    --------------
  75    -- Allocate --
  76    --------------
  77
  78    function Allocate (Num : Integer := 1) return Table_Index_Type is
  79       Old_Last : constant Integer := Last_Val;
  80
  81    begin
  82       Last_Val := Last_Val + Num;
  83
  84       if Last_Val > Max then
  85          Reallocate;
  86       end if;
  87
  88       return Table_Index_Type (Old_Last + 1);
  89    end Allocate;
  90
  91    ------------
  92    -- Append --
  93    ------------
  94
  95    procedure Append (New_Val : Table_Component_Type) is
  96    begin
  97       Increment_Last;
  98       Table (Table_Index_Type (Last_Val)) := New_Val;
  99    end Append;
 100
 101    --------------------
 102    -- Decrement_Last --
 103    --------------------
 104
 105    procedure Decrement_Last is
 106    begin
 107       Last_Val := Last_Val - 1;
 108    end Decrement_Last;
 109
 110    ----------
 111    -- Free --
 112    ----------
 113
 114    procedure Free is
 115    begin
 116       Free (To_Address (Table));
 117       Table := null;
 118       Length := 0;
 119    end Free;
 120
 121    --------------------
 122    -- Increment_Last --
 123    --------------------
 124
 125    procedure Increment_Last is
 126    begin
 127       Last_Val := Last_Val + 1;
 128
 129       if Last_Val > Max then
 130          Reallocate;
 131       end if;
 132    end Increment_Last;
 133
 134    ----------
 135    -- Init --
 136    ----------
 137
 138    procedure Init is
 139       Old_Length : Integer := Length;
 140
 141    begin
 142       Last_Val := Min - 1;
 143       Max      := Min + Table_Initial - 1;
 144       Length   := Max - Min + 1;
 145
 146       --  If table is same size as before (happens when table is never
 147       --  expanded which is a common case), then simply reuse it. Note
 148       --  that this also means that an explicit Init call right after
 149       --  the implicit one in the package body is harmless.
 150
 151       if Old_Length = Length then
 152          return;
 153
 154       --  Otherwise we can use Reallocate to get a table of the right size.
 155       --  Note that Reallocate works fine to allocate a table of the right
 156       --  initial size when it is first allocated.
 157
 158       else
 159          Reallocate;
 160       end if;
 161    end Init;
 162
 163    ----------
 164    -- Last --
 165    ----------
 166
 167    function Last return Table_Index_Type is
 168    begin
 169       return Table_Index_Type (Last_Val);
 170    end Last;
 171
 172    ----------------
 173    -- Reallocate --
 174    ----------------
 175
 176    procedure Reallocate is
 177       New_Size : size_t;
 178
 179    begin
 180       if Max < Last_Val then
 181          pragma Assert (not Locked);
 182
 183          while Max < Last_Val loop
 184
 185             --  Increase length using the table increment factor, but make
 186             --  sure that we add at least ten elements (this avoids a loop
 187             --  for silly small increment values)
 188
 189             Length := Integer'Max
 190                         (Length * (100 + Table_Increment) / 100,
 191                          Length + 10);
 192             Max := Min + Length - 1;
 193          end loop;
 194       end if;
 195
 196       New_Size :=
 197         size_t ((Max - Min + 1) *
 198                 (Table_Type'Component_Size / Storage_Unit));
 199
 200       if Table = null then
 201          Table := To_Pointer (Alloc (New_Size));
 202
 203       elsif New_Size > 0 then
 204          Table :=
 205            To_Pointer (Realloc (Ptr  => To_Address (Table),
 206                                 Size => New_Size));
 207       end if;
 208
 209       if Length /= 0 and then Table = null then
 210          raise Storage_Error;
 211       end if;
 212
 213    end Reallocate;
 214
 215    -------------
 216    -- Release --
 217    -------------
 218
 219    procedure Release is
 220    begin
 221       Length := Last_Val - Integer (Table_Low_Bound) + 1;
 222       Max    := Last_Val;
 223       Reallocate;
 224    end Release;
 225
 226    --------------
 227    -- Set_Item --
 228    --------------
 229
 230    procedure Set_Item
 231      (Index : Table_Index_Type;
 232       Item  : Table_Component_Type)
 233    is
 234    begin
 235       if Integer (Index) > Max then
 236          Set_Last (Index);
 237       end if;
 238
 239       Table (Index) := Item;
 240    end Set_Item;
 241
 242    --------------
 243    -- Set_Last --
 244    --------------
 245
 246    procedure Set_Last (New_Val : Table_Index_Type) is
 247    begin
 248       if Integer (New_Val) < Last_Val then
 249          Last_Val := Integer (New_Val);
 250       else
 251          Last_Val := Integer (New_Val);
 252
 253          if Last_Val > Max then
 254             Reallocate;
 255          end if;
 256       end if;
 257    end Set_Last;
 258
 259    ----------------
 260    -- To_Address --
 261    ----------------
 262
 263    function To_Address (Table : Table_Ptr) return Address is
 264    begin
 265       return Table_Conversions.To_Address
 266         (Table_Conversions.Object_Pointer (Table));
 267    end To_Address;
 268
 269    ----------------
 270    -- To_Pointer --
 271    ----------------
 272
 273    function To_Pointer (Table : Address) return Table_Ptr is
 274    begin
 275       return Table_Ptr (Table_Conversions.To_Pointer (Table));
 276    end To_Pointer;
 277
 278 begin
 279    Init;
 280 end GNAT.Table;