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