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-2018, 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; 35 36with Ada.Unchecked_Deallocation; 37with System; 38 39package body GNAT.Dynamic_Tables is 40 41 ----------------------- 42 -- Local Subprograms -- 43 ----------------------- 44 45 function Last_Allocated (T : Instance) return Table_Last_Type; 46 pragma Inline (Last_Allocated); 47 -- Return the index of the last allocated element 48 49 procedure Grow (T : in out Instance; New_Last : Table_Last_Type); 50 -- This is called when we are about to set the value of Last to a value 51 -- that is larger than Last_Allocated. This reallocates the table to the 52 -- larger size, as indicated by New_Last. At the time this is called, 53 -- Last (T) is still the old value, and this does not modify it. 54 55 -------------- 56 -- Allocate -- 57 -------------- 58 59 procedure Allocate (T : in out Instance; Num : Integer := 1) is 60 begin 61 -- Note that Num can be negative 62 63 pragma Assert (not T.Locked); 64 Set_Last (T, Last (T) + Table_Index_Type'Base (Num)); 65 end Allocate; 66 67 ------------ 68 -- Append -- 69 ------------ 70 71 procedure Append (T : in out Instance; New_Val : Table_Component_Type) is 72 pragma Assert (not T.Locked); 73 New_Last : constant Table_Last_Type := Last (T) + 1; 74 75 begin 76 if New_Last <= Last_Allocated (T) then 77 78 -- Fast path 79 80 T.P.Last := New_Last; 81 T.Table (New_Last) := New_Val; 82 83 else 84 Set_Item (T, New_Last, New_Val); 85 end if; 86 end Append; 87 88 ---------------- 89 -- Append_All -- 90 ---------------- 91 92 procedure Append_All (T : in out Instance; New_Vals : Table_Type) is 93 begin 94 for J in New_Vals'Range loop 95 Append (T, New_Vals (J)); 96 end loop; 97 end Append_All; 98 99 -------------------- 100 -- Decrement_Last -- 101 -------------------- 102 103 procedure Decrement_Last (T : in out Instance) is 104 begin 105 pragma Assert (not T.Locked); 106 Allocate (T, -1); 107 end Decrement_Last; 108 109 ----------- 110 -- First -- 111 ----------- 112 113 function First return Table_Index_Type is 114 begin 115 return Table_Low_Bound; 116 end First; 117 118 -------------- 119 -- For_Each -- 120 -------------- 121 122 procedure For_Each (Table : Instance) is 123 Quit : Boolean := False; 124 begin 125 for Index in First .. Last (Table) loop 126 Action (Index, Table.Table (Index), Quit); 127 exit when Quit; 128 end loop; 129 end For_Each; 130 131 ---------- 132 -- Grow -- 133 ---------- 134 135 procedure Grow (T : in out Instance; New_Last : Table_Last_Type) is 136 137 -- Note: Type Alloc_Ptr below needs to be declared locally so we know 138 -- the bounds. That means that the collection is local, so is finalized 139 -- when leaving Grow. That's why this package doesn't support controlled 140 -- types; the table elements would be finalized prematurely. An Ada 141 -- implementation would also be within its rights to reclaim the 142 -- storage. Fortunately, GNAT doesn't do that. 143 144 pragma Assert (not T.Locked); 145 pragma Assert (New_Last > Last_Allocated (T)); 146 147 subtype Table_Length_Type is Table_Index_Type'Base 148 range 0 .. Table_Index_Type'Base'Last; 149 150 Old_Last_Allocated : constant Table_Last_Type := Last_Allocated (T); 151 Old_Allocated_Length : constant Table_Length_Type := 152 Old_Last_Allocated - First + 1; 153 154 New_Length : constant Table_Length_Type := New_Last - First + 1; 155 New_Allocated_Length : Table_Length_Type; 156 157 begin 158 if T.Table = Empty_Table_Ptr then 159 New_Allocated_Length := Table_Length_Type (Table_Initial); 160 else 161 New_Allocated_Length := 162 Table_Length_Type 163 (Long_Long_Integer (Old_Allocated_Length) * 164 (100 + Long_Long_Integer (Table_Increment)) / 100); 165 end if; 166 167 -- Make sure it really did grow 168 169 if New_Allocated_Length <= Old_Allocated_Length then 170 New_Allocated_Length := Old_Allocated_Length + 10; 171 end if; 172 173 if New_Allocated_Length <= New_Length then 174 New_Allocated_Length := New_Length + 10; 175 end if; 176 177 pragma Assert (New_Allocated_Length > Old_Allocated_Length); 178 pragma Assert (New_Allocated_Length > New_Length); 179 180 T.P.Last_Allocated := First + New_Allocated_Length - 1; 181 182 declare 183 subtype Old_Alloc_Type is Table_Type (First .. Old_Last_Allocated); 184 type Old_Alloc_Ptr is access all Old_Alloc_Type; 185 186 procedure Free is 187 new Ada.Unchecked_Deallocation (Old_Alloc_Type, Old_Alloc_Ptr); 188 function To_Old_Alloc_Ptr is 189 new Ada.Unchecked_Conversion (Table_Ptr, Old_Alloc_Ptr); 190 191 subtype Alloc_Type is 192 Table_Type (First .. First + New_Allocated_Length - 1); 193 type Alloc_Ptr is access all Alloc_Type; 194 195 function To_Table_Ptr is 196 new Ada.Unchecked_Conversion (Alloc_Ptr, Table_Ptr); 197 198 Old_Table : Old_Alloc_Ptr := To_Old_Alloc_Ptr (T.Table); 199 New_Table : constant Alloc_Ptr := new Alloc_Type; 200 201 begin 202 if T.Table /= Empty_Table_Ptr then 203 New_Table (First .. Last (T)) := Old_Table (First .. Last (T)); 204 Free (Old_Table); 205 end if; 206 207 T.Table := To_Table_Ptr (New_Table); 208 end; 209 210 pragma Assert (New_Last <= Last_Allocated (T)); 211 pragma Assert (T.Table /= null); 212 pragma Assert (T.Table /= Empty_Table_Ptr); 213 end Grow; 214 215 -------------------- 216 -- Increment_Last -- 217 -------------------- 218 219 procedure Increment_Last (T : in out Instance) is 220 begin 221 pragma Assert (not T.Locked); 222 Allocate (T, 1); 223 end Increment_Last; 224 225 ---------- 226 -- Init -- 227 ---------- 228 229 procedure Init (T : in out Instance) is 230 pragma Assert (not T.Locked); 231 subtype Alloc_Type is Table_Type (First .. Last_Allocated (T)); 232 type Alloc_Ptr is access all Alloc_Type; 233 234 procedure Free is new Ada.Unchecked_Deallocation (Alloc_Type, Alloc_Ptr); 235 function To_Alloc_Ptr is 236 new Ada.Unchecked_Conversion (Table_Ptr, Alloc_Ptr); 237 238 Temp : Alloc_Ptr := To_Alloc_Ptr (T.Table); 239 240 begin 241 if T.Table = Empty_Table_Ptr then 242 pragma Assert (T.P = (Last_Allocated | Last => First - 1)); 243 null; 244 else 245 Free (Temp); 246 T.Table := Empty_Table_Ptr; 247 T.P := (Last_Allocated | Last => First - 1); 248 end if; 249 end Init; 250 251 -------------- 252 -- Is_Empty -- 253 -------------- 254 255 function Is_Empty (T : Instance) return Boolean is 256 begin 257 return Last (T) = First - 1; 258 end Is_Empty; 259 260 ---------- 261 -- Last -- 262 ---------- 263 264 function Last (T : Instance) return Table_Last_Type is 265 begin 266 return T.P.Last; 267 end Last; 268 269 -------------------- 270 -- Last_Allocated -- 271 -------------------- 272 273 function Last_Allocated (T : Instance) return Table_Last_Type is 274 begin 275 return T.P.Last_Allocated; 276 end Last_Allocated; 277 278 ---------- 279 -- Move -- 280 ---------- 281 282 procedure Move (From, To : in out Instance) is 283 begin 284 pragma Assert (not From.Locked); 285 pragma Assert (not To.Locked); 286 pragma Assert (Is_Empty (To)); 287 To := From; 288 289 From.Table := Empty_Table_Ptr; 290 From.Locked := False; 291 From.P.Last_Allocated := First - 1; 292 From.P.Last := First - 1; 293 pragma Assert (Is_Empty (From)); 294 end Move; 295 296 ------------- 297 -- Release -- 298 ------------- 299 300 procedure Release (T : in out Instance) is 301 pragma Assert (not T.Locked); 302 Old_Last_Allocated : constant Table_Last_Type := Last_Allocated (T); 303 304 function New_Last_Allocated return Table_Last_Type; 305 -- Compute the new value of Last_Allocated. This is normally equal to 306 -- Last, but if Release_Threshold /= 0, then we need to take that into 307 -- account. 308 309 ------------------------ 310 -- New_Last_Allocated -- 311 ------------------------ 312 313 function New_Last_Allocated return Table_Last_Type is 314 subtype Table_Length_Type is Table_Index_Type'Base 315 range 0 .. Table_Index_Type'Base'Last; 316 317 Length : constant Table_Length_Type := Last (T) - First + 1; 318 319 Comp_Size_In_Bytes : constant Table_Length_Type := 320 Table_Type'Component_Size / System.Storage_Unit; 321 322 Length_Threshold : constant Table_Length_Type := 323 Table_Length_Type (Release_Threshold) / Comp_Size_In_Bytes; 324 325 begin 326 if Release_Threshold = 0 or else Length < Length_Threshold then 327 return Last (T); 328 else 329 declare 330 Extra_Length : constant Table_Length_Type := Length / 1000; 331 begin 332 return (Length + Extra_Length) - 1 + First; 333 end; 334 end if; 335 end New_Last_Allocated; 336 337 -- Local variables 338 339 New_Last_Alloc : constant Table_Last_Type := New_Last_Allocated; 340 341 -- Start of processing for Release 342 343 begin 344 if New_Last_Alloc < Last_Allocated (T) then 345 pragma Assert (Last (T) < Last_Allocated (T)); 346 pragma Assert (T.Table /= Empty_Table_Ptr); 347 348 declare 349 subtype Old_Alloc_Type is Table_Type (First .. Old_Last_Allocated); 350 type Old_Alloc_Ptr is access all Old_Alloc_Type; 351 352 procedure Free is 353 new Ada.Unchecked_Deallocation (Old_Alloc_Type, Old_Alloc_Ptr); 354 function To_Old_Alloc_Ptr is 355 new Ada.Unchecked_Conversion (Table_Ptr, Old_Alloc_Ptr); 356 357 subtype Alloc_Type is Table_Type (First .. New_Last_Alloc); 358 type Alloc_Ptr is access all Alloc_Type; 359 360 function To_Table_Ptr is 361 new Ada.Unchecked_Conversion (Alloc_Ptr, Table_Ptr); 362 363 Old_Table : Old_Alloc_Ptr := To_Old_Alloc_Ptr (T.Table); 364 New_Table : constant Alloc_Ptr := new Alloc_Type; 365 366 begin 367 New_Table (First .. Last (T)) := Old_Table (First .. Last (T)); 368 T.P.Last_Allocated := New_Last_Alloc; 369 Free (Old_Table); 370 T.Table := To_Table_Ptr (New_Table); 371 end; 372 end if; 373 end Release; 374 375 -------------- 376 -- Set_Item -- 377 -------------- 378 379 procedure Set_Item 380 (T : in out Instance; 381 Index : Valid_Table_Index_Type; 382 Item : Table_Component_Type) 383 is 384 begin 385 pragma Assert (not T.Locked); 386 387 -- If Set_Last is going to reallocate the table, we make a copy of Item, 388 -- in case the call was "Set_Item (T, X, T.Table (Y));", and Item is 389 -- passed by reference. Without the copy, we would deallocate the array 390 -- containing Item, leaving a dangling pointer. 391 392 if Index > Last_Allocated (T) then 393 declare 394 Item_Copy : constant Table_Component_Type := Item; 395 begin 396 Set_Last (T, Index); 397 T.Table (Index) := Item_Copy; 398 end; 399 400 else 401 if Index > Last (T) then 402 Set_Last (T, Index); 403 end if; 404 405 T.Table (Index) := Item; 406 end if; 407 end Set_Item; 408 409 -------------- 410 -- Set_Last -- 411 -------------- 412 413 procedure Set_Last (T : in out Instance; New_Val : Table_Last_Type) is 414 begin 415 pragma Assert (not T.Locked); 416 if New_Val > Last_Allocated (T) then 417 Grow (T, New_Val); 418 end if; 419 420 T.P.Last := New_Val; 421 end Set_Last; 422 423 ---------------- 424 -- Sort_Table -- 425 ---------------- 426 427 procedure Sort_Table (Table : in out Instance) is 428 Temp : Table_Component_Type; 429 -- A temporary position to simulate index 0 430 431 -- Local subprograms 432 433 function Index_Of (Idx : Natural) return Table_Index_Type'Base; 434 -- Return index of Idx'th element of table 435 436 function Lower_Than (Op1, Op2 : Natural) return Boolean; 437 -- Compare two components 438 439 procedure Move (From : Natural; To : Natural); 440 -- Move one component 441 442 package Heap_Sort is new GNAT.Heap_Sort_G (Move, Lower_Than); 443 444 -------------- 445 -- Index_Of -- 446 -------------- 447 448 function Index_Of (Idx : Natural) return Table_Index_Type'Base is 449 J : constant Integer'Base := 450 Table_Index_Type'Base'Pos (First) + Idx - 1; 451 begin 452 return Table_Index_Type'Base'Val (J); 453 end Index_Of; 454 455 ---------- 456 -- Move -- 457 ---------- 458 459 procedure Move (From : Natural; To : Natural) is 460 begin 461 if From = 0 then 462 Table.Table (Index_Of (To)) := Temp; 463 464 elsif To = 0 then 465 Temp := Table.Table (Index_Of (From)); 466 467 else 468 Table.Table (Index_Of (To)) := 469 Table.Table (Index_Of (From)); 470 end if; 471 end Move; 472 473 ---------------- 474 -- Lower_Than -- 475 ---------------- 476 477 function Lower_Than (Op1, Op2 : Natural) return Boolean is 478 begin 479 if Op1 = 0 then 480 return Lt (Temp, Table.Table (Index_Of (Op2))); 481 482 elsif Op2 = 0 then 483 return Lt (Table.Table (Index_Of (Op1)), Temp); 484 485 else 486 return 487 Lt (Table.Table (Index_Of (Op1)), Table.Table (Index_Of (Op2))); 488 end if; 489 end Lower_Than; 490 491 -- Start of processing for Sort_Table 492 493 begin 494 Heap_Sort.Sort (Natural (Last (Table) - First) + 1); 495 end Sort_Table; 496 497end GNAT.Dynamic_Tables; 498