1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUNTIME 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-2002 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 Ada.Unchecked_Deallocation; 35 36package body System.HTable is 37 38 -------------------- 39 -- Static_HTable -- 40 -------------------- 41 42 package body Static_HTable is 43 44 Table : array (Header_Num) of Elmt_Ptr; 45 46 Iterator_Index : Header_Num; 47 Iterator_Ptr : Elmt_Ptr; 48 Iterator_Started : Boolean := False; 49 50 function Get_Non_Null return Elmt_Ptr; 51 -- Returns Null_Ptr if Iterator_Started is false of the Table is 52 -- empty. Returns Iterator_Ptr if non null, or the next non null 53 -- element in table if any. 54 55 --------- 56 -- Get -- 57 --------- 58 59 function Get (K : Key) return Elmt_Ptr is 60 Elmt : Elmt_Ptr; 61 62 begin 63 Elmt := Table (Hash (K)); 64 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 end if; 99 100 Iterator_Ptr := Next (Iterator_Ptr); 101 return Get_Non_Null; 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 -- Remove -- 125 ------------ 126 127 procedure Remove (K : Key) is 128 Index : constant Header_Num := Hash (K); 129 Elmt : Elmt_Ptr; 130 Next_Elmt : Elmt_Ptr; 131 132 begin 133 Elmt := Table (Index); 134 135 if Elmt = Null_Ptr then 136 return; 137 138 elsif Equal (Get_Key (Elmt), K) then 139 Table (Index) := Next (Elmt); 140 141 else 142 loop 143 Next_Elmt := Next (Elmt); 144 145 if Next_Elmt = Null_Ptr then 146 return; 147 148 elsif Equal (Get_Key (Next_Elmt), K) then 149 Set_Next (Elmt, Next (Next_Elmt)); 150 return; 151 152 else 153 Elmt := Next_Elmt; 154 end if; 155 end loop; 156 end if; 157 end Remove; 158 159 ----------- 160 -- Reset -- 161 ----------- 162 163 procedure Reset is 164 begin 165 for J in Table'Range loop 166 Table (J) := Null_Ptr; 167 end loop; 168 end Reset; 169 170 --------- 171 -- Set -- 172 --------- 173 174 procedure Set (E : Elmt_Ptr) is 175 Index : Header_Num; 176 177 begin 178 Index := Hash (Get_Key (E)); 179 Set_Next (E, Table (Index)); 180 Table (Index) := E; 181 end Set; 182 183 end Static_HTable; 184 185 -------------------- 186 -- Simple_HTable -- 187 -------------------- 188 189 package body Simple_HTable is 190 191 type Element_Wrapper; 192 type Elmt_Ptr is access all Element_Wrapper; 193 type Element_Wrapper is record 194 K : Key; 195 E : Element; 196 Next : Elmt_Ptr; 197 end record; 198 199 procedure Free is new 200 Ada.Unchecked_Deallocation (Element_Wrapper, Elmt_Ptr); 201 202 procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr); 203 function Next (E : Elmt_Ptr) return Elmt_Ptr; 204 function Get_Key (E : Elmt_Ptr) return Key; 205 206 package Tab is new Static_HTable ( 207 Header_Num => Header_Num, 208 Element => Element_Wrapper, 209 Elmt_Ptr => Elmt_Ptr, 210 Null_Ptr => null, 211 Set_Next => Set_Next, 212 Next => Next, 213 Key => Key, 214 Get_Key => Get_Key, 215 Hash => Hash, 216 Equal => Equal); 217 218 --------- 219 -- Get -- 220 --------- 221 222 function Get (K : Key) return Element is 223 Tmp : constant Elmt_Ptr := Tab.Get (K); 224 225 begin 226 if Tmp = null then 227 return No_Element; 228 else 229 return Tmp.E; 230 end if; 231 end Get; 232 233 --------------- 234 -- Get_First -- 235 --------------- 236 237 function Get_First return Element is 238 Tmp : constant Elmt_Ptr := Tab.Get_First; 239 240 begin 241 if Tmp = null then 242 return No_Element; 243 else 244 return Tmp.E; 245 end if; 246 end Get_First; 247 248 ------------- 249 -- Get_Key -- 250 ------------- 251 252 function Get_Key (E : Elmt_Ptr) return Key is 253 begin 254 return E.K; 255 end Get_Key; 256 257 -------------- 258 -- Get_Next -- 259 -------------- 260 261 function Get_Next return Element is 262 Tmp : constant Elmt_Ptr := Tab.Get_Next; 263 264 begin 265 if Tmp = null then 266 return No_Element; 267 else 268 return Tmp.E; 269 end if; 270 end Get_Next; 271 272 ---------- 273 -- Next -- 274 ---------- 275 276 function Next (E : Elmt_Ptr) return Elmt_Ptr is 277 begin 278 return E.Next; 279 end Next; 280 281 ------------ 282 -- Remove -- 283 ------------ 284 285 procedure Remove (K : Key) is 286 Tmp : Elmt_Ptr; 287 288 begin 289 Tmp := Tab.Get (K); 290 291 if Tmp /= null then 292 Tab.Remove (K); 293 Free (Tmp); 294 end if; 295 end Remove; 296 297 ----------- 298 -- Reset -- 299 ----------- 300 301 procedure Reset is 302 E1, E2 : Elmt_Ptr; 303 304 begin 305 E1 := Tab.Get_First; 306 while E1 /= null loop 307 E2 := Tab.Get_Next; 308 Free (E1); 309 E1 := E2; 310 end loop; 311 312 Tab.Reset; 313 end Reset; 314 315 --------- 316 -- Set -- 317 --------- 318 319 procedure Set (K : Key; E : Element) is 320 Tmp : constant Elmt_Ptr := Tab.Get (K); 321 322 begin 323 if Tmp = null then 324 Tab.Set (new Element_Wrapper'(K, E, null)); 325 else 326 Tmp.E := E; 327 end if; 328 end Set; 329 330 -------------- 331 -- Set_Next -- 332 -------------- 333 334 procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr) is 335 begin 336 E.Next := Next; 337 end Set_Next; 338 end Simple_HTable; 339 340 ---------- 341 -- Hash -- 342 ---------- 343 344 function Hash (Key : String) return Header_Num is 345 346 type Uns is mod 2 ** 32; 347 348 function Rotate_Left (Value : Uns; Amount : Natural) return Uns; 349 pragma Import (Intrinsic, Rotate_Left); 350 351 Tmp : Uns := 0; 352 353 begin 354 for J in Key'Range loop 355 Tmp := Rotate_Left (Tmp, 1) + Character'Pos (Key (J)); 356 end loop; 357 358 return Header_Num'First + 359 Header_Num'Base (Tmp mod Header_Num'Range_Length); 360 end Hash; 361 362end System.HTable; 363