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