1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- G N A T . D Y N A M I C _ T A B L E S --
9 -- Copyright (C) 2000-2009, AdaCore --
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. --
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. --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
32 ------------------------------------------------------------------------------
36 with GNAT.Heap_Sort_G;
37 with System; use System;
38 with System.Memory; use System.Memory;
40 with Ada.Unchecked_Conversion;
42 package body GNAT.Dynamic_Tables is
44 Min : constant Integer := Integer (Table_Low_Bound);
45 -- Subscript of the minimum entry in the currently allocated table
47 -----------------------
48 -- Local Subprograms --
49 -----------------------
51 procedure Reallocate (T : in out Instance);
52 -- Reallocate the existing table according to the current value stored
53 -- in Max. Works correctly to do an initial allocation if the table
56 pragma Warnings (Off);
57 -- These unchecked conversions are in fact safe, since they never
58 -- generate improperly aliased pointer values.
60 function To_Address is new Ada.Unchecked_Conversion (Table_Ptr, Address);
61 function To_Pointer is new Ada.Unchecked_Conversion (Address, Table_Ptr);
69 procedure Allocate (T : in out Instance; Num : Integer := 1) is
71 T.P.Last_Val := T.P.Last_Val + Num;
73 if T.P.Last_Val > T.P.Max then
82 procedure Append (T : in out Instance; New_Val : Table_Component_Type) is
84 Set_Item (T, Table_Index_Type (T.P.Last_Val + 1), New_Val);
91 procedure Append_All (T : in out Instance; New_Vals : Table_Type) is
93 for J in New_Vals'Range loop
94 Append (T, New_Vals (J));
102 procedure Decrement_Last (T : in out Instance) is
104 T.P.Last_Val := T.P.Last_Val - 1;
111 procedure For_Each (Table : Instance) is
112 Quit : Boolean := False;
114 for Index in Table_Low_Bound .. Table_Index_Type (Table.P.Last_Val) loop
115 Action (Index, Table.Table (Index), Quit);
124 procedure Free (T : in out Instance) is
126 Free (To_Address (T.Table));
135 procedure Increment_Last (T : in out Instance) is
137 T.P.Last_Val := T.P.Last_Val + 1;
139 if T.P.Last_Val > T.P.Max then
148 procedure Init (T : in out Instance) is
149 Old_Length : constant Integer := T.P.Length;
152 T.P.Last_Val := Min - 1;
153 T.P.Max := Min + Table_Initial - 1;
154 T.P.Length := T.P.Max - Min + 1;
156 -- If table is same size as before (happens when table is never
157 -- expanded which is a common case), then simply reuse it. Note
158 -- that this also means that an explicit Init call right after
159 -- the implicit one in the package body is harmless.
161 if Old_Length = T.P.Length then
164 -- Otherwise we can use Reallocate to get a table of the right size.
165 -- Note that Reallocate works fine to allocate a table of the right
166 -- initial size when it is first allocated.
177 function Last (T : Instance) return Table_Index_Type is
179 return Table_Index_Type (T.P.Last_Val);
186 procedure Reallocate (T : in out Instance) is
187 New_Length : Integer;
191 if T.P.Max < T.P.Last_Val then
192 while T.P.Max < T.P.Last_Val loop
193 New_Length := T.P.Length * (100 + Table_Increment) / 100;
195 if New_Length > T.P.Length then
196 T.P.Length := New_Length;
198 T.P.Length := T.P.Length + 1;
201 T.P.Max := Min + T.P.Length - 1;
206 size_t ((T.P.Max - Min + 1) *
207 (Table_Type'Component_Size / Storage_Unit));
209 if T.Table = null then
210 T.Table := To_Pointer (Alloc (New_Size));
212 elsif New_Size > 0 then
214 To_Pointer (Realloc (Ptr => To_Address (T.Table),
218 if T.P.Length /= 0 and then T.Table = null then
227 procedure Release (T : in out Instance) is
229 T.P.Length := T.P.Last_Val - Integer (Table_Low_Bound) + 1;
230 T.P.Max := T.P.Last_Val;
239 (T : in out Instance;
240 Index : Table_Index_Type;
241 Item : Table_Component_Type)
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.
249 subtype Allocated_Table_T is
250 Table_Type (T.Table'First .. Table_Index_Type (T.P.Max + 1));
251 -- A constrained table subtype one element larger than the currently
254 Allocated_Table_Address : constant System.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).
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 one
265 -- element (the supplementary element is used to have a convenient way
266 -- to the address just past the end of the current allocation). Range
267 -- checks are suppressed because this unit uses direct calls to
268 -- System.Memory for allocation, and this can yield misaligned storage
269 -- (and we cannot rely on the bootstrap compiler supporting specifically
270 -- disabling alignment checks, so we need to suppress all range checks).
271 -- It is safe to suppress this check here because we know that a
272 -- (possibly misaligned) object of that type does actually exist at that
274 -- ??? We should really improve the allocation circuitry here to
275 -- guarantee proper alignment.
277 Need_Realloc : constant Boolean := Integer (Index) > T.P.Max;
278 -- True if this operation requires storage reallocation (which may
279 -- involve moving table contents around).
282 -- If we're going to reallocate, check whether Item references an
283 -- element of the currently allocated table.
286 and then Allocated_Table'Address <= Item'Address
287 and then Item'Address <
288 Allocated_Table (Table_Index_Type (T.P.Max + 1))'Address
290 -- If so, save a copy on the stack because Increment_Last will
291 -- reallocate storage and might deallocate the current table.
294 Item_Copy : constant Table_Component_Type := Item;
297 T.Table (Index) := Item_Copy;
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.
304 if Integer (Index) > T.P.Last_Val then
308 T.Table (Index) := Item;
316 procedure Set_Last (T : in out Instance; New_Val : Table_Index_Type) is
318 if Integer (New_Val) < T.P.Last_Val then
319 T.P.Last_Val := Integer (New_Val);
322 T.P.Last_Val := Integer (New_Val);
324 if T.P.Last_Val > T.P.Max then
334 procedure Sort_Table (Table : in out Instance) is
336 Temp : Table_Component_Type;
337 -- A temporary position to simulate index 0
341 function Index_Of (Idx : Natural) return Table_Index_Type;
342 -- Return index of Idx'th element of table
344 function Lower_Than (Op1, Op2 : Natural) return Boolean;
345 -- Compare two components
347 procedure Move (From : Natural; To : Natural);
348 -- Move one component
350 package Heap_Sort is new GNAT.Heap_Sort_G (Move, Lower_Than);
356 function Index_Of (Idx : Natural) return Table_Index_Type is
357 J : constant Integer'Base :=
358 Table_Index_Type'Pos (First) + Idx - 1;
360 return Table_Index_Type'Val (J);
367 procedure Move (From : Natural; To : Natural) is
370 Table.Table (Index_Of (To)) := Temp;
373 Temp := Table.Table (Index_Of (From));
376 Table.Table (Index_Of (To)) :=
377 Table.Table (Index_Of (From));
385 function Lower_Than (Op1, Op2 : Natural) return Boolean is
388 return Lt (Temp, Table.Table (Index_Of (Op2)));
391 return Lt (Table.Table (Index_Of (Op1)), Temp);
395 Lt (Table.Table (Index_Of (Op1)),
396 Table.Table (Index_Of (Op2)));
400 -- Start of processing for Sort_Table
403 Heap_Sort.Sort (Natural (Last (Table) - First) + 1);
406 end GNAT.Dynamic_Tables;