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-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 pragma Compiler_Unit;
  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          while T.P.Max < T.P.Last_Val loop
 191             New_Length := T.P.Length * (100 + Table_Increment) / 100;
 192
 193             if New_Length > T.P.Length then
 194                T.P.Length := New_Length;
 195             else
 196                T.P.Length := T.P.Length + 1;
 197             end if;
 198
 199             T.P.Max := Min + T.P.Length - 1;
 200          end loop;
 201       end if;
 202
 203       New_Size :=
 204         size_t ((T.P.Max - Min + 1) *
 205                 (Table_Type'Component_Size / Storage_Unit));
 206
 207       if T.Table = null then
 208          T.Table := To_Pointer (Alloc (New_Size));
 209
 210       elsif New_Size > 0 then
 211          T.Table :=
 212            To_Pointer (Realloc (Ptr  => To_Address (T.Table),
 213                                 Size => New_Size));
 214       end if;
 215
 216       if T.P.Length /= 0 and then T.Table = null then
 217          raise Storage_Error;
 218       end if;
 219    end Reallocate;
 220
 221    -------------
 222    -- Release --
 223    -------------
 224
 225    procedure Release (T : in out Instance) is
 226    begin
 227       T.P.Length := T.P.Last_Val - Integer (Table_Low_Bound) + 1;
 228       T.P.Max    := T.P.Last_Val;
 229       Reallocate (T);
 230    end Release;
 231
 232    --------------
 233    -- Set_Item --
 234    --------------
 235
 236    procedure Set_Item
 237       (T     : in out Instance;
 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 (T.Table'First .. Table_Index_Type (T.P.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                                   T.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 one
 263       --  element (the supplementary element is used to have a convenient way
 264       --  to the address just past the end of the current allocation). Range
 265       --  checks are suppressed because this unit uses direct calls to
 266       --  System.Memory for allocation, and this can yield misaligned storage
 267       --  (and we cannot rely on the bootstrap compiler supporting specifically
 268       --  disabling alignment checks, so we need to suppress all range checks).
 269       --  It is safe to suppress this check here because we know that a
 270       --  (possibly misaligned) object of that type does actually exist at that
 271       --  address.
 272       --  ??? We should really improve the allocation circuitry here to
 273       --  guarantee proper alignment.
 274
 275       Need_Realloc : constant Boolean := Integer (Index) > T.P.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 (T.P.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 (T, Index);
 295             T.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) > T.P.Last_Val then
 303             Set_Last (T, Index);
 304          end if;
 305
 306          T.Table (Index) := Item;
 307       end if;
 308    end Set_Item;
 309
 310    --------------
 311    -- Set_Last --
 312    --------------
 313
 314    procedure Set_Last (T : in out Instance; New_Val : Table_Index_Type) is
 315    begin
 316       if Integer (New_Val) < T.P.Last_Val then
 317          T.P.Last_Val := Integer (New_Val);
 318
 319       else
 320          T.P.Last_Val := Integer (New_Val);
 321
 322          if T.P.Last_Val > T.P.Max then
 323             Reallocate (T);
 324          end if;
 325       end if;
 326    end Set_Last;
 327
 328    ----------------
 329    -- Sort_Table --
 330    ----------------
 331
 332    procedure Sort_Table (Table : in out Instance) is
 333
 334       Temp : Table_Component_Type;
 335       --  A temporary position to simulate index 0
 336
 337       --  Local subprograms
 338
 339       function Index_Of (Idx : Natural) return Table_Index_Type;
 340       --  Return index of Idx'th element of table
 341
 342       function Lower_Than (Op1, Op2 : Natural) return Boolean;
 343       --  Compare two components
 344
 345       procedure Move (From : Natural; To : Natural);
 346       --  Move one component
 347
 348       package Heap_Sort is new GNAT.Heap_Sort_G (Move, Lower_Than);
 349
 350       --------------
 351       -- Index_Of --
 352       --------------
 353
 354       function Index_Of (Idx : Natural) return Table_Index_Type is
 355          J : constant Integer'Base :=
 356                Table_Index_Type'Pos (First) + Idx - 1;
 357       begin
 358          return Table_Index_Type'Val (J);
 359       end Index_Of;
 360
 361       ----------
 362       -- Move --
 363       ----------
 364
 365       procedure Move (From : Natural; To : Natural) is
 366       begin
 367          if From = 0 then
 368             Table.Table (Index_Of (To)) := Temp;
 369
 370          elsif To = 0 then
 371             Temp := Table.Table (Index_Of (From));
 372
 373          else
 374             Table.Table (Index_Of (To)) :=
 375               Table.Table (Index_Of (From));
 376          end if;
 377       end Move;
 378
 379       ----------------
 380       -- Lower_Than --
 381       ----------------
 382
 383       function Lower_Than (Op1, Op2 : Natural) return Boolean is
 384       begin
 385          if Op1 = 0 then
 386             return Lt (Temp, Table.Table (Index_Of (Op2)));
 387
 388          elsif Op2 = 0 then
 389             return Lt (Table.Table (Index_Of (Op1)), Temp);
 390
 391          else
 392             return
 393               Lt (Table.Table (Index_Of (Op1)),
 394                    Table.Table (Index_Of (Op2)));
 395          end if;
 396       end Lower_Than;
 397
 398    --  Start of processing for Sort_Table
 399
 400    begin
 401       Heap_Sort.Sort (Natural (Last (Table) - First) + 1);
 402    end Sort_Table;
 403
 404 end GNAT.Dynamic_Tables;