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