gcc/ada/g-dyntab.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                   G N A T . D Y N A M I C _ T A B L E S                  --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --                     Copyright (C) 2000-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 pragma Compiler_Unit_Warning;
  33
  34 with GNAT.Heap_Sort_G;
  35 with System;        use System;
  36 with System.Memory; use System.Memory;
  37
  38 with Ada.Unchecked_Conversion;
  39
  40 package body GNAT.Dynamic_Tables is
  41
  42    Min : constant Integer := Integer (Table_Low_Bound);
  43    --  Subscript of the minimum entry in the currently allocated table
  44
  45    -----------------------
  46    -- Local Subprograms --
  47    -----------------------
  48
  49    procedure Reallocate (T : in out Instance);
  50    --  Reallocate the existing table according to the current value stored
  51    --  in Max. Works correctly to do an initial allocation if the table
  52    --  is currently null.
  53
  54    pragma Warnings (Off);
  55    --  These unchecked conversions are in fact safe, since they never
  56    --  generate improperly aliased pointer values.
  57
  58    function To_Address is new Ada.Unchecked_Conversion (Table_Ptr, Address);
  59    function To_Pointer is new Ada.Unchecked_Conversion (Address, Table_Ptr);
  60
  61    pragma Warnings (On);
  62
  63    --------------
  64    -- Allocate --
  65    --------------
  66
  67    procedure Allocate (T : in out Instance; Num : Integer := 1) is
  68    begin
  69       T.P.Last_Val := T.P.Last_Val + Num;
  70
  71       if T.P.Last_Val > T.P.Max then
  72          Reallocate (T);
  73       end if;
  74    end Allocate;
  75
  76    ------------
  77    -- Append --
  78    ------------
  79
  80    procedure Append (T : in out Instance; New_Val : Table_Component_Type) is
  81    begin
  82       Set_Item (T, Table_Index_Type (T.P.Last_Val + 1), New_Val);
  83    end Append;
  84
  85    ----------------
  86    -- Append_All --
  87    ----------------
  88
  89    procedure Append_All (T : in out Instance; New_Vals : Table_Type) is
  90    begin
  91       for J in New_Vals'Range loop
  92          Append (T, New_Vals (J));
  93       end loop;
  94    end Append_All;
  95
  96    --------------------
  97    -- Decrement_Last --
  98    --------------------
  99
 100    procedure Decrement_Last (T : in out Instance) is
 101    begin
 102       T.P.Last_Val := T.P.Last_Val - 1;
 103    end Decrement_Last;
 104
 105    --------------
 106    -- For_Each --
 107    --------------
 108
 109    procedure For_Each (Table : Instance) is
 110       Quit : Boolean := False;
 111    begin
 112       for Index in Table_Low_Bound .. Table_Index_Type (Table.P.Last_Val) loop
 113          Action (Index, Table.Table (Index), Quit);
 114          exit when Quit;
 115       end loop;
 116    end For_Each;
 117
 118    ----------
 119    -- Free --
 120    ----------
 121
 122    procedure Free (T : in out Instance) is
 123    begin
 124       Free (To_Address (T.Table));
 125       T.Table := null;
 126       T.P.Length := 0;
 127    end Free;
 128
 129    --------------------
 130    -- Increment_Last --
 131    --------------------
 132
 133    procedure Increment_Last (T : in out Instance) is
 134    begin
 135       T.P.Last_Val := T.P.Last_Val + 1;
 136
 137       if T.P.Last_Val > T.P.Max then
 138          Reallocate (T);
 139       end if;
 140    end Increment_Last;
 141
 142    ----------
 143    -- Init --
 144    ----------
 145
 146    procedure Init (T : in out Instance) is
 147       Old_Length : constant Integer := T.P.Length;
 148
 149    begin
 150       T.P.Last_Val := Min - 1;
 151       T.P.Max      := Min + Table_Initial - 1;
 152       T.P.Length   := T.P.Max - Min + 1;
 153
 154       --  If table is same size as before (happens when table is never
 155       --  expanded which is a common case), then simply reuse it. Note
 156       --  that this also means that an explicit Init call right after
 157       --  the implicit one in the package body is harmless.
 158
 159       if Old_Length = T.P.Length then
 160          return;
 161
 162       --  Otherwise we can use Reallocate to get a table of the right size.
 163       --  Note that Reallocate works fine to allocate a table of the right
 164       --  initial size when it is first allocated.
 165
 166       else
 167          Reallocate (T);
 168       end if;
 169    end Init;
 170
 171    ----------
 172    -- Last --
 173    ----------
 174
 175    function Last (T : Instance) return Table_Index_Type is
 176    begin
 177       return Table_Index_Type (T.P.Last_Val);
 178    end Last;
 179
 180    ----------------
 181    -- Reallocate --
 182    ----------------
 183
 184    procedure Reallocate (T : in out Instance) is
 185       New_Length : Integer;
 186       New_Size   : size_t;
 187
 188    begin
 189       if T.P.Max < T.P.Last_Val then
 190
 191          --  Now increment table length until it is sufficiently large. Use
 192          --  the increment value or 10, which ever is larger (the reason
 193          --  for the use of 10 here is to ensure that the table does really
 194          --  increase in size (which would not be the case for a table of
 195          --  length 10 increased by 3% for instance). Do the intermediate
 196          --  calculation in Long_Long_Integer to avoid overflow.
 197
 198          while T.P.Max < T.P.Last_Val loop
 199             New_Length :=
 200               Integer
 201                 (Long_Long_Integer (T.P.Length) *
 202                   (100 + Long_Long_Integer (Table_Increment)) / 100);
 203
 204             if New_Length > T.P.Length then
 205                T.P.Length := New_Length;
 206             else
 207                T.P.Length := T.P.Length + 10;
 208             end if;
 209
 210             T.P.Max := Min + T.P.Length - 1;
 211          end loop;
 212       end if;
 213
 214       New_Size :=
 215         size_t ((T.P.Max - Min + 1) *
 216                 (Table_Type'Component_Size / Storage_Unit));
 217
 218       if T.Table = null then
 219          T.Table := To_Pointer (Alloc (New_Size));
 220
 221       elsif New_Size > 0 then
 222          T.Table :=
 223            To_Pointer (Realloc (Ptr  => To_Address (T.Table),
 224                                 Size => New_Size));
 225       end if;
 226
 227       if T.P.Length /= 0 and then T.Table = null then
 228          raise Storage_Error;
 229       end if;
 230    end Reallocate;
 231
 232    -------------
 233    -- Release --
 234    -------------
 235
 236    procedure Release (T : in out Instance) is
 237    begin
 238       T.P.Length := T.P.Last_Val - Integer (Table_Low_Bound) + 1;
 239       T.P.Max    := T.P.Last_Val;
 240       Reallocate (T);
 241    end Release;
 242
 243    --------------
 244    -- Set_Item --
 245    --------------
 246
 247    procedure Set_Item
 248       (T     : in out Instance;
 249        Index : Table_Index_Type;
 250        Item  : Table_Component_Type)
 251    is
 252       --  If Item is a value within the current allocation, and we are going to
 253       --  reallocate, then we must preserve an intermediate copy here before
 254       --  calling Increment_Last. Otherwise, if Table_Component_Type is passed
 255       --  by reference, we are going to end up copying from storage that might
 256       --  have been deallocated from Increment_Last calling Reallocate.
 257
 258       subtype Allocated_Table_T is
 259         Table_Type (T.Table'First .. Table_Index_Type (T.P.Max + 1));
 260       --  A constrained table subtype one element larger than the currently
 261       --  allocated table.
 262
 263       Allocated_Table_Address : constant System.Address :=
 264                                   T.Table.all'Address;
 265       --  Used for address clause below (we can't use non-static expression
 266       --  Table.all'Address directly in the clause because some older versions
 267       --  of the compiler do not allow it).
 268
 269       Allocated_Table : Allocated_Table_T;
 270       pragma Import (Ada, Allocated_Table);
 271       pragma Suppress (Range_Check, On => Allocated_Table);
 272       for Allocated_Table'Address use Allocated_Table_Address;
 273       --  Allocated_Table represents the currently allocated array, plus one
 274       --  element (the supplementary element is used to have a convenient way
 275       --  to the address just past the end of the current allocation). Range
 276       --  checks are suppressed because this unit uses direct calls to
 277       --  System.Memory for allocation, and this can yield misaligned storage
 278       --  (and we cannot rely on the bootstrap compiler supporting specifically
 279       --  disabling alignment checks, so we need to suppress all range checks).
 280       --  It is safe to suppress this check here because we know that a
 281       --  (possibly misaligned) object of that type does actually exist at that
 282       --  address.
 283       --  ??? We should really improve the allocation circuitry here to
 284       --  guarantee proper alignment.
 285
 286       Need_Realloc : constant Boolean := Integer (Index) > T.P.Max;
 287       --  True if this operation requires storage reallocation (which may
 288       --  involve moving table contents around).
 289
 290    begin
 291       --  If we're going to reallocate, check whether Item references an
 292       --  element of the currently allocated table.
 293
 294       if Need_Realloc
 295         and then Allocated_Table'Address <= Item'Address
 296         and then Item'Address <
 297                    Allocated_Table (Table_Index_Type (T.P.Max + 1))'Address
 298       then
 299          --  If so, save a copy on the stack because Increment_Last will
 300          --  reallocate storage and might deallocate the current table.
 301
 302          declare
 303             Item_Copy : constant Table_Component_Type := Item;
 304          begin
 305             Set_Last (T, Index);
 306             T.Table (Index) := Item_Copy;
 307          end;
 308
 309       else
 310          --  Here we know that either we won't reallocate (case of Index < Max)
 311          --  or that Item is not in the currently allocated table.
 312
 313          if Integer (Index) > T.P.Last_Val then
 314             Set_Last (T, Index);
 315          end if;
 316
 317          T.Table (Index) := Item;
 318       end if;
 319    end Set_Item;
 320
 321    --------------
 322    -- Set_Last --
 323    --------------
 324
 325    procedure Set_Last (T : in out Instance; New_Val : Table_Index_Type) is
 326    begin
 327       if Integer (New_Val) < T.P.Last_Val then
 328          T.P.Last_Val := Integer (New_Val);
 329
 330       else
 331          T.P.Last_Val := Integer (New_Val);
 332
 333          if T.P.Last_Val > T.P.Max then
 334             Reallocate (T);
 335          end if;
 336       end if;
 337    end Set_Last;
 338
 339    ----------------
 340    -- Sort_Table --
 341    ----------------
 342
 343    procedure Sort_Table (Table : in out Instance) is
 344
 345       Temp : Table_Component_Type;
 346       --  A temporary position to simulate index 0
 347
 348       --  Local subprograms
 349
 350       function Index_Of (Idx : Natural) return Table_Index_Type;
 351       --  Return index of Idx'th element of table
 352
 353       function Lower_Than (Op1, Op2 : Natural) return Boolean;
 354       --  Compare two components
 355
 356       procedure Move (From : Natural; To : Natural);
 357       --  Move one component
 358
 359       package Heap_Sort is new GNAT.Heap_Sort_G (Move, Lower_Than);
 360
 361       --------------
 362       -- Index_Of --
 363       --------------
 364
 365       function Index_Of (Idx : Natural) return Table_Index_Type is
 366          J : constant Integer'Base :=
 367                Table_Index_Type'Pos (First) + Idx - 1;
 368       begin
 369          return Table_Index_Type'Val (J);
 370       end Index_Of;
 371
 372       ----------
 373       -- Move --
 374       ----------
 375
 376       procedure Move (From : Natural; To : Natural) is
 377       begin
 378          if From = 0 then
 379             Table.Table (Index_Of (To)) := Temp;
 380
 381          elsif To = 0 then
 382             Temp := Table.Table (Index_Of (From));
 383
 384          else
 385             Table.Table (Index_Of (To)) :=
 386               Table.Table (Index_Of (From));
 387          end if;
 388       end Move;
 389
 390       ----------------
 391       -- Lower_Than --
 392       ----------------
 393
 394       function Lower_Than (Op1, Op2 : Natural) return Boolean is
 395       begin
 396          if Op1 = 0 then
 397             return Lt (Temp, Table.Table (Index_Of (Op2)));
 398
 399          elsif Op2 = 0 then
 400             return Lt (Table.Table (Index_Of (Op1)), Temp);
 401
 402          else
 403             return
 404               Lt (Table.Table (Index_Of (Op1)),
 405                    Table.Table (Index_Of (Op2)));
 406          end if;
 407       end Lower_Than;
 408
 409    --  Start of processing for Sort_Table
 410
 411    begin
 412       Heap_Sort.Sort (Natural (Last (Table) - First) + 1);
 413    end Sort_Table;
 414
 415 end GNAT.Dynamic_Tables;