gcc/ada/g-table.adb

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