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