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-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 with System;        use System;
  33 with System.Memory; use System.Memory;
  34
  35 with Ada.Unchecked_Conversion;
  36
  37 package body GNAT.Table is
  38
  39    Min : constant Integer := Integer (Table_Low_Bound);
  40    --  Subscript of the minimum entry in the currently allocated table
  41
  42    Max : Integer;
  43    --  Subscript of the maximum entry in the currently allocated table
  44
  45    Length : Integer := 0;
  46    --  Number of entries in currently allocated table. The value of zero
  47    --  ensures that we initially allocate the table.
  48
  49    Last_Val : Integer;
  50    --  Current value of Last
  51
  52    -----------------------
  53    -- Local Subprograms --
  54    -----------------------
  55
  56    procedure Reallocate;
  57    --  Reallocate the existing table according to the current value stored
  58    --  in Max. Works correctly to do an initial allocation if the table
  59    --  is currently null.
  60
  61    pragma Warnings (Off);
  62    --  Turn off warnings. The following unchecked conversions are only used
  63    --  internally in this package, and cannot never result in any instances
  64    --  of improperly aliased pointers for the client of the package.
  65
  66    function To_Address is new Ada.Unchecked_Conversion (Table_Ptr, Address);
  67    function To_Pointer is new Ada.Unchecked_Conversion (Address, Table_Ptr);
  68
  69    pragma Warnings (On);
  70
  71    --------------
  72    -- Allocate --
  73    --------------
  74
  75    function Allocate (Num : Integer := 1) return Table_Index_Type is
  76       Old_Last : constant Integer := Last_Val;
  77
  78    begin
  79       Last_Val := Last_Val + Num;
  80
  81       if Last_Val > Max then
  82          Reallocate;
  83       end if;
  84
  85       return Table_Index_Type (Old_Last + 1);
  86    end Allocate;
  87
  88    ------------
  89    -- Append --
  90    ------------
  91
  92    procedure Append (New_Val : Table_Component_Type) is
  93    begin
  94       Set_Item (Table_Index_Type (Last_Val + 1), New_Val);
  95    end Append;
  96
  97    ----------------
  98    -- Append_All --
  99    ----------------
 100
 101    procedure Append_All (New_Vals : Table_Type) is
 102    begin
 103       for J in New_Vals'Range loop
 104          Append (New_Vals (J));
 105       end loop;
 106    end Append_All;
 107
 108    --------------------
 109    -- Decrement_Last --
 110    --------------------
 111
 112    procedure Decrement_Last is
 113    begin
 114       Last_Val := Last_Val - 1;
 115    end Decrement_Last;
 116
 117    ----------
 118    -- Free --
 119    ----------
 120
 121    procedure Free is
 122    begin
 123       Free (To_Address (Table));
 124       Table := null;
 125       Length := 0;
 126    end Free;
 127
 128    --------------------
 129    -- Increment_Last --
 130    --------------------
 131
 132    procedure Increment_Last is
 133    begin
 134       Last_Val := Last_Val + 1;
 135
 136       if Last_Val > Max then
 137          Reallocate;
 138       end if;
 139    end Increment_Last;
 140
 141    ----------
 142    -- Init --
 143    ----------
 144
 145    procedure Init is
 146       Old_Length : constant Integer := Length;
 147
 148    begin
 149       Last_Val := Min - 1;
 150       Max      := Min + Table_Initial - 1;
 151       Length   := Max - Min + 1;
 152
 153       --  If table is same size as before (happens when table is never
 154       --  expanded which is a common case), then simply reuse it. Note
 155       --  that this also means that an explicit Init call right after
 156       --  the implicit one in the package body is harmless.
 157
 158       if Old_Length = Length then
 159          return;
 160
 161       --  Otherwise we can use Reallocate to get a table of the right size.
 162       --  Note that Reallocate works fine to allocate a table of the right
 163       --  initial size when it is first allocated.
 164
 165       else
 166          Reallocate;
 167       end if;
 168    end Init;
 169
 170    ----------
 171    -- Last --
 172    ----------
 173
 174    function Last return Table_Index_Type is
 175    begin
 176       return Table_Index_Type (Last_Val);
 177    end Last;
 178
 179    ----------------
 180    -- Reallocate --
 181    ----------------
 182
 183    procedure Reallocate is
 184       New_Size : size_t;
 185
 186    begin
 187       if Max < Last_Val then
 188          pragma Assert (not Locked);
 189
 190          while Max < Last_Val loop
 191
 192             --  Increase length using the table increment factor, but make
 193             --  sure that we add at least ten elements (this avoids a loop
 194             --  for silly small increment values)
 195
 196             Length := Integer'Max
 197                         (Length * (100 + Table_Increment) / 100,
 198                          Length + 10);
 199             Max := Min + Length - 1;
 200          end loop;
 201       end if;
 202
 203       New_Size :=
 204         size_t ((Max - Min + 1) *
 205                 (Table_Type'Component_Size / Storage_Unit));
 206
 207       if Table = null then
 208          Table := To_Pointer (Alloc (New_Size));
 209
 210       elsif New_Size > 0 then
 211          Table :=
 212            To_Pointer (Realloc (Ptr  => To_Address (Table),
 213                                 Size => New_Size));
 214       end if;
 215
 216       if Length /= 0 and then Table = null then
 217          raise Storage_Error;
 218       end if;
 219
 220    end Reallocate;
 221
 222    -------------
 223    -- Release --
 224    -------------
 225
 226    procedure Release is
 227    begin
 228       Length := Last_Val - Integer (Table_Low_Bound) + 1;
 229       Max    := Last_Val;
 230       Reallocate;
 231    end Release;
 232
 233    --------------
 234    -- Set_Item --
 235    --------------
 236
 237    procedure Set_Item
 238       (Index : Table_Index_Type;
 239        Item  : Table_Component_Type)
 240    is
 241       --  If Item is a value within the current allocation, and we are going to
 242       --  reallocate, then we must preserve an intermediate copy here before
 243       --  calling Increment_Last. Otherwise, if Table_Component_Type is passed
 244       --  by reference, we are going to end up copying from storage that might
 245       --  have been deallocated from Increment_Last calling Reallocate.
 246
 247       subtype Allocated_Table_T is
 248         Table_Type (Table'First .. Table_Index_Type (Max + 1));
 249       --  A constrained table subtype one element larger than the currently
 250       --  allocated table.
 251
 252       Allocated_Table_Address : constant System.Address :=
 253                                   Table.all'Address;
 254       --  Used for address clause below (we can't use non-static expression
 255       --  Table.all'Address directly in the clause because some older versions
 256       --  of the compiler do not allow it).
 257
 258       Allocated_Table : Allocated_Table_T;
 259       pragma Import (Ada, Allocated_Table);
 260       pragma Suppress (Range_Check, On => Allocated_Table);
 261       for Allocated_Table'Address use Allocated_Table_Address;
 262       --  Allocated_Table represents the currently allocated array, plus
 263       --  one element (the supplementary element is used to have a
 264       --  convenient way of computing the address just past the end of the
 265       --  current allocation). Range checks are suppressed because this unit
 266       --  uses direct calls to System.Memory for allocation, and this can
 267       --  yield misaligned storage (and we cannot rely on the bootstrap
 268       --  compiler supporting specifically disabling alignment checks, so we
 269       --  need to suppress all range checks). It is safe to suppress this check
 270       --  here because we know that a (possibly misaligned) object of that type
 271       --  does actually exist at that address.
 272       --  ??? We should really improve the allocation circuitry here to
 273       --  guarantee proper alignment.
 274
 275       Need_Realloc : constant Boolean := Integer (Index) > Max;
 276       --  True if this operation requires storage reallocation (which may
 277       --  involve moving table contents around).
 278
 279    begin
 280       --  If we're going to reallocate, check whether Item references an
 281       --  element of the currently allocated table.
 282
 283       if Need_Realloc
 284         and then Allocated_Table'Address <= Item'Address
 285         and then Item'Address <
 286                    Allocated_Table (Table_Index_Type (Max + 1))'Address
 287       then
 288          --  If so, save a copy on the stack because Increment_Last will
 289          --  reallocate storage and might deallocate the current table.
 290
 291          declare
 292             Item_Copy : constant Table_Component_Type := Item;
 293          begin
 294             Set_Last (Index);
 295             Table (Index) := Item_Copy;
 296          end;
 297
 298       else
 299          --  Here we know that either we won't reallocate (case of Index < Max)
 300          --  or that Item is not in the currently allocated table.
 301
 302          if Integer (Index) > Last_Val then
 303             Set_Last (Index);
 304          end if;
 305
 306          Table (Index) := Item;
 307       end if;
 308    end Set_Item;
 309
 310    --------------
 311    -- Set_Last --
 312    --------------
 313
 314    procedure Set_Last (New_Val : Table_Index_Type) is
 315    begin
 316       if Integer (New_Val) < Last_Val then
 317          Last_Val := Integer (New_Val);
 318       else
 319          Last_Val := Integer (New_Val);
 320
 321          if Last_Val > Max then
 322             Reallocate;
 323          end if;
 324       end if;
 325    end Set_Last;
 326
 327 begin
 328    Init;
 329 end GNAT.Table;