1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME COMPONENTS -- 4-- -- 5-- G N A T . D Y N A M I C _ H T A B L E S -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2002-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 32package body GNAT.Dynamic_HTables is 33 34 ------------------- 35 -- Static_HTable -- 36 ------------------- 37 38 package body Static_HTable is 39 40 type Table_Type is array (Header_Num) of Elmt_Ptr; 41 42 type Instance_Data is record 43 Table : Table_Type; 44 Iterator_Index : Header_Num; 45 Iterator_Ptr : Elmt_Ptr; 46 Iterator_Started : Boolean := False; 47 end record; 48 49 function Get_Non_Null (T : Instance) return Elmt_Ptr; 50 -- Returns Null_Ptr if Iterator_Started is False or if the Table is 51 -- empty. Returns Iterator_Ptr if non null, or the next non null 52 -- element in table if any. 53 54 --------- 55 -- Get -- 56 --------- 57 58 function Get (T : Instance; K : Key) return Elmt_Ptr is 59 Elmt : Elmt_Ptr; 60 61 begin 62 if T = null then 63 return Null_Ptr; 64 end if; 65 66 Elmt := T.Table (Hash (K)); 67 68 loop 69 if Elmt = Null_Ptr then 70 return Null_Ptr; 71 72 elsif Equal (Get_Key (Elmt), K) then 73 return Elmt; 74 75 else 76 Elmt := Next (Elmt); 77 end if; 78 end loop; 79 end Get; 80 81 --------------- 82 -- Get_First -- 83 --------------- 84 85 function Get_First (T : Instance) return Elmt_Ptr is 86 begin 87 if T = null then 88 return Null_Ptr; 89 end if; 90 91 T.Iterator_Started := True; 92 T.Iterator_Index := T.Table'First; 93 T.Iterator_Ptr := T.Table (T.Iterator_Index); 94 return Get_Non_Null (T); 95 end Get_First; 96 97 -------------- 98 -- Get_Next -- 99 -------------- 100 101 function Get_Next (T : Instance) return Elmt_Ptr is 102 begin 103 if T = null or else not T.Iterator_Started then 104 return Null_Ptr; 105 end if; 106 107 T.Iterator_Ptr := Next (T.Iterator_Ptr); 108 return Get_Non_Null (T); 109 end Get_Next; 110 111 ------------------ 112 -- Get_Non_Null -- 113 ------------------ 114 115 function Get_Non_Null (T : Instance) return Elmt_Ptr is 116 begin 117 if T = null then 118 return Null_Ptr; 119 end if; 120 121 while T.Iterator_Ptr = Null_Ptr loop 122 if T.Iterator_Index = T.Table'Last then 123 T.Iterator_Started := False; 124 return Null_Ptr; 125 end if; 126 127 T.Iterator_Index := T.Iterator_Index + 1; 128 T.Iterator_Ptr := T.Table (T.Iterator_Index); 129 end loop; 130 131 return T.Iterator_Ptr; 132 end Get_Non_Null; 133 134 ------------ 135 -- Remove -- 136 ------------ 137 138 procedure Remove (T : Instance; K : Key) is 139 Index : constant Header_Num := Hash (K); 140 Elmt : Elmt_Ptr; 141 Next_Elmt : Elmt_Ptr; 142 143 begin 144 if T = null then 145 return; 146 end if; 147 148 Elmt := T.Table (Index); 149 150 if Elmt = Null_Ptr then 151 return; 152 153 elsif Equal (Get_Key (Elmt), K) then 154 T.Table (Index) := Next (Elmt); 155 156 else 157 loop 158 Next_Elmt := Next (Elmt); 159 160 if Next_Elmt = Null_Ptr then 161 return; 162 163 elsif Equal (Get_Key (Next_Elmt), K) then 164 Set_Next (Elmt, Next (Next_Elmt)); 165 return; 166 167 else 168 Elmt := Next_Elmt; 169 end if; 170 end loop; 171 end if; 172 end Remove; 173 174 ----------- 175 -- Reset -- 176 ----------- 177 178 procedure Reset (T : in out Instance) is 179 procedure Free is 180 new Ada.Unchecked_Deallocation (Instance_Data, Instance); 181 182 begin 183 if T = null then 184 return; 185 end if; 186 187 for J in T.Table'Range loop 188 T.Table (J) := Null_Ptr; 189 end loop; 190 191 Free (T); 192 end Reset; 193 194 --------- 195 -- Set -- 196 --------- 197 198 procedure Set (T : in out Instance; E : Elmt_Ptr) is 199 Index : Header_Num; 200 201 begin 202 if T = null then 203 T := new Instance_Data; 204 end if; 205 206 Index := Hash (Get_Key (E)); 207 Set_Next (E, T.Table (Index)); 208 T.Table (Index) := E; 209 end Set; 210 211 end Static_HTable; 212 213 ------------------- 214 -- Simple_HTable -- 215 ------------------- 216 217 package body Simple_HTable is 218 219 --------- 220 -- Get -- 221 --------- 222 223 function Get (T : Instance; K : Key) return Element is 224 Tmp : Elmt_Ptr; 225 226 begin 227 if T = Nil then 228 return No_Element; 229 end if; 230 231 Tmp := Tab.Get (Tab.Instance (T), K); 232 233 if Tmp = null then 234 return No_Element; 235 else 236 return Tmp.E; 237 end if; 238 end Get; 239 240 --------------- 241 -- Get_First -- 242 --------------- 243 244 function Get_First (T : Instance) return Element is 245 Tmp : constant Elmt_Ptr := Tab.Get_First (Tab.Instance (T)); 246 247 begin 248 if Tmp = null then 249 return No_Element; 250 else 251 return Tmp.E; 252 end if; 253 end Get_First; 254 255 ------------- 256 -- Get_Key -- 257 ------------- 258 259 function Get_Key (E : Elmt_Ptr) return Key is 260 begin 261 return E.K; 262 end Get_Key; 263 264 -------------- 265 -- Get_Next -- 266 -------------- 267 268 function Get_Next (T : Instance) return Element is 269 Tmp : constant Elmt_Ptr := Tab.Get_Next (Tab.Instance (T)); 270 begin 271 if Tmp = null then 272 return No_Element; 273 else 274 return Tmp.E; 275 end if; 276 end Get_Next; 277 278 ---------- 279 -- Next -- 280 ---------- 281 282 function Next (E : Elmt_Ptr) return Elmt_Ptr is 283 begin 284 return E.Next; 285 end Next; 286 287 ------------ 288 -- Remove -- 289 ------------ 290 291 procedure Remove (T : Instance; K : Key) is 292 Tmp : Elmt_Ptr; 293 294 begin 295 Tmp := Tab.Get (Tab.Instance (T), K); 296 297 if Tmp /= null then 298 Tab.Remove (Tab.Instance (T), K); 299 Free (Tmp); 300 end if; 301 end Remove; 302 303 ----------- 304 -- Reset -- 305 ----------- 306 307 procedure Reset (T : in out Instance) is 308 E1, E2 : Elmt_Ptr; 309 310 begin 311 E1 := Tab.Get_First (Tab.Instance (T)); 312 while E1 /= null loop 313 E2 := Tab.Get_Next (Tab.Instance (T)); 314 Free (E1); 315 E1 := E2; 316 end loop; 317 318 Tab.Reset (Tab.Instance (T)); 319 end Reset; 320 321 --------- 322 -- Set -- 323 --------- 324 325 procedure Set (T : in out Instance; K : Key; E : Element) is 326 Tmp : constant Elmt_Ptr := Tab.Get (Tab.Instance (T), K); 327 begin 328 if Tmp = null then 329 Tab.Set (Tab.Instance (T), new Element_Wrapper'(K, E, null)); 330 else 331 Tmp.E := E; 332 end if; 333 end Set; 334 335 -------------- 336 -- Set_Next -- 337 -------------- 338 339 procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr) is 340 begin 341 E.Next := Next; 342 end Set_Next; 343 344 end Simple_HTable; 345 346end GNAT.Dynamic_HTables; 347