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-- 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 32pragma Compiler_Unit_Warning; 33 34with GNAT.Heap_Sort_G; 35with System; use System; 36with System.Memory; use System.Memory; 37 38with Ada.Unchecked_Conversion; 39 40package 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 415end GNAT.Dynamic_Tables; 416