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-2013, 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 while T.P.Max < T.P.Last_Val loop 191 New_Length := T.P.Length * (100 + Table_Increment) / 100; 192 193 if New_Length > T.P.Length then 194 T.P.Length := New_Length; 195 else 196 T.P.Length := T.P.Length + 1; 197 end if; 198 199 T.P.Max := Min + T.P.Length - 1; 200 end loop; 201 end if; 202 203 New_Size := 204 size_t ((T.P.Max - Min + 1) * 205 (Table_Type'Component_Size / Storage_Unit)); 206 207 if T.Table = null then 208 T.Table := To_Pointer (Alloc (New_Size)); 209 210 elsif New_Size > 0 then 211 T.Table := 212 To_Pointer (Realloc (Ptr => To_Address (T.Table), 213 Size => New_Size)); 214 end if; 215 216 if T.P.Length /= 0 and then T.Table = null then 217 raise Storage_Error; 218 end if; 219 end Reallocate; 220 221 ------------- 222 -- Release -- 223 ------------- 224 225 procedure Release (T : in out Instance) is 226 begin 227 T.P.Length := T.P.Last_Val - Integer (Table_Low_Bound) + 1; 228 T.P.Max := T.P.Last_Val; 229 Reallocate (T); 230 end Release; 231 232 -------------- 233 -- Set_Item -- 234 -------------- 235 236 procedure Set_Item 237 (T : in out Instance; 238 Index : Table_Index_Type; 239 Item : Table_Component_Type) 240 is 241 -- If Item is a value within the current allocation, and we are going to 242 -- reallocate, then we must preserve an intermediate copy here before 243 -- calling Increment_Last. Otherwise, if Table_Component_Type is passed 244 -- by reference, we are going to end up copying from storage that might 245 -- have been deallocated from Increment_Last calling Reallocate. 246 247 subtype Allocated_Table_T is 248 Table_Type (T.Table'First .. Table_Index_Type (T.P.Max + 1)); 249 -- A constrained table subtype one element larger than the currently 250 -- allocated table. 251 252 Allocated_Table_Address : constant System.Address := 253 T.Table.all'Address; 254 -- Used for address clause below (we can't use non-static expression 255 -- Table.all'Address directly in the clause because some older versions 256 -- of the compiler do not allow it). 257 258 Allocated_Table : Allocated_Table_T; 259 pragma Import (Ada, Allocated_Table); 260 pragma Suppress (Range_Check, On => Allocated_Table); 261 for Allocated_Table'Address use Allocated_Table_Address; 262 -- Allocated_Table represents the currently allocated array, plus one 263 -- element (the supplementary element is used to have a convenient way 264 -- to the address just past the end of the current allocation). Range 265 -- checks are suppressed because this unit uses direct calls to 266 -- System.Memory for allocation, and this can yield misaligned storage 267 -- (and we cannot rely on the bootstrap compiler supporting specifically 268 -- disabling alignment checks, so we need to suppress all range checks). 269 -- It is safe to suppress this check here because we know that a 270 -- (possibly misaligned) object of that type does actually exist at that 271 -- address. 272 -- ??? We should really improve the allocation circuitry here to 273 -- guarantee proper alignment. 274 275 Need_Realloc : constant Boolean := Integer (Index) > T.P.Max; 276 -- True if this operation requires storage reallocation (which may 277 -- involve moving table contents around). 278 279 begin 280 -- If we're going to reallocate, check whether Item references an 281 -- element of the currently allocated table. 282 283 if Need_Realloc 284 and then Allocated_Table'Address <= Item'Address 285 and then Item'Address < 286 Allocated_Table (Table_Index_Type (T.P.Max + 1))'Address 287 then 288 -- If so, save a copy on the stack because Increment_Last will 289 -- reallocate storage and might deallocate the current table. 290 291 declare 292 Item_Copy : constant Table_Component_Type := Item; 293 begin 294 Set_Last (T, Index); 295 T.Table (Index) := Item_Copy; 296 end; 297 298 else 299 -- Here we know that either we won't reallocate (case of Index < Max) 300 -- or that Item is not in the currently allocated table. 301 302 if Integer (Index) > T.P.Last_Val then 303 Set_Last (T, Index); 304 end if; 305 306 T.Table (Index) := Item; 307 end if; 308 end Set_Item; 309 310 -------------- 311 -- Set_Last -- 312 -------------- 313 314 procedure Set_Last (T : in out Instance; New_Val : Table_Index_Type) is 315 begin 316 if Integer (New_Val) < T.P.Last_Val then 317 T.P.Last_Val := Integer (New_Val); 318 319 else 320 T.P.Last_Val := Integer (New_Val); 321 322 if T.P.Last_Val > T.P.Max then 323 Reallocate (T); 324 end if; 325 end if; 326 end Set_Last; 327 328 ---------------- 329 -- Sort_Table -- 330 ---------------- 331 332 procedure Sort_Table (Table : in out Instance) is 333 334 Temp : Table_Component_Type; 335 -- A temporary position to simulate index 0 336 337 -- Local subprograms 338 339 function Index_Of (Idx : Natural) return Table_Index_Type; 340 -- Return index of Idx'th element of table 341 342 function Lower_Than (Op1, Op2 : Natural) return Boolean; 343 -- Compare two components 344 345 procedure Move (From : Natural; To : Natural); 346 -- Move one component 347 348 package Heap_Sort is new GNAT.Heap_Sort_G (Move, Lower_Than); 349 350 -------------- 351 -- Index_Of -- 352 -------------- 353 354 function Index_Of (Idx : Natural) return Table_Index_Type is 355 J : constant Integer'Base := 356 Table_Index_Type'Pos (First) + Idx - 1; 357 begin 358 return Table_Index_Type'Val (J); 359 end Index_Of; 360 361 ---------- 362 -- Move -- 363 ---------- 364 365 procedure Move (From : Natural; To : Natural) is 366 begin 367 if From = 0 then 368 Table.Table (Index_Of (To)) := Temp; 369 370 elsif To = 0 then 371 Temp := Table.Table (Index_Of (From)); 372 373 else 374 Table.Table (Index_Of (To)) := 375 Table.Table (Index_Of (From)); 376 end if; 377 end Move; 378 379 ---------------- 380 -- Lower_Than -- 381 ---------------- 382 383 function Lower_Than (Op1, Op2 : Natural) return Boolean is 384 begin 385 if Op1 = 0 then 386 return Lt (Temp, Table.Table (Index_Of (Op2))); 387 388 elsif Op2 = 0 then 389 return Lt (Table.Table (Index_Of (Op1)), Temp); 390 391 else 392 return 393 Lt (Table.Table (Index_Of (Op1)), 394 Table.Table (Index_Of (Op2))); 395 end if; 396 end Lower_Than; 397 398 -- Start of processing for Sort_Table 399 400 begin 401 Heap_Sort.Sort (Natural (Last (Table) - First) + 1); 402 end Sort_Table; 403 404end GNAT.Dynamic_Tables; 405