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