File : 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 -- --
19 -- --
20 -- --
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;