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-2014, 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 GNAT.Heap_Sort_G;
  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    -- For_Each --
 121    --------------
 122
 123    procedure For_Each is
 124       Quit : Boolean := False;
 125    begin
 126       for Index in Table_Low_Bound .. Table_Index_Type (Last_Val) loop
 127          Action (Index, Table (Index), Quit);
 128          exit when Quit;
 129       end loop;
 130    end For_Each;
 131
 132    ----------
 133    -- Free --
 134    ----------
 135
 136    procedure Free is
 137    begin
 138       Free (To_Address (Table));
 139       Table := null;
 140       Length := 0;
 141    end Free;
 142
 143    --------------------
 144    -- Increment_Last --
 145    --------------------
 146
 147    procedure Increment_Last is
 148    begin
 149       Last_Val := Last_Val + 1;
 150
 151       if Last_Val > Max then
 152          Reallocate;
 153       end if;
 154    end Increment_Last;
 155
 156    ----------
 157    -- Init --
 158    ----------
 159
 160    procedure Init is
 161       Old_Length : constant Integer := Length;
 162
 163    begin
 164       Last_Val := Min - 1;
 165       Max      := Min + Table_Initial - 1;
 166       Length   := Max - Min + 1;
 167
 168       --  If table is same size as before (happens when table is never
 169       --  expanded which is a common case), then simply reuse it. Note
 170       --  that this also means that an explicit Init call right after
 171       --  the implicit one in the package body is harmless.
 172
 173       if Old_Length = Length then
 174          return;
 175
 176       --  Otherwise we can use Reallocate to get a table of the right size.
 177       --  Note that Reallocate works fine to allocate a table of the right
 178       --  initial size when it is first allocated.
 179
 180       else
 181          Reallocate;
 182       end if;
 183    end Init;
 184
 185    ----------
 186    -- Last --
 187    ----------
 188
 189    function Last return Table_Index_Type is
 190    begin
 191       return Table_Index_Type (Last_Val);
 192    end Last;
 193
 194    ----------------
 195    -- Reallocate --
 196    ----------------
 197
 198    procedure Reallocate is
 199       New_Size   : size_t;
 200       New_Length : Long_Long_Integer;
 201
 202    begin
 203       if Max < Last_Val then
 204          pragma Assert (not Locked);
 205
 206          --  Now increment table length until it is sufficiently large. Use
 207          --  the increment value or 10, which ever is larger (the reason
 208          --  for the use of 10 here is to ensure that the table does really
 209          --  increase in size (which would not be the case for a table of
 210          --  length 10 increased by 3% for instance). Do the intermediate
 211          --  calculation in Long_Long_Integer to avoid overflow.
 212
 213          while Max < Last_Val loop
 214             New_Length :=
 215               Long_Long_Integer (Length) *
 216                 (100 + Long_Long_Integer (Table_Increment)) / 100;
 217             Length := Integer'Max (Integer (New_Length), Length + 10);
 218             Max := Min + Length - 1;
 219          end loop;
 220       end if;
 221
 222       New_Size :=
 223         size_t ((Max - Min + 1) *
 224                 (Table_Type'Component_Size / Storage_Unit));
 225
 226       if Table = null then
 227          Table := To_Pointer (Alloc (New_Size));
 228
 229       elsif New_Size > 0 then
 230          Table :=
 231            To_Pointer (Realloc (Ptr  => To_Address (Table),
 232                                 Size => New_Size));
 233       end if;
 234
 235       if Length /= 0 and then Table = null then
 236          raise Storage_Error;
 237       end if;
 238
 239    end Reallocate;
 240
 241    -------------
 242    -- Release --
 243    -------------
 244
 245    procedure Release is
 246    begin
 247       Length := Last_Val - Integer (Table_Low_Bound) + 1;
 248       Max    := Last_Val;
 249       Reallocate;
 250    end Release;
 251
 252    --------------
 253    -- Set_Item --
 254    --------------
 255
 256    procedure Set_Item
 257       (Index : Table_Index_Type;
 258        Item  : Table_Component_Type)
 259    is
 260       --  If Item is a value within the current allocation, and we are going to
 261       --  reallocate, then we must preserve an intermediate copy here before
 262       --  calling Increment_Last. Otherwise, if Table_Component_Type is passed
 263       --  by reference, we are going to end up copying from storage that might
 264       --  have been deallocated from Increment_Last calling Reallocate.
 265
 266       subtype Allocated_Table_T is
 267         Table_Type (Table'First .. Table_Index_Type (Max + 1));
 268       --  A constrained table subtype one element larger than the currently
 269       --  allocated table.
 270
 271       Allocated_Table_Address : constant System.Address :=
 272                                   Table.all'Address;
 273       --  Used for address clause below (we can't use non-static expression
 274       --  Table.all'Address directly in the clause because some older versions
 275       --  of the compiler do not allow it).
 276
 277       Allocated_Table : Allocated_Table_T;
 278       pragma Import (Ada, Allocated_Table);
 279       pragma Suppress (Range_Check, On => Allocated_Table);
 280       for Allocated_Table'Address use Allocated_Table_Address;
 281       --  Allocated_Table represents the currently allocated array, plus one
 282       --  element (the supplementary element is used to have a convenient
 283       --  way of computing the address just past the end of the current
 284       --  allocation). Range checks are suppressed because this unit uses
 285       --  direct calls to System.Memory for allocation, and this can yield
 286       --  misaligned storage (and we cannot rely on the bootstrap compiler
 287       --  supporting specifically disabling alignment checks, so we need to
 288       --  suppress all range checks). It is safe to suppress this check here
 289       --  because we know that a (possibly misaligned) object of that type
 290       --  does actually exist at that address. ??? We should really improve
 291       --  the allocation circuitry here to
 292       --  guarantee proper alignment.
 293
 294       Need_Realloc : constant Boolean := Integer (Index) > Max;
 295       --  True if this operation requires storage reallocation (which may
 296       --  involve moving table contents around).
 297
 298    begin
 299       --  If we're going to reallocate, check whether Item references an
 300       --  element of the currently allocated table.
 301
 302       if Need_Realloc
 303         and then Allocated_Table'Address <= Item'Address
 304         and then Item'Address <
 305                    Allocated_Table (Table_Index_Type (Max + 1))'Address
 306       then
 307          --  If so, save a copy on the stack because Increment_Last will
 308          --  reallocate storage and might deallocate the current table.
 309
 310          declare
 311             Item_Copy : constant Table_Component_Type := Item;
 312          begin
 313             Set_Last (Index);
 314             Table (Index) := Item_Copy;
 315          end;
 316
 317       else
 318          --  Here we know that either we won't reallocate (case of Index < Max)
 319          --  or that Item is not in the currently allocated table.
 320
 321          if Integer (Index) > Last_Val then
 322             Set_Last (Index);
 323          end if;
 324
 325          Table (Index) := Item;
 326       end if;
 327    end Set_Item;
 328
 329    --------------
 330    -- Set_Last --
 331    --------------
 332
 333    procedure Set_Last (New_Val : Table_Index_Type) is
 334    begin
 335       if Integer (New_Val) < Last_Val then
 336          Last_Val := Integer (New_Val);
 337       else
 338          Last_Val := Integer (New_Val);
 339
 340          if Last_Val > Max then
 341             Reallocate;
 342          end if;
 343       end if;
 344    end Set_Last;
 345
 346    ----------------
 347    -- Sort_Table --
 348    ----------------
 349
 350    procedure Sort_Table is
 351
 352       Temp : Table_Component_Type;
 353       --  A temporary position to simulate index 0
 354
 355       --  Local subprograms
 356
 357       function Index_Of (Idx : Natural) return Table_Index_Type;
 358       --  Return index of Idx'th element of table
 359
 360       function Lower_Than (Op1, Op2 : Natural) return Boolean;
 361       --  Compare two components
 362
 363       procedure Move (From : Natural; To : Natural);
 364       --  Move one component
 365
 366       package Heap_Sort is new GNAT.Heap_Sort_G (Move, Lower_Than);
 367
 368       --------------
 369       -- Index_Of --
 370       --------------
 371
 372       function Index_Of (Idx : Natural) return Table_Index_Type is
 373          J : constant Integer'Base := Table_Index_Type'Pos (First) + Idx - 1;
 374       begin
 375          return Table_Index_Type'Val (J);
 376       end Index_Of;
 377
 378       ----------
 379       -- Move --
 380       ----------
 381
 382       procedure Move (From : Natural; To : Natural) is
 383       begin
 384          if From = 0 then
 385             Table (Index_Of (To)) := Temp;
 386          elsif To = 0 then
 387             Temp := Table (Index_Of (From));
 388          else
 389             Table (Index_Of (To)) := Table (Index_Of (From));
 390          end if;
 391       end Move;
 392
 393       ----------------
 394       -- Lower_Than --
 395       ----------------
 396
 397       function Lower_Than (Op1, Op2 : Natural) return Boolean is
 398       begin
 399          if Op1 = 0 then
 400             return Lt (Temp, Table (Index_Of (Op2)));
 401          elsif Op2 = 0 then
 402             return Lt (Table (Index_Of (Op1)), Temp);
 403          else
 404             return Lt (Table (Index_Of (Op1)), Table (Index_Of (Op2)));
 405          end if;
 406       end Lower_Than;
 407
 408    --  Start of processing for Sort_Table
 409
 410    begin
 411       Heap_Sort.Sort (Natural (Last - First) + 1);
 412    end Sort_Table;
 413
 414 begin
 415    Init;
 416 end GNAT.Table;