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 --            Copyright (C) 1998-2002 Ada Core Technologies, Inc.           --
  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,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com).   --
  30 --                                                                          --
  31 ------------------------------------------------------------------------------
  32
  33 with System;        use System;
  34 with System.Memory; use System.Memory;
  35
  36 with Unchecked_Conversion;
  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    function To_Address is new Unchecked_Conversion (Table_Ptr, Address);
  63    function To_Pointer is new Unchecked_Conversion (Address, Table_Ptr);
  64
  65    --------------
  66    -- Allocate --
  67    --------------
  68
  69    function Allocate (Num : Integer := 1) return Table_Index_Type is
  70       Old_Last : constant Integer := Last_Val;
  71
  72    begin
  73       Last_Val := Last_Val + Num;
  74
  75       if Last_Val > Max then
  76          Reallocate;
  77       end if;
  78
  79       return Table_Index_Type (Old_Last + 1);
  80    end Allocate;
  81
  82    ------------
  83    -- Append --
  84    ------------
  85
  86    procedure Append (New_Val : Table_Component_Type) is
  87    begin
  88       Increment_Last;
  89       Table (Table_Index_Type (Last_Val)) := New_Val;
  90    end Append;
  91
  92    --------------------
  93    -- Decrement_Last --
  94    --------------------
  95
  96    procedure Decrement_Last is
  97    begin
  98       Last_Val := Last_Val - 1;
  99    end Decrement_Last;
 100
 101    ----------
 102    -- Free --
 103    ----------
 104
 105    procedure Free is
 106    begin
 107       Free (To_Address (Table));
 108       Table := null;
 109       Length := 0;
 110    end Free;
 111
 112    --------------------
 113    -- Increment_Last --
 114    --------------------
 115
 116    procedure Increment_Last is
 117    begin
 118       Last_Val := Last_Val + 1;
 119
 120       if Last_Val > Max then
 121          Reallocate;
 122       end if;
 123    end Increment_Last;
 124
 125    ----------
 126    -- Init --
 127    ----------
 128
 129    procedure Init is
 130       Old_Length : constant Integer := Length;
 131
 132    begin
 133       Last_Val := Min - 1;
 134       Max      := Min + Table_Initial - 1;
 135       Length   := Max - Min + 1;
 136
 137       --  If table is same size as before (happens when table is never
 138       --  expanded which is a common case), then simply reuse it. Note
 139       --  that this also means that an explicit Init call right after
 140       --  the implicit one in the package body is harmless.
 141
 142       if Old_Length = Length then
 143          return;
 144
 145       --  Otherwise we can use Reallocate to get a table of the right size.
 146       --  Note that Reallocate works fine to allocate a table of the right
 147       --  initial size when it is first allocated.
 148
 149       else
 150          Reallocate;
 151       end if;
 152    end Init;
 153
 154    ----------
 155    -- Last --
 156    ----------
 157
 158    function Last return Table_Index_Type is
 159    begin
 160       return Table_Index_Type (Last_Val);
 161    end Last;
 162
 163    ----------------
 164    -- Reallocate --
 165    ----------------
 166
 167    procedure Reallocate is
 168       New_Size : size_t;
 169
 170    begin
 171       if Max < Last_Val then
 172          pragma Assert (not Locked);
 173
 174          while Max < Last_Val loop
 175
 176             --  Increase length using the table increment factor, but make
 177             --  sure that we add at least ten elements (this avoids a loop
 178             --  for silly small increment values)
 179
 180             Length := Integer'Max
 181                         (Length * (100 + Table_Increment) / 100,
 182                          Length + 10);
 183             Max := Min + Length - 1;
 184          end loop;
 185       end if;
 186
 187       New_Size :=
 188         size_t ((Max - Min + 1) *
 189                 (Table_Type'Component_Size / Storage_Unit));
 190
 191       if Table = null then
 192          Table := To_Pointer (Alloc (New_Size));
 193
 194       elsif New_Size > 0 then
 195          Table :=
 196            To_Pointer (Realloc (Ptr  => To_Address (Table),
 197                                 Size => New_Size));
 198       end if;
 199
 200       if Length /= 0 and then Table = null then
 201          raise Storage_Error;
 202       end if;
 203
 204    end Reallocate;
 205
 206    -------------
 207    -- Release --
 208    -------------
 209
 210    procedure Release is
 211    begin
 212       Length := Last_Val - Integer (Table_Low_Bound) + 1;
 213       Max    := Last_Val;
 214       Reallocate;
 215    end Release;
 216
 217    --------------
 218    -- Set_Item --
 219    --------------
 220
 221    procedure Set_Item
 222      (Index : Table_Index_Type;
 223       Item  : Table_Component_Type)
 224    is
 225    begin
 226       if Integer (Index) > Max then
 227          Set_Last (Index);
 228       end if;
 229
 230       Table (Index) := Item;
 231    end Set_Item;
 232
 233    --------------
 234    -- Set_Last --
 235    --------------
 236
 237    procedure Set_Last (New_Val : Table_Index_Type) is
 238    begin
 239       if Integer (New_Val) < Last_Val then
 240          Last_Val := Integer (New_Val);
 241       else
 242          Last_Val := Integer (New_Val);
 243
 244          if Last_Val > Max then
 245             Reallocate;
 246          end if;
 247       end if;
 248    end Set_Last;
 249
 250 begin
 251    Init;
 252 end GNAT.Table;