1------------------------------------------------------------------------------ 2-- -- 3-- GNAT LIBRARY COMPONENTS -- 4-- -- 5-- ADA.CONTAINERS.HASH_TABLES.GENERIC_BOUNDED_OPERATIONS -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2004-2011, Free Software Foundation, 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 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-- This unit was originally developed by Matthew J Heaney. -- 28------------------------------------------------------------------------------ 29 30with System; use type System.Address; 31 32package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is 33 34 ----------- 35 -- Clear -- 36 ----------- 37 38 procedure Clear (HT : in out Hash_Table_Type'Class) is 39 begin 40 if HT.Busy > 0 then 41 raise Program_Error with 42 "attempt to tamper with cursors (container is busy)"; 43 end if; 44 45 HT.Length := 0; 46 -- HT.Busy := 0; 47 -- HT.Lock := 0; 48 HT.Free := -1; 49 HT.Buckets := (others => 0); -- optimize this somehow ??? 50 end Clear; 51 52 --------------------------- 53 -- Delete_Node_Sans_Free -- 54 --------------------------- 55 56 procedure Delete_Node_Sans_Free 57 (HT : in out Hash_Table_Type'Class; 58 X : Count_Type) 59 is 60 pragma Assert (X /= 0); 61 62 Indx : Hash_Type; 63 Prev : Count_Type; 64 Curr : Count_Type; 65 66 begin 67 if HT.Length = 0 then 68 raise Program_Error with 69 "attempt to delete node from empty hashed container"; 70 end if; 71 72 Indx := Index (HT, HT.Nodes (X)); 73 Prev := HT.Buckets (Indx); 74 75 if Prev = 0 then 76 raise Program_Error with 77 "attempt to delete node from empty hash bucket"; 78 end if; 79 80 if Prev = X then 81 HT.Buckets (Indx) := Next (HT.Nodes (Prev)); 82 HT.Length := HT.Length - 1; 83 return; 84 end if; 85 86 if HT.Length = 1 then 87 raise Program_Error with 88 "attempt to delete node not in its proper hash bucket"; 89 end if; 90 91 loop 92 Curr := Next (HT.Nodes (Prev)); 93 94 if Curr = 0 then 95 raise Program_Error with 96 "attempt to delete node not in its proper hash bucket"; 97 end if; 98 99 if Curr = X then 100 Set_Next (HT.Nodes (Prev), Next => Next (HT.Nodes (Curr))); 101 HT.Length := HT.Length - 1; 102 return; 103 end if; 104 105 Prev := Curr; 106 end loop; 107 end Delete_Node_Sans_Free; 108 109 ----------- 110 -- First -- 111 ----------- 112 113 function First (HT : Hash_Table_Type'Class) return Count_Type is 114 Indx : Hash_Type; 115 116 begin 117 if HT.Length = 0 then 118 return 0; 119 end if; 120 121 Indx := HT.Buckets'First; 122 loop 123 if HT.Buckets (Indx) /= 0 then 124 return HT.Buckets (Indx); 125 end if; 126 127 Indx := Indx + 1; 128 end loop; 129 end First; 130 131 ---------- 132 -- Free -- 133 ---------- 134 135 procedure Free 136 (HT : in out Hash_Table_Type'Class; 137 X : Count_Type) 138 is 139 N : Nodes_Type renames HT.Nodes; 140 141 begin 142 -- This subprogram "deallocates" a node by relinking the node off of the 143 -- active list and onto the free list. Previously it would flag index 144 -- value 0 as an error. The precondition was weakened, so that index 145 -- value 0 is now allowed, and this value is interpreted to mean "do 146 -- nothing". This makes its behavior analogous to the behavior of 147 -- Ada.Unchecked_Deallocation, and allows callers to avoid having to add 148 -- special-case checks at the point of call. 149 150 if X = 0 then 151 return; 152 end if; 153 154 pragma Assert (X <= HT.Capacity); 155 156 -- pragma Assert (N (X).Prev >= 0); -- node is active 157 -- Find a way to mark a node as active vs. inactive; we could 158 -- use a special value in Color_Type for this. ??? 159 160 -- The hash table actually contains two data structures: a list for 161 -- the "active" nodes that contain elements that have been inserted 162 -- onto the container, and another for the "inactive" nodes of the free 163 -- store. 164 -- 165 -- We desire that merely declaring an object should have only minimal 166 -- cost; specially, we want to avoid having to initialize the free 167 -- store (to fill in the links), especially if the capacity is large. 168 -- 169 -- The head of the free list is indicated by Container.Free. If its 170 -- value is non-negative, then the free store has been initialized 171 -- in the "normal" way: Container.Free points to the head of the list 172 -- of free (inactive) nodes, and the value 0 means the free list is 173 -- empty. Each node on the free list has been initialized to point 174 -- to the next free node (via its Parent component), and the value 0 175 -- means that this is the last free node. 176 -- 177 -- If Container.Free is negative, then the links on the free store 178 -- have not been initialized. In this case the link values are 179 -- implied: the free store comprises the components of the node array 180 -- started with the absolute value of Container.Free, and continuing 181 -- until the end of the array (Nodes'Last). 182 -- 183 -- ??? 184 -- It might be possible to perform an optimization here. Suppose that 185 -- the free store can be represented as having two parts: one 186 -- comprising the non-contiguous inactive nodes linked together 187 -- in the normal way, and the other comprising the contiguous 188 -- inactive nodes (that are not linked together, at the end of the 189 -- nodes array). This would allow us to never have to initialize 190 -- the free store, except in a lazy way as nodes become inactive. 191 192 -- When an element is deleted from the list container, its node 193 -- becomes inactive, and so we set its Next component to value of 194 -- the node's index (in the nodes array), to indicate that it is 195 -- now inactive. This provides a useful way to detect a dangling 196 -- cursor reference. ??? 197 198 Set_Next (N (X), Next => X); -- Node is deallocated (not on active list) 199 200 if HT.Free >= 0 then 201 -- The free store has previously been initialized. All we need to 202 -- do here is link the newly-free'd node onto the free list. 203 204 Set_Next (N (X), HT.Free); 205 HT.Free := X; 206 207 elsif X + 1 = abs HT.Free then 208 -- The free store has not been initialized, and the node becoming 209 -- inactive immediately precedes the start of the free store. All 210 -- we need to do is move the start of the free store back by one. 211 212 HT.Free := HT.Free + 1; 213 214 else 215 -- The free store has not been initialized, and the node becoming 216 -- inactive does not immediately precede the free store. Here we 217 -- first initialize the free store (meaning the links are given 218 -- values in the traditional way), and then link the newly-free'd 219 -- node onto the head of the free store. 220 221 -- ??? 222 -- See the comments above for an optimization opportunity. If 223 -- the next link for a node on the free store is negative, then 224 -- this means the remaining nodes on the free store are 225 -- physically contiguous, starting as the absolute value of 226 -- that index value. 227 228 HT.Free := abs HT.Free; 229 230 if HT.Free > HT.Capacity then 231 HT.Free := 0; 232 233 else 234 for I in HT.Free .. HT.Capacity - 1 loop 235 Set_Next (Node => N (I), Next => I + 1); 236 end loop; 237 238 Set_Next (Node => N (HT.Capacity), Next => 0); 239 end if; 240 241 Set_Next (Node => N (X), Next => HT.Free); 242 HT.Free := X; 243 end if; 244 end Free; 245 246 ---------------------- 247 -- Generic_Allocate -- 248 ---------------------- 249 250 procedure Generic_Allocate 251 (HT : in out Hash_Table_Type'Class; 252 Node : out Count_Type) 253 is 254 N : Nodes_Type renames HT.Nodes; 255 256 begin 257 if HT.Free >= 0 then 258 Node := HT.Free; 259 260 -- We always perform the assignment first, before we 261 -- change container state, in order to defend against 262 -- exceptions duration assignment. 263 264 Set_Element (N (Node)); 265 HT.Free := Next (N (Node)); 266 267 else 268 -- A negative free store value means that the links of the nodes 269 -- in the free store have not been initialized. In this case, the 270 -- nodes are physically contiguous in the array, starting at the 271 -- index that is the absolute value of the Container.Free, and 272 -- continuing until the end of the array (Nodes'Last). 273 274 Node := abs HT.Free; 275 276 -- As above, we perform this assignment first, before modifying 277 -- any container state. 278 279 Set_Element (N (Node)); 280 HT.Free := HT.Free - 1; 281 end if; 282 end Generic_Allocate; 283 284 ------------------- 285 -- Generic_Equal -- 286 ------------------- 287 288 function Generic_Equal 289 (L, R : Hash_Table_Type'Class) return Boolean 290 is 291 L_Index : Hash_Type; 292 L_Node : Count_Type; 293 294 N : Count_Type; 295 296 begin 297 if L'Address = R'Address then 298 return True; 299 end if; 300 301 if L.Length /= R.Length then 302 return False; 303 end if; 304 305 if L.Length = 0 then 306 return True; 307 end if; 308 309 -- Find the first node of hash table L 310 311 L_Index := L.Buckets'First; 312 loop 313 L_Node := L.Buckets (L_Index); 314 exit when L_Node /= 0; 315 L_Index := L_Index + 1; 316 end loop; 317 318 -- For each node of hash table L, search for an equivalent node in hash 319 -- table R. 320 321 N := L.Length; 322 loop 323 if not Find (HT => R, Key => L.Nodes (L_Node)) then 324 return False; 325 end if; 326 327 N := N - 1; 328 329 L_Node := Next (L.Nodes (L_Node)); 330 331 if L_Node = 0 then 332 -- We have exhausted the nodes in this bucket 333 334 if N = 0 then 335 return True; 336 end if; 337 338 -- Find the next bucket 339 340 loop 341 L_Index := L_Index + 1; 342 L_Node := L.Buckets (L_Index); 343 exit when L_Node /= 0; 344 end loop; 345 end if; 346 end loop; 347 end Generic_Equal; 348 349 ----------------------- 350 -- Generic_Iteration -- 351 ----------------------- 352 353 procedure Generic_Iteration (HT : Hash_Table_Type'Class) is 354 Node : Count_Type; 355 356 begin 357 if HT.Length = 0 then 358 return; 359 end if; 360 361 for Indx in HT.Buckets'Range loop 362 Node := HT.Buckets (Indx); 363 while Node /= 0 loop 364 Process (Node); 365 Node := Next (HT.Nodes (Node)); 366 end loop; 367 end loop; 368 end Generic_Iteration; 369 370 ------------------ 371 -- Generic_Read -- 372 ------------------ 373 374 procedure Generic_Read 375 (Stream : not null access Root_Stream_Type'Class; 376 HT : out Hash_Table_Type'Class) 377 is 378 N : Count_Type'Base; 379 380 begin 381 Clear (HT); 382 383 Count_Type'Base'Read (Stream, N); 384 385 if N < 0 then 386 raise Program_Error with "stream appears to be corrupt"; 387 end if; 388 389 if N = 0 then 390 return; 391 end if; 392 393 if N > HT.Capacity then 394 raise Capacity_Error with "too many elements in stream"; 395 end if; 396 397 for J in 1 .. N loop 398 declare 399 Node : constant Count_Type := New_Node (Stream); 400 Indx : constant Hash_Type := Index (HT, HT.Nodes (Node)); 401 B : Count_Type renames HT.Buckets (Indx); 402 begin 403 Set_Next (HT.Nodes (Node), Next => B); 404 B := Node; 405 end; 406 407 HT.Length := HT.Length + 1; 408 end loop; 409 end Generic_Read; 410 411 ------------------- 412 -- Generic_Write -- 413 ------------------- 414 415 procedure Generic_Write 416 (Stream : not null access Root_Stream_Type'Class; 417 HT : Hash_Table_Type'Class) 418 is 419 procedure Write (Node : Count_Type); 420 pragma Inline (Write); 421 422 procedure Write is new Generic_Iteration (Write); 423 424 ----------- 425 -- Write -- 426 ----------- 427 428 procedure Write (Node : Count_Type) is 429 begin 430 Write (Stream, HT.Nodes (Node)); 431 end Write; 432 433 begin 434 Count_Type'Base'Write (Stream, HT.Length); 435 Write (HT); 436 end Generic_Write; 437 438 ----------- 439 -- Index -- 440 ----------- 441 442 function Index 443 (Buckets : Buckets_Type; 444 Node : Node_Type) return Hash_Type is 445 begin 446 return Buckets'First + Hash_Node (Node) mod Buckets'Length; 447 end Index; 448 449 function Index 450 (HT : Hash_Table_Type'Class; 451 Node : Node_Type) return Hash_Type is 452 begin 453 return Index (HT.Buckets, Node); 454 end Index; 455 456 ---------- 457 -- Next -- 458 ---------- 459 460 function Next 461 (HT : Hash_Table_Type'Class; 462 Node : Count_Type) return Count_Type 463 is 464 Result : Count_Type := Next (HT.Nodes (Node)); 465 466 begin 467 if Result /= 0 then -- another node in same bucket 468 return Result; 469 end if; 470 471 -- This was the last node in the bucket, so move to the next 472 -- bucket, and start searching for next node from there. 473 474 for Indx in Index (HT, HT.Nodes (Node)) + 1 .. HT.Buckets'Last loop 475 Result := HT.Buckets (Indx); 476 477 if Result /= 0 then -- bucket is not empty 478 return Result; 479 end if; 480 end loop; 481 482 return 0; 483 end Next; 484 485end Ada.Containers.Hash_Tables.Generic_Bounded_Operations; 486