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