1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME COMPONENTS -- 4-- -- 5-- S Y S T E M . H T A B L E -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1995-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 32pragma Compiler_Unit_Warning; 33 34with Ada.Unchecked_Deallocation; 35with System.String_Hash; 36 37package body System.HTable is 38 39 ------------------- 40 -- Static_HTable -- 41 ------------------- 42 43 package body Static_HTable is 44 45 Table : array (Header_Num) of Elmt_Ptr; 46 47 Iterator_Index : Header_Num; 48 Iterator_Ptr : Elmt_Ptr; 49 Iterator_Started : Boolean := False; 50 51 function Get_Non_Null return Elmt_Ptr; 52 -- Returns Null_Ptr if Iterator_Started is false or the Table is empty. 53 -- Returns Iterator_Ptr if non null, or the next non null element in 54 -- table if any. 55 56 --------- 57 -- Get -- 58 --------- 59 60 function Get (K : Key) return Elmt_Ptr is 61 Elmt : Elmt_Ptr; 62 63 begin 64 Elmt := Table (Hash (K)); 65 loop 66 if Elmt = Null_Ptr then 67 return Null_Ptr; 68 69 elsif Equal (Get_Key (Elmt), K) then 70 return Elmt; 71 72 else 73 Elmt := Next (Elmt); 74 end if; 75 end loop; 76 end Get; 77 78 --------------- 79 -- Get_First -- 80 --------------- 81 82 function Get_First return Elmt_Ptr is 83 begin 84 Iterator_Started := True; 85 Iterator_Index := Table'First; 86 Iterator_Ptr := Table (Iterator_Index); 87 return Get_Non_Null; 88 end Get_First; 89 90 -------------- 91 -- Get_Next -- 92 -------------- 93 94 function Get_Next return Elmt_Ptr is 95 begin 96 if not Iterator_Started then 97 return Null_Ptr; 98 else 99 Iterator_Ptr := Next (Iterator_Ptr); 100 return Get_Non_Null; 101 end if; 102 end Get_Next; 103 104 ------------------ 105 -- Get_Non_Null -- 106 ------------------ 107 108 function Get_Non_Null return Elmt_Ptr is 109 begin 110 while Iterator_Ptr = Null_Ptr loop 111 if Iterator_Index = Table'Last then 112 Iterator_Started := False; 113 return Null_Ptr; 114 end if; 115 116 Iterator_Index := Iterator_Index + 1; 117 Iterator_Ptr := Table (Iterator_Index); 118 end loop; 119 120 return Iterator_Ptr; 121 end Get_Non_Null; 122 123 ------------- 124 -- Present -- 125 ------------- 126 127 function Present (K : Key) return Boolean is 128 begin 129 return Get (K) /= Null_Ptr; 130 end Present; 131 132 ------------ 133 -- Remove -- 134 ------------ 135 136 procedure Remove (K : Key) is 137 Index : constant Header_Num := Hash (K); 138 Elmt : Elmt_Ptr; 139 Next_Elmt : Elmt_Ptr; 140 141 begin 142 Elmt := Table (Index); 143 144 if Elmt = Null_Ptr then 145 return; 146 147 elsif Equal (Get_Key (Elmt), K) then 148 Table (Index) := Next (Elmt); 149 150 else 151 loop 152 Next_Elmt := Next (Elmt); 153 154 if Next_Elmt = Null_Ptr then 155 return; 156 157 elsif Equal (Get_Key (Next_Elmt), K) then 158 Set_Next (Elmt, Next (Next_Elmt)); 159 return; 160 161 else 162 Elmt := Next_Elmt; 163 end if; 164 end loop; 165 end if; 166 end Remove; 167 168 ----------- 169 -- Reset -- 170 ----------- 171 172 procedure Reset is 173 begin 174 for J in Table'Range loop 175 Table (J) := Null_Ptr; 176 end loop; 177 end Reset; 178 179 --------- 180 -- Set -- 181 --------- 182 183 procedure Set (E : Elmt_Ptr) is 184 Index : Header_Num; 185 begin 186 Index := Hash (Get_Key (E)); 187 Set_Next (E, Table (Index)); 188 Table (Index) := E; 189 end Set; 190 191 ------------------------ 192 -- Set_If_Not_Present -- 193 ------------------------ 194 195 function Set_If_Not_Present (E : Elmt_Ptr) return Boolean is 196 K : Key renames Get_Key (E); 197 -- Note that it is important to use a renaming here rather than 198 -- define a constant initialized by the call, because the latter 199 -- construct runs into bootstrap problems with earlier versions 200 -- of the GNAT compiler. 201 202 Index : constant Header_Num := Hash (K); 203 Elmt : Elmt_Ptr; 204 205 begin 206 Elmt := Table (Index); 207 loop 208 if Elmt = Null_Ptr then 209 Set_Next (E, Table (Index)); 210 Table (Index) := E; 211 return True; 212 213 elsif Equal (Get_Key (Elmt), K) then 214 return False; 215 216 else 217 Elmt := Next (Elmt); 218 end if; 219 end loop; 220 end Set_If_Not_Present; 221 222 end Static_HTable; 223 224 ------------------- 225 -- Simple_HTable -- 226 ------------------- 227 228 package body Simple_HTable is 229 230 type Element_Wrapper; 231 type Elmt_Ptr is access all Element_Wrapper; 232 type Element_Wrapper is record 233 K : Key; 234 E : Element; 235 Next : Elmt_Ptr; 236 end record; 237 238 procedure Free is new 239 Ada.Unchecked_Deallocation (Element_Wrapper, Elmt_Ptr); 240 241 procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr); 242 function Next (E : Elmt_Ptr) return Elmt_Ptr; 243 function Get_Key (E : Elmt_Ptr) return Key; 244 245 package Tab is new Static_HTable ( 246 Header_Num => Header_Num, 247 Element => Element_Wrapper, 248 Elmt_Ptr => Elmt_Ptr, 249 Null_Ptr => null, 250 Set_Next => Set_Next, 251 Next => Next, 252 Key => Key, 253 Get_Key => Get_Key, 254 Hash => Hash, 255 Equal => Equal); 256 257 --------- 258 -- Get -- 259 --------- 260 261 function Get (K : Key) return Element is 262 Tmp : constant Elmt_Ptr := Tab.Get (K); 263 begin 264 if Tmp = null then 265 return No_Element; 266 else 267 return Tmp.E; 268 end if; 269 end Get; 270 271 --------------- 272 -- Get_First -- 273 --------------- 274 275 function Get_First return Element is 276 Tmp : constant Elmt_Ptr := Tab.Get_First; 277 begin 278 if Tmp = null then 279 return No_Element; 280 else 281 return Tmp.E; 282 end if; 283 end Get_First; 284 285 procedure Get_First (K : in out Key; E : out Element) is 286 Tmp : constant Elmt_Ptr := Tab.Get_First; 287 begin 288 if Tmp = null then 289 E := No_Element; 290 else 291 K := Tmp.K; 292 E := Tmp.E; 293 end if; 294 end Get_First; 295 296 ------------- 297 -- Get_Key -- 298 ------------- 299 300 function Get_Key (E : Elmt_Ptr) return Key is 301 begin 302 return E.K; 303 end Get_Key; 304 305 -------------- 306 -- Get_Next -- 307 -------------- 308 309 function Get_Next return Element is 310 Tmp : constant Elmt_Ptr := Tab.Get_Next; 311 begin 312 if Tmp = null then 313 return No_Element; 314 else 315 return Tmp.E; 316 end if; 317 end Get_Next; 318 319 procedure Get_Next (K : in out Key; E : out Element) is 320 Tmp : constant Elmt_Ptr := Tab.Get_Next; 321 begin 322 if Tmp = null then 323 E := No_Element; 324 else 325 K := Tmp.K; 326 E := Tmp.E; 327 end if; 328 end Get_Next; 329 330 ---------- 331 -- Next -- 332 ---------- 333 334 function Next (E : Elmt_Ptr) return Elmt_Ptr is 335 begin 336 return E.Next; 337 end Next; 338 339 ------------ 340 -- Remove -- 341 ------------ 342 343 procedure Remove (K : Key) is 344 Tmp : Elmt_Ptr; 345 346 begin 347 Tmp := Tab.Get (K); 348 349 if Tmp /= null then 350 Tab.Remove (K); 351 Free (Tmp); 352 end if; 353 end Remove; 354 355 ----------- 356 -- Reset -- 357 ----------- 358 359 procedure Reset is 360 E1, E2 : Elmt_Ptr; 361 362 begin 363 E1 := Tab.Get_First; 364 while E1 /= null loop 365 E2 := Tab.Get_Next; 366 Free (E1); 367 E1 := E2; 368 end loop; 369 370 Tab.Reset; 371 end Reset; 372 373 --------- 374 -- Set -- 375 --------- 376 377 procedure Set (K : Key; E : Element) is 378 Tmp : constant Elmt_Ptr := Tab.Get (K); 379 begin 380 if Tmp = null then 381 Tab.Set (new Element_Wrapper'(K, E, null)); 382 else 383 Tmp.E := E; 384 end if; 385 end Set; 386 387 -------------- 388 -- Set_Next -- 389 -------------- 390 391 procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr) is 392 begin 393 E.Next := Next; 394 end Set_Next; 395 end Simple_HTable; 396 397 ---------- 398 -- Hash -- 399 ---------- 400 401 function Hash (Key : String) return Header_Num is 402 type Uns is mod 2 ** 32; 403 404 function Hash_Fun is 405 new System.String_Hash.Hash (Character, String, Uns); 406 407 begin 408 return Header_Num'First + 409 Header_Num'Base (Hash_Fun (Key) mod Header_Num'Range_Length); 410 end Hash; 411 412end System.HTable; 413