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-2003 Ada Core Technologies, Inc. -- 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 2, 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. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING. If not, write -- 19-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- 20-- MA 02111-1307, USA. -- 21-- -- 22-- As a special exception, if other files instantiate generics from this -- 23-- unit, or you link this unit with other files to produce an executable, -- 24-- this unit does not by itself cause the resulting executable to be -- 25-- covered by the GNU General Public License. This exception does not -- 26-- however invalidate any other reasons why the executable file might be -- 27-- covered by the GNU Public License. -- 28-- -- 29-- GNAT was originally developed by the GNAT team at New York University. -- 30-- Extensive contributions were provided by Ada Core Technologies Inc. -- 31-- -- 32------------------------------------------------------------------------------ 33 34with GNAT.Heap_Sort_G; 35with System; use System; 36with System.Memory; use System.Memory; 37 38with 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 function To_Address is new Unchecked_Conversion (Table_Ptr, Address); 55 function To_Pointer is new Unchecked_Conversion (Address, Table_Ptr); 56 57 -------------- 58 -- Allocate -- 59 -------------- 60 61 procedure Allocate 62 (T : in out Instance; 63 Num : Integer := 1) 64 is 65 begin 66 T.P.Last_Val := T.P.Last_Val + Num; 67 68 if T.P.Last_Val > T.P.Max then 69 Reallocate (T); 70 end if; 71 end Allocate; 72 73 ------------ 74 -- Append -- 75 ------------ 76 77 procedure Append (T : in out Instance; New_Val : Table_Component_Type) is 78 begin 79 Increment_Last (T); 80 T.Table (Table_Index_Type (T.P.Last_Val)) := New_Val; 81 end Append; 82 83 -------------------- 84 -- Decrement_Last -- 85 -------------------- 86 87 procedure Decrement_Last (T : in out Instance) is 88 begin 89 T.P.Last_Val := T.P.Last_Val - 1; 90 end Decrement_Last; 91 92 -------------- 93 -- For_Each -- 94 -------------- 95 96 procedure For_Each (Table : Instance) is 97 Quit : Boolean := False; 98 begin 99 for Index in Table_Low_Bound .. Table_Index_Type (Table.P.Last_Val) loop 100 Action (Index, Table.Table (Index), Quit); 101 exit when Quit; 102 end loop; 103 end For_Each; 104 105 ---------- 106 -- Free -- 107 ---------- 108 109 procedure Free (T : in out Instance) is 110 begin 111 Free (To_Address (T.Table)); 112 T.Table := null; 113 T.P.Length := 0; 114 end Free; 115 116 -------------------- 117 -- Increment_Last -- 118 -------------------- 119 120 procedure Increment_Last (T : in out Instance) is 121 begin 122 T.P.Last_Val := T.P.Last_Val + 1; 123 124 if T.P.Last_Val > T.P.Max then 125 Reallocate (T); 126 end if; 127 end Increment_Last; 128 129 ---------- 130 -- Init -- 131 ---------- 132 133 procedure Init (T : in out Instance) is 134 Old_Length : constant Integer := T.P.Length; 135 136 begin 137 T.P.Last_Val := Min - 1; 138 T.P.Max := Min + Table_Initial - 1; 139 T.P.Length := T.P.Max - Min + 1; 140 141 -- If table is same size as before (happens when table is never 142 -- expanded which is a common case), then simply reuse it. Note 143 -- that this also means that an explicit Init call right after 144 -- the implicit one in the package body is harmless. 145 146 if Old_Length = T.P.Length then 147 return; 148 149 -- Otherwise we can use Reallocate to get a table of the right size. 150 -- Note that Reallocate works fine to allocate a table of the right 151 -- initial size when it is first allocated. 152 153 else 154 Reallocate (T); 155 end if; 156 end Init; 157 158 ---------- 159 -- Last -- 160 ---------- 161 162 function Last (T : in Instance) return Table_Index_Type is 163 begin 164 return Table_Index_Type (T.P.Last_Val); 165 end Last; 166 167 ---------------- 168 -- Reallocate -- 169 ---------------- 170 171 procedure Reallocate (T : in out Instance) is 172 New_Length : Integer; 173 New_Size : size_t; 174 175 begin 176 if T.P.Max < T.P.Last_Val then 177 while T.P.Max < T.P.Last_Val loop 178 New_Length := T.P.Length * (100 + Table_Increment) / 100; 179 180 if New_Length > T.P.Length then 181 T.P.Length := New_Length; 182 else 183 T.P.Length := T.P.Length + 1; 184 end if; 185 186 T.P.Max := Min + T.P.Length - 1; 187 end loop; 188 end if; 189 190 New_Size := 191 size_t ((T.P.Max - Min + 1) * 192 (Table_Type'Component_Size / Storage_Unit)); 193 194 if T.Table = null then 195 T.Table := To_Pointer (Alloc (New_Size)); 196 197 elsif New_Size > 0 then 198 T.Table := 199 To_Pointer (Realloc (Ptr => To_Address (T.Table), 200 Size => New_Size)); 201 end if; 202 203 if T.P.Length /= 0 and then T.Table = null then 204 raise Storage_Error; 205 end if; 206 end Reallocate; 207 208 ------------- 209 -- Release -- 210 ------------- 211 212 procedure Release (T : in out Instance) is 213 begin 214 T.P.Length := T.P.Last_Val - Integer (Table_Low_Bound) + 1; 215 T.P.Max := T.P.Last_Val; 216 Reallocate (T); 217 end Release; 218 219 -------------- 220 -- Set_Item -- 221 -------------- 222 223 procedure Set_Item 224 (T : in out Instance; 225 Index : Table_Index_Type; 226 Item : Table_Component_Type) 227 is 228 begin 229 if Integer (Index) > T.P.Last_Val then 230 Set_Last (T, Index); 231 end if; 232 233 T.Table (Index) := Item; 234 end Set_Item; 235 236 -------------- 237 -- Set_Last -- 238 -------------- 239 240 procedure Set_Last (T : in out Instance; New_Val : Table_Index_Type) is 241 begin 242 if Integer (New_Val) < T.P.Last_Val then 243 T.P.Last_Val := Integer (New_Val); 244 245 else 246 T.P.Last_Val := Integer (New_Val); 247 248 if T.P.Last_Val > T.P.Max then 249 Reallocate (T); 250 end if; 251 end if; 252 end Set_Last; 253 254 ---------------- 255 -- Sort_Table -- 256 ---------------- 257 258 procedure Sort_Table (Table : in out Instance) is 259 260 Temp : Table_Component_Type; 261 -- A temporary position to simulate index 0 262 263 -- Local subprograms 264 265 function Index_Of (Idx : Natural) return Table_Index_Type; 266 -- Apply Natural to indexs of the table 267 268 function Lower_Than (Op1, Op2 : Natural) return Boolean; 269 -- Compare two components 270 271 procedure Move (From : Natural; To : Natural); 272 -- Move one component 273 274 package Heap_Sort is new GNAT.Heap_Sort_G (Move, Lower_Than); 275 276 -------------- 277 -- Index_Of -- 278 -------------- 279 280 function Index_Of (Idx : Natural) return Table_Index_Type is 281 begin 282 return First + Table_Index_Type (Idx) - 1; 283 end Index_Of; 284 285 ---------- 286 -- Move -- 287 ---------- 288 289 procedure Move (From : Natural; To : Natural) is 290 begin 291 if From = 0 then 292 Table.Table (Index_Of (To)) := Temp; 293 294 elsif To = 0 then 295 Temp := Table.Table (Index_Of (From)); 296 297 else 298 Table.Table (Index_Of (To)) := 299 Table.Table (Index_Of (From)); 300 end if; 301 end Move; 302 303 ---------------- 304 -- Lower_Than -- 305 ---------------- 306 307 function Lower_Than (Op1, Op2 : Natural) return Boolean is 308 begin 309 if Op1 = 0 then 310 return Lt (Temp, Table.Table (Index_Of (Op2))); 311 312 elsif Op2 = 0 then 313 return Lt (Table.Table (Index_Of (Op1)), Temp); 314 315 else 316 return 317 Lt (Table.Table (Index_Of (Op1)), 318 Table.Table (Index_Of (Op2))); 319 end if; 320 end Lower_Than; 321 322 -- Start of processing for Sort_Table 323 324 begin 325 326 Heap_Sort.Sort (Natural (Last (Table) - First) + 1); 327 328 end Sort_Table; 329 330end GNAT.Dynamic_Tables; 331