|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT COMPILER COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- T A B L E --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
131
|
9 -- Copyright (C) 1992-2018, Free Software Foundation, Inc. --
|
|
111
|
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 Debug; use Debug;
|
|
|
33 with Opt; use Opt;
|
|
|
34 with Output; use Output;
|
|
|
35 with System; use System;
|
|
|
36 with Tree_IO; use Tree_IO;
|
|
|
37
|
|
|
38 with System.Memory; use System.Memory;
|
|
|
39
|
|
|
40 with Unchecked_Conversion;
|
|
|
41
|
|
|
42 pragma Elaborate_All (Output);
|
|
|
43
|
|
|
44 package body Table is
|
|
|
45 package body Table is
|
|
|
46
|
|
|
47 Min : constant Int := Int (Table_Low_Bound);
|
|
|
48 -- Subscript of the minimum entry in the currently allocated table
|
|
|
49
|
|
|
50 Length : Int := 0;
|
|
|
51 -- Number of entries in currently allocated table. The value of zero
|
|
|
52 -- ensures that we initially allocate the table.
|
|
|
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 function Tree_Get_Table_Address return Address;
|
|
|
64 -- Return Null_Address if the table length is zero,
|
|
|
65 -- Table (First)'Address if not.
|
|
|
66
|
|
|
67 pragma Warnings (Off);
|
|
|
68 -- Turn off warnings. The following unchecked conversions are only used
|
|
|
69 -- internally in this package, and cannot never result in any instances
|
|
|
70 -- of improperly aliased pointers for the client of the package.
|
|
|
71
|
|
|
72 function To_Address is new Unchecked_Conversion (Table_Ptr, Address);
|
|
|
73 function To_Pointer is new Unchecked_Conversion (Address, Table_Ptr);
|
|
|
74
|
|
|
75 pragma Warnings (On);
|
|
|
76
|
|
|
77 ------------
|
|
|
78 -- Append --
|
|
|
79 ------------
|
|
|
80
|
|
|
81 procedure Append (New_Val : Table_Component_Type) is
|
|
|
82 begin
|
|
|
83 Set_Item (Table_Index_Type (Last_Val + 1), New_Val);
|
|
|
84 end Append;
|
|
|
85
|
|
|
86 ----------------
|
|
|
87 -- Append_All --
|
|
|
88 ----------------
|
|
|
89
|
|
|
90 procedure Append_All (New_Vals : Table_Type) is
|
|
|
91 begin
|
|
|
92 for J in New_Vals'Range loop
|
|
|
93 Append (New_Vals (J));
|
|
|
94 end loop;
|
|
|
95 end Append_All;
|
|
|
96
|
|
|
97 --------------------
|
|
|
98 -- Decrement_Last --
|
|
|
99 --------------------
|
|
|
100
|
|
|
101 procedure Decrement_Last is
|
|
|
102 begin
|
|
|
103 Last_Val := Last_Val - 1;
|
|
|
104 end Decrement_Last;
|
|
|
105
|
|
|
106 ----------
|
|
|
107 -- Free --
|
|
|
108 ----------
|
|
|
109
|
|
|
110 procedure Free is
|
|
|
111 begin
|
|
|
112 Free (To_Address (Table));
|
|
|
113 Table := null;
|
|
|
114 Length := 0;
|
|
|
115 end Free;
|
|
|
116
|
|
|
117 --------------------
|
|
|
118 -- Increment_Last --
|
|
|
119 --------------------
|
|
|
120
|
|
|
121 procedure Increment_Last is
|
|
|
122 begin
|
|
|
123 Last_Val := Last_Val + 1;
|
|
|
124
|
|
|
125 if Last_Val > Max then
|
|
|
126 Reallocate;
|
|
|
127 end if;
|
|
|
128 end Increment_Last;
|
|
|
129
|
|
|
130 ----------
|
|
|
131 -- Init --
|
|
|
132 ----------
|
|
|
133
|
|
|
134 procedure Init is
|
|
|
135 Old_Length : constant Int := Length;
|
|
|
136
|
|
|
137 begin
|
|
|
138 Locked := False;
|
|
|
139 Last_Val := Min - 1;
|
|
|
140 Max := Min + (Table_Initial * Table_Factor) - 1;
|
|
|
141 Length := Max - Min + 1;
|
|
|
142
|
|
|
143 -- If table is same size as before (happens when table is never
|
|
|
144 -- expanded which is a common case), then simply reuse it. Note
|
|
|
145 -- that this also means that an explicit Init call right after
|
|
|
146 -- the implicit one in the package body is harmless.
|
|
|
147
|
|
|
148 if Old_Length = Length then
|
|
|
149 return;
|
|
|
150
|
|
|
151 -- Otherwise we can use Reallocate to get a table of the right size.
|
|
|
152 -- Note that Reallocate works fine to allocate a table of the right
|
|
|
153 -- initial size when it is first allocated.
|
|
|
154
|
|
|
155 else
|
|
|
156 Reallocate;
|
|
|
157 end if;
|
|
|
158 end Init;
|
|
|
159
|
|
|
160 ----------
|
|
|
161 -- Last --
|
|
|
162 ----------
|
|
|
163
|
|
|
164 function Last return Table_Index_Type is
|
|
|
165 begin
|
|
|
166 return Table_Index_Type (Last_Val);
|
|
|
167 end Last;
|
|
|
168
|
|
|
169 ----------------
|
|
|
170 -- Reallocate --
|
|
|
171 ----------------
|
|
|
172
|
|
|
173 procedure Reallocate is
|
|
|
174 New_Size : Memory.size_t;
|
|
|
175 New_Length : Long_Long_Integer;
|
|
|
176
|
|
|
177 begin
|
|
|
178 if Max < Last_Val then
|
|
|
179 pragma Assert (not Locked);
|
|
|
180
|
|
|
181 -- Make sure that we have at least the initial allocation. This
|
|
|
182 -- is needed in cases where a zero length table is written out.
|
|
|
183
|
|
|
184 Length := Int'Max (Length, Table_Initial);
|
|
|
185
|
|
|
186 -- Now increment table length until it is sufficiently large. Use
|
|
|
187 -- the increment value or 10, which ever is larger (the reason
|
|
|
188 -- for the use of 10 here is to ensure that the table does really
|
|
|
189 -- increase in size (which would not be the case for a table of
|
|
|
190 -- length 10 increased by 3% for instance). Do the intermediate
|
|
|
191 -- calculation in Long_Long_Integer to avoid overflow.
|
|
|
192
|
|
|
193 while Max < Last_Val loop
|
|
|
194 New_Length :=
|
|
|
195 Long_Long_Integer (Length) *
|
|
|
196 (100 + Long_Long_Integer (Table_Increment)) / 100;
|
|
|
197 Length := Int'Max (Int (New_Length), Length + 10);
|
|
|
198 Max := Min + Length - 1;
|
|
|
199 end loop;
|
|
|
200
|
|
|
201 if Debug_Flag_D then
|
|
|
202 Write_Str ("--> Allocating new ");
|
|
|
203 Write_Str (Table_Name);
|
|
|
204 Write_Str (" table, size = ");
|
|
|
205 Write_Int (Max - Min + 1);
|
|
|
206 Write_Eol;
|
|
|
207 end if;
|
|
|
208 end if;
|
|
|
209
|
|
|
210 -- Do the intermediate calculation in size_t to avoid signed overflow
|
|
|
211
|
|
|
212 New_Size :=
|
|
|
213 Memory.size_t (Max - Min + 1) *
|
|
|
214 (Table_Type'Component_Size / Storage_Unit);
|
|
|
215
|
|
|
216 if Table = null then
|
|
|
217 Table := To_Pointer (Alloc (New_Size));
|
|
|
218
|
|
|
219 elsif New_Size > 0 then
|
|
|
220 Table :=
|
|
|
221 To_Pointer (Realloc (Ptr => To_Address (Table),
|
|
|
222 Size => New_Size));
|
|
|
223 end if;
|
|
|
224
|
|
|
225 if Length /= 0 and then Table = null then
|
|
|
226 Set_Standard_Error;
|
|
|
227 Write_Str ("available memory exhausted");
|
|
|
228 Write_Eol;
|
|
|
229 Set_Standard_Output;
|
|
|
230 raise Unrecoverable_Error;
|
|
|
231 end if;
|
|
|
232 end Reallocate;
|
|
|
233
|
|
|
234 -------------
|
|
|
235 -- Release --
|
|
|
236 -------------
|
|
|
237
|
|
|
238 procedure Release is
|
|
|
239 Extra_Length : Int;
|
|
|
240 Size : Memory.size_t;
|
|
|
241
|
|
|
242 begin
|
|
|
243 Length := Last_Val - Int (Table_Low_Bound) + 1;
|
|
|
244 Size := Memory.size_t (Length) *
|
|
|
245 (Table_Type'Component_Size / Storage_Unit);
|
|
|
246
|
|
|
247 -- If the size of the table exceeds the release threshold then leave
|
|
|
248 -- space to store as many extra elements as 0.1% of the table length.
|
|
|
249
|
|
|
250 if Release_Threshold > 0
|
|
|
251 and then Size > Memory.size_t (Release_Threshold)
|
|
|
252 then
|
|
|
253 Extra_Length := Length / 1000;
|
|
|
254 Length := Length + Extra_Length;
|
|
|
255 Max := Int (Table_Low_Bound) + Length - 1;
|
|
|
256
|
|
|
257 if Debug_Flag_D then
|
|
|
258 Write_Str ("--> Release_Threshold reached (length=");
|
|
|
259 Write_Int (Int (Size));
|
|
|
260 Write_Str ("): leaving room space for ");
|
|
|
261 Write_Int (Extra_Length);
|
|
|
262 Write_Str (" components");
|
|
|
263 Write_Eol;
|
|
|
264 end if;
|
|
|
265 else
|
|
|
266 Max := Last_Val;
|
|
|
267 end if;
|
|
|
268
|
|
|
269 Reallocate;
|
|
|
270 end Release;
|
|
|
271
|
|
|
272 -------------
|
|
|
273 -- Restore --
|
|
|
274 -------------
|
|
|
275
|
|
|
276 procedure Restore (T : Saved_Table) is
|
|
|
277 begin
|
|
|
278 Free (To_Address (Table));
|
|
|
279 Last_Val := T.Last_Val;
|
|
|
280 Max := T.Max;
|
|
|
281 Table := T.Table;
|
|
|
282 Length := Max - Min + 1;
|
|
|
283 end Restore;
|
|
|
284
|
|
|
285 ----------
|
|
|
286 -- Save --
|
|
|
287 ----------
|
|
|
288
|
|
|
289 function Save return Saved_Table is
|
|
|
290 Res : Saved_Table;
|
|
|
291
|
|
|
292 begin
|
|
|
293 Res.Last_Val := Last_Val;
|
|
|
294 Res.Max := Max;
|
|
|
295 Res.Table := Table;
|
|
|
296
|
|
|
297 Table := null;
|
|
|
298 Length := 0;
|
|
|
299 Init;
|
|
|
300 return Res;
|
|
|
301 end Save;
|
|
|
302
|
|
|
303 --------------
|
|
|
304 -- Set_Item --
|
|
|
305 --------------
|
|
|
306
|
|
|
307 procedure Set_Item
|
|
|
308 (Index : Table_Index_Type;
|
|
|
309 Item : Table_Component_Type)
|
|
|
310 is
|
|
|
311 -- If Item is a value within the current allocation, and we are going
|
|
|
312 -- to reallocate, then we must preserve an intermediate copy here
|
|
|
313 -- before calling Increment_Last. Otherwise, if Table_Component_Type
|
|
|
314 -- is passed by reference, we are going to end up copying from
|
|
|
315 -- storage that might have been deallocated from Increment_Last
|
|
|
316 -- calling Reallocate.
|
|
|
317
|
|
|
318 subtype Allocated_Table_T is
|
|
|
319 Table_Type (Table'First .. Table_Index_Type (Max + 1));
|
|
|
320 -- A constrained table subtype one element larger than the currently
|
|
|
321 -- allocated table.
|
|
|
322
|
|
|
323 Allocated_Table_Address : constant System.Address :=
|
|
|
324 Table.all'Address;
|
|
|
325 -- Used for address clause below (we can't use non-static expression
|
|
|
326 -- Table.all'Address directly in the clause because some older
|
|
|
327 -- versions of the compiler do not allow it).
|
|
|
328
|
|
|
329 Allocated_Table : Allocated_Table_T;
|
|
|
330 pragma Import (Ada, Allocated_Table);
|
|
|
331 pragma Suppress (Range_Check, On => Allocated_Table);
|
|
|
332 for Allocated_Table'Address use Allocated_Table_Address;
|
|
|
333 -- Allocated_Table represents the currently allocated array, plus one
|
|
|
334 -- element (the supplementary element is used to have a convenient
|
|
|
335 -- way of computing the address just past the end of the current
|
|
|
336 -- allocation). Range checks are suppressed because this unit
|
|
|
337 -- uses direct calls to System.Memory for allocation, and this can
|
|
|
338 -- yield misaligned storage (and we cannot rely on the bootstrap
|
|
|
339 -- compiler supporting specifically disabling alignment checks, so we
|
|
|
340 -- need to suppress all range checks). It is safe to suppress this
|
|
|
341 -- check here because we know that a (possibly misaligned) object
|
|
|
342 -- of that type does actually exist at that address.
|
|
|
343 -- ??? We should really improve the allocation circuitry here to
|
|
|
344 -- guarantee proper alignment.
|
|
|
345
|
|
|
346 Need_Realloc : constant Boolean := Int (Index) > Max;
|
|
|
347 -- True if this operation requires storage reallocation (which may
|
|
|
348 -- involve moving table contents around).
|
|
|
349
|
|
|
350 begin
|
|
|
351 -- If we're going to reallocate, check whether Item references an
|
|
|
352 -- element of the currently allocated table.
|
|
|
353
|
|
|
354 if Need_Realloc
|
|
|
355 and then Allocated_Table'Address <= Item'Address
|
|
|
356 and then Item'Address <
|
|
|
357 Allocated_Table (Table_Index_Type (Max + 1))'Address
|
|
|
358 then
|
|
|
359 -- If so, save a copy on the stack because Increment_Last will
|
|
|
360 -- reallocate storage and might deallocate the current table.
|
|
|
361
|
|
|
362 declare
|
|
|
363 Item_Copy : constant Table_Component_Type := Item;
|
|
|
364 begin
|
|
|
365 Set_Last (Index);
|
|
|
366 Table (Index) := Item_Copy;
|
|
|
367 end;
|
|
|
368
|
|
|
369 else
|
|
|
370 -- Here we know that either we won't reallocate (case of Index <
|
|
|
371 -- Max) or that Item is not in the currently allocated table.
|
|
|
372
|
|
|
373 if Int (Index) > Last_Val then
|
|
|
374 Set_Last (Index);
|
|
|
375 end if;
|
|
|
376
|
|
|
377 Table (Index) := Item;
|
|
|
378 end if;
|
|
|
379 end Set_Item;
|
|
|
380
|
|
|
381 --------------
|
|
|
382 -- Set_Last --
|
|
|
383 --------------
|
|
|
384
|
|
|
385 procedure Set_Last (New_Val : Table_Index_Type) is
|
|
|
386 begin
|
|
|
387 if Int (New_Val) < Last_Val then
|
|
|
388 Last_Val := Int (New_Val);
|
|
|
389
|
|
|
390 else
|
|
|
391 Last_Val := Int (New_Val);
|
|
|
392
|
|
|
393 if Last_Val > Max then
|
|
|
394 Reallocate;
|
|
|
395 end if;
|
|
|
396 end if;
|
|
|
397 end Set_Last;
|
|
|
398
|
|
|
399 ----------------------------
|
|
|
400 -- Tree_Get_Table_Address --
|
|
|
401 ----------------------------
|
|
|
402
|
|
|
403 function Tree_Get_Table_Address return Address is
|
|
|
404 begin
|
|
|
405 if Length = 0 then
|
|
|
406 return Null_Address;
|
|
|
407 else
|
|
|
408 return Table (First)'Address;
|
|
|
409 end if;
|
|
|
410 end Tree_Get_Table_Address;
|
|
|
411
|
|
|
412 ---------------
|
|
|
413 -- Tree_Read --
|
|
|
414 ---------------
|
|
|
415
|
|
|
416 -- Note: we allocate only the space required to accommodate the data
|
|
|
417 -- actually written, which means that a Tree_Write/Tree_Read sequence
|
|
|
418 -- does an implicit Release.
|
|
|
419
|
|
|
420 procedure Tree_Read is
|
|
|
421 begin
|
|
|
422 Tree_Read_Int (Max);
|
|
|
423 Last_Val := Max;
|
|
|
424 Length := Max - Min + 1;
|
|
|
425 Reallocate;
|
|
|
426
|
|
|
427 Tree_Read_Data
|
|
|
428 (Tree_Get_Table_Address,
|
|
|
429 (Last_Val - Int (First) + 1) *
|
|
|
430
|
|
|
431 -- Note the importance of parenthesizing the following division
|
|
|
432 -- to avoid the possibility of intermediate overflow.
|
|
|
433
|
|
|
434 (Table_Type'Component_Size / Storage_Unit));
|
|
|
435 end Tree_Read;
|
|
|
436
|
|
|
437 ----------------
|
|
|
438 -- Tree_Write --
|
|
|
439 ----------------
|
|
|
440
|
|
|
441 -- Note: we write out only the currently valid data, not the entire
|
|
|
442 -- contents of the allocated array. See note above on Tree_Read.
|
|
|
443
|
|
|
444 procedure Tree_Write is
|
|
|
445 begin
|
|
|
446 Tree_Write_Int (Int (Last));
|
|
|
447 Tree_Write_Data
|
|
|
448 (Tree_Get_Table_Address,
|
|
|
449 (Last_Val - Int (First) + 1) *
|
|
|
450 (Table_Type'Component_Size / Storage_Unit));
|
|
|
451 end Tree_Write;
|
|
|
452
|
|
|
453 begin
|
|
|
454 Init;
|
|
|
455 end Table;
|
|
|
456 end Table;
|
