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-2010, 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 System; use System; 33with System.Memory; use System.Memory; 34 35with Ada.Unchecked_Conversion; 36 37package body GNAT.Table is 38 39 Min : constant Integer := Integer (Table_Low_Bound); 40 -- Subscript of the minimum entry in the currently allocated table 41 42 Max : Integer; 43 -- Subscript of the maximum entry in the currently allocated table 44 45 Length : Integer := 0; 46 -- Number of entries in currently allocated table. The value of zero 47 -- ensures that we initially allocate the table. 48 49 Last_Val : Integer; 50 -- Current value of Last 51 52 ----------------------- 53 -- Local Subprograms -- 54 ----------------------- 55 56 procedure Reallocate; 57 -- Reallocate the existing table according to the current value stored 58 -- in Max. Works correctly to do an initial allocation if the table 59 -- is currently null. 60 61 pragma Warnings (Off); 62 -- Turn off warnings. The following unchecked conversions are only used 63 -- internally in this package, and cannot never result in any instances 64 -- of improperly aliased pointers for the client of the package. 65 66 function To_Address is new Ada.Unchecked_Conversion (Table_Ptr, Address); 67 function To_Pointer is new Ada.Unchecked_Conversion (Address, Table_Ptr); 68 69 pragma Warnings (On); 70 71 -------------- 72 -- Allocate -- 73 -------------- 74 75 function Allocate (Num : Integer := 1) return Table_Index_Type is 76 Old_Last : constant Integer := Last_Val; 77 78 begin 79 Last_Val := Last_Val + Num; 80 81 if Last_Val > Max then 82 Reallocate; 83 end if; 84 85 return Table_Index_Type (Old_Last + 1); 86 end Allocate; 87 88 ------------ 89 -- Append -- 90 ------------ 91 92 procedure Append (New_Val : Table_Component_Type) is 93 begin 94 Set_Item (Table_Index_Type (Last_Val + 1), New_Val); 95 end Append; 96 97 ---------------- 98 -- Append_All -- 99 ---------------- 100 101 procedure Append_All (New_Vals : Table_Type) is 102 begin 103 for J in New_Vals'Range loop 104 Append (New_Vals (J)); 105 end loop; 106 end Append_All; 107 108 -------------------- 109 -- Decrement_Last -- 110 -------------------- 111 112 procedure Decrement_Last is 113 begin 114 Last_Val := Last_Val - 1; 115 end Decrement_Last; 116 117 ---------- 118 -- Free -- 119 ---------- 120 121 procedure Free is 122 begin 123 Free (To_Address (Table)); 124 Table := null; 125 Length := 0; 126 end Free; 127 128 -------------------- 129 -- Increment_Last -- 130 -------------------- 131 132 procedure Increment_Last is 133 begin 134 Last_Val := Last_Val + 1; 135 136 if Last_Val > Max then 137 Reallocate; 138 end if; 139 end Increment_Last; 140 141 ---------- 142 -- Init -- 143 ---------- 144 145 procedure Init is 146 Old_Length : constant Integer := Length; 147 148 begin 149 Last_Val := Min - 1; 150 Max := Min + Table_Initial - 1; 151 Length := Max - Min + 1; 152 153 -- If table is same size as before (happens when table is never 154 -- expanded which is a common case), then simply reuse it. Note 155 -- that this also means that an explicit Init call right after 156 -- the implicit one in the package body is harmless. 157 158 if Old_Length = Length then 159 return; 160 161 -- Otherwise we can use Reallocate to get a table of the right size. 162 -- Note that Reallocate works fine to allocate a table of the right 163 -- initial size when it is first allocated. 164 165 else 166 Reallocate; 167 end if; 168 end Init; 169 170 ---------- 171 -- Last -- 172 ---------- 173 174 function Last return Table_Index_Type is 175 begin 176 return Table_Index_Type (Last_Val); 177 end Last; 178 179 ---------------- 180 -- Reallocate -- 181 ---------------- 182 183 procedure Reallocate is 184 New_Size : size_t; 185 186 begin 187 if Max < Last_Val then 188 pragma Assert (not Locked); 189 190 while Max < Last_Val loop 191 192 -- Increase length using the table increment factor, but make 193 -- sure that we add at least ten elements (this avoids a loop 194 -- for silly small increment values) 195 196 Length := Integer'Max 197 (Length * (100 + Table_Increment) / 100, 198 Length + 10); 199 Max := Min + Length - 1; 200 end loop; 201 end if; 202 203 New_Size := 204 size_t ((Max - Min + 1) * 205 (Table_Type'Component_Size / Storage_Unit)); 206 207 if Table = null then 208 Table := To_Pointer (Alloc (New_Size)); 209 210 elsif New_Size > 0 then 211 Table := 212 To_Pointer (Realloc (Ptr => To_Address (Table), 213 Size => New_Size)); 214 end if; 215 216 if Length /= 0 and then Table = null then 217 raise Storage_Error; 218 end if; 219 220 end Reallocate; 221 222 ------------- 223 -- Release -- 224 ------------- 225 226 procedure Release is 227 begin 228 Length := Last_Val - Integer (Table_Low_Bound) + 1; 229 Max := Last_Val; 230 Reallocate; 231 end Release; 232 233 -------------- 234 -- Set_Item -- 235 -------------- 236 237 procedure Set_Item 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 (Table'First .. Table_Index_Type (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 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 263 -- one element (the supplementary element is used to have a 264 -- convenient way of computing the address just past the end of the 265 -- current allocation). Range checks are suppressed because this unit 266 -- uses direct calls to System.Memory for allocation, and this can 267 -- yield misaligned storage (and we cannot rely on the bootstrap 268 -- compiler supporting specifically disabling alignment checks, so we 269 -- need to suppress all range checks). It is safe to suppress this check 270 -- here because we know that a (possibly misaligned) object of that type 271 -- does actually exist at that address. 272 -- ??? We should really improve the allocation circuitry here to 273 -- guarantee proper alignment. 274 275 Need_Realloc : constant Boolean := Integer (Index) > 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 (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 (Index); 295 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) > Last_Val then 303 Set_Last (Index); 304 end if; 305 306 Table (Index) := Item; 307 end if; 308 end Set_Item; 309 310 -------------- 311 -- Set_Last -- 312 -------------- 313 314 procedure Set_Last (New_Val : Table_Index_Type) is 315 begin 316 if Integer (New_Val) < Last_Val then 317 Last_Val := Integer (New_Val); 318 else 319 Last_Val := Integer (New_Val); 320 321 if Last_Val > Max then 322 Reallocate; 323 end if; 324 end if; 325 end Set_Last; 326 327begin 328 Init; 329end GNAT.Table; 330