1------------------------------------------------------------------------------ 2-- -- 3-- GNAT LIBRARY COMPONENTS -- 4-- -- 5-- ADA.CONTAINERS.HASH_TABLES.GENERIC_OPERATIONS -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2004-2010, 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 Ada.Containers.Prime_Numbers; 31with Ada.Unchecked_Deallocation; 32 33with System; use type System.Address; 34 35package body Ada.Containers.Hash_Tables.Generic_Operations is 36 37 type Buckets_Allocation is access all Buckets_Type; 38 -- Used for allocation and deallocation (see New_Buckets and Free_Buckets). 39 -- This is necessary because Buckets_Access has an empty storage pool. 40 41 ------------ 42 -- Adjust -- 43 ------------ 44 45 procedure Adjust (HT : in out Hash_Table_Type) is 46 Src_Buckets : constant Buckets_Access := HT.Buckets; 47 N : constant Count_Type := HT.Length; 48 Src_Node : Node_Access; 49 Dst_Prev : Node_Access; 50 51 begin 52 HT.Buckets := null; 53 HT.Length := 0; 54 55 if N = 0 then 56 return; 57 end if; 58 59 -- Technically it isn't necessary to allocate the exact same length 60 -- buckets array, because our only requirement is that following 61 -- assignment the source and target containers compare equal (that is, 62 -- operator "=" returns True). We can satisfy this requirement with any 63 -- hash table length, but we decide here to match the length of the 64 -- source table. This has the benefit that when iterating, elements of 65 -- the target are delivered in the exact same order as for the source. 66 67 HT.Buckets := New_Buckets (Length => Src_Buckets'Length); 68 69 for Src_Index in Src_Buckets'Range loop 70 Src_Node := Src_Buckets (Src_Index); 71 72 if Src_Node /= null then 73 declare 74 Dst_Node : constant Node_Access := Copy_Node (Src_Node); 75 76 -- See note above 77 78 pragma Assert (Index (HT, Dst_Node) = Src_Index); 79 80 begin 81 HT.Buckets (Src_Index) := Dst_Node; 82 HT.Length := HT.Length + 1; 83 84 Dst_Prev := Dst_Node; 85 end; 86 87 Src_Node := Next (Src_Node); 88 while Src_Node /= null loop 89 declare 90 Dst_Node : constant Node_Access := Copy_Node (Src_Node); 91 92 -- See note above 93 94 pragma Assert (Index (HT, Dst_Node) = Src_Index); 95 96 begin 97 Set_Next (Node => Dst_Prev, Next => Dst_Node); 98 HT.Length := HT.Length + 1; 99 100 Dst_Prev := Dst_Node; 101 end; 102 103 Src_Node := Next (Src_Node); 104 end loop; 105 end if; 106 end loop; 107 108 pragma Assert (HT.Length = N); 109 end Adjust; 110 111 -------------- 112 -- Capacity -- 113 -------------- 114 115 function Capacity (HT : Hash_Table_Type) return Count_Type is 116 begin 117 if HT.Buckets = null then 118 return 0; 119 end if; 120 121 return HT.Buckets'Length; 122 end Capacity; 123 124 ----------- 125 -- Clear -- 126 ----------- 127 128 procedure Clear (HT : in out Hash_Table_Type) is 129 Index : Hash_Type := 0; 130 Node : Node_Access; 131 132 begin 133 if HT.Busy > 0 then 134 raise Program_Error with 135 "attempt to tamper with cursors (container is busy)"; 136 end if; 137 138 while HT.Length > 0 loop 139 while HT.Buckets (Index) = null loop 140 Index := Index + 1; 141 end loop; 142 143 declare 144 Bucket : Node_Access renames HT.Buckets (Index); 145 begin 146 loop 147 Node := Bucket; 148 Bucket := Next (Bucket); 149 HT.Length := HT.Length - 1; 150 Free (Node); 151 exit when Bucket = null; 152 end loop; 153 end; 154 end loop; 155 end Clear; 156 157 --------------------------- 158 -- Delete_Node_Sans_Free -- 159 --------------------------- 160 161 procedure Delete_Node_Sans_Free 162 (HT : in out Hash_Table_Type; 163 X : Node_Access) 164 is 165 pragma Assert (X /= null); 166 167 Indx : Hash_Type; 168 Prev : Node_Access; 169 Curr : Node_Access; 170 171 begin 172 if HT.Length = 0 then 173 raise Program_Error with 174 "attempt to delete node from empty hashed container"; 175 end if; 176 177 Indx := Index (HT, X); 178 Prev := HT.Buckets (Indx); 179 180 if Prev = null then 181 raise Program_Error with 182 "attempt to delete node from empty hash bucket"; 183 end if; 184 185 if Prev = X then 186 HT.Buckets (Indx) := Next (Prev); 187 HT.Length := HT.Length - 1; 188 return; 189 end if; 190 191 if HT.Length = 1 then 192 raise Program_Error with 193 "attempt to delete node not in its proper hash bucket"; 194 end if; 195 196 loop 197 Curr := Next (Prev); 198 199 if Curr = null then 200 raise Program_Error with 201 "attempt to delete node not in its proper hash bucket"; 202 end if; 203 204 if Curr = X then 205 Set_Next (Node => Prev, Next => Next (Curr)); 206 HT.Length := HT.Length - 1; 207 return; 208 end if; 209 210 Prev := Curr; 211 end loop; 212 end Delete_Node_Sans_Free; 213 214 -------------- 215 -- Finalize -- 216 -------------- 217 218 procedure Finalize (HT : in out Hash_Table_Type) is 219 begin 220 Clear (HT); 221 Free_Buckets (HT.Buckets); 222 end Finalize; 223 224 ----------- 225 -- First -- 226 ----------- 227 228 function First (HT : Hash_Table_Type) return Node_Access is 229 Indx : Hash_Type; 230 231 begin 232 if HT.Length = 0 then 233 return null; 234 end if; 235 236 Indx := HT.Buckets'First; 237 loop 238 if HT.Buckets (Indx) /= null then 239 return HT.Buckets (Indx); 240 end if; 241 242 Indx := Indx + 1; 243 end loop; 244 end First; 245 246 ------------------ 247 -- Free_Buckets -- 248 ------------------ 249 250 procedure Free_Buckets (Buckets : in out Buckets_Access) is 251 procedure Free is 252 new Ada.Unchecked_Deallocation (Buckets_Type, Buckets_Allocation); 253 254 begin 255 -- Buckets must have been created by New_Buckets. Here, we convert back 256 -- to the Buckets_Allocation type, and do the free on that. 257 258 Free (Buckets_Allocation (Buckets)); 259 end Free_Buckets; 260 261 --------------------- 262 -- Free_Hash_Table -- 263 --------------------- 264 265 procedure Free_Hash_Table (Buckets : in out Buckets_Access) is 266 Node : Node_Access; 267 268 begin 269 if Buckets = null then 270 return; 271 end if; 272 273 for J in Buckets'Range loop 274 while Buckets (J) /= null loop 275 Node := Buckets (J); 276 Buckets (J) := Next (Node); 277 Free (Node); 278 end loop; 279 end loop; 280 281 Free_Buckets (Buckets); 282 end Free_Hash_Table; 283 284 ------------------- 285 -- Generic_Equal -- 286 ------------------- 287 288 function Generic_Equal 289 (L, R : Hash_Table_Type) return Boolean 290 is 291 L_Index : Hash_Type; 292 L_Node : Node_Access; 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 := 0; 312 loop 313 L_Node := L.Buckets (L_Index); 314 exit when L_Node /= null; 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_Node) then 324 return False; 325 end if; 326 327 N := N - 1; 328 329 L_Node := Next (L_Node); 330 331 if L_Node = null 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 /= null; 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) is 354 Node : Node_Access; 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 /= null loop 364 Process (Node); 365 Node := Next (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) 377 is 378 N : Count_Type'Base; 379 NN : Hash_Type; 380 381 begin 382 Clear (HT); 383 384 Count_Type'Base'Read (Stream, N); 385 386 if N < 0 then 387 raise Program_Error with "stream appears to be corrupt"; 388 end if; 389 390 if N = 0 then 391 return; 392 end if; 393 394 -- The RM does not specify whether or how the capacity changes when a 395 -- hash table is streamed in. Therefore we decide here to allocate a new 396 -- buckets array only when it's necessary to preserve representation 397 -- invariants. 398 399 if HT.Buckets = null 400 or else HT.Buckets'Length < N 401 then 402 Free_Buckets (HT.Buckets); 403 NN := Prime_Numbers.To_Prime (N); 404 HT.Buckets := New_Buckets (Length => NN); 405 end if; 406 407 for J in 1 .. N loop 408 declare 409 Node : constant Node_Access := New_Node (Stream); 410 Indx : constant Hash_Type := Index (HT, Node); 411 B : Node_Access renames HT.Buckets (Indx); 412 begin 413 Set_Next (Node => Node, Next => B); 414 B := Node; 415 end; 416 417 HT.Length := HT.Length + 1; 418 end loop; 419 end Generic_Read; 420 421 ------------------- 422 -- Generic_Write -- 423 ------------------- 424 425 procedure Generic_Write 426 (Stream : not null access Root_Stream_Type'Class; 427 HT : Hash_Table_Type) 428 is 429 procedure Write (Node : Node_Access); 430 pragma Inline (Write); 431 432 procedure Write is new Generic_Iteration (Write); 433 434 ----------- 435 -- Write -- 436 ----------- 437 438 procedure Write (Node : Node_Access) is 439 begin 440 Write (Stream, Node); 441 end Write; 442 443 begin 444 -- See Generic_Read for an explanation of why we do not stream out the 445 -- buckets array length too. 446 447 Count_Type'Base'Write (Stream, HT.Length); 448 Write (HT); 449 end Generic_Write; 450 451 ----------- 452 -- Index -- 453 ----------- 454 455 function Index 456 (Buckets : Buckets_Type; 457 Node : Node_Access) return Hash_Type is 458 begin 459 return Hash_Node (Node) mod Buckets'Length; 460 end Index; 461 462 function Index 463 (Hash_Table : Hash_Table_Type; 464 Node : Node_Access) return Hash_Type is 465 begin 466 return Index (Hash_Table.Buckets.all, Node); 467 end Index; 468 469 ---------- 470 -- Move -- 471 ---------- 472 473 procedure Move (Target, Source : in out Hash_Table_Type) is 474 begin 475 if Target'Address = Source'Address then 476 return; 477 end if; 478 479 if Source.Busy > 0 then 480 raise Program_Error with 481 "attempt to tamper with cursors (container is busy)"; 482 end if; 483 484 Clear (Target); 485 486 declare 487 Buckets : constant Buckets_Access := Target.Buckets; 488 begin 489 Target.Buckets := Source.Buckets; 490 Source.Buckets := Buckets; 491 end; 492 493 Target.Length := Source.Length; 494 Source.Length := 0; 495 end Move; 496 497 ----------------- 498 -- New_Buckets -- 499 ----------------- 500 501 function New_Buckets (Length : Hash_Type) return Buckets_Access is 502 subtype Rng is Hash_Type range 0 .. Length - 1; 503 504 begin 505 -- Allocate in Buckets_Allocation'Storage_Pool, then convert to 506 -- Buckets_Access. 507 508 return Buckets_Access (Buckets_Allocation'(new Buckets_Type (Rng))); 509 end New_Buckets; 510 511 ---------- 512 -- Next -- 513 ---------- 514 515 function Next 516 (HT : Hash_Table_Type; 517 Node : Node_Access) return Node_Access 518 is 519 Result : Node_Access := Next (Node); 520 521 begin 522 if Result /= null then 523 return Result; 524 end if; 525 526 for Indx in Index (HT, Node) + 1 .. HT.Buckets'Last loop 527 Result := HT.Buckets (Indx); 528 529 if Result /= null then 530 return Result; 531 end if; 532 end loop; 533 534 return null; 535 end Next; 536 537 ---------------------- 538 -- Reserve_Capacity -- 539 ---------------------- 540 541 procedure Reserve_Capacity 542 (HT : in out Hash_Table_Type; 543 N : Count_Type) 544 is 545 NN : Hash_Type; 546 547 begin 548 if HT.Buckets = null then 549 if N > 0 then 550 NN := Prime_Numbers.To_Prime (N); 551 HT.Buckets := New_Buckets (Length => NN); 552 end if; 553 554 return; 555 end if; 556 557 if HT.Length = 0 then 558 559 -- This is the easy case. There are no nodes, so no rehashing is 560 -- necessary. All we need to do is allocate a new buckets array 561 -- having a length implied by the specified capacity. (We say 562 -- "implied by" because bucket arrays are always allocated with a 563 -- length that corresponds to a prime number.) 564 565 if N = 0 then 566 Free_Buckets (HT.Buckets); 567 return; 568 end if; 569 570 if N = HT.Buckets'Length then 571 return; 572 end if; 573 574 NN := Prime_Numbers.To_Prime (N); 575 576 if NN = HT.Buckets'Length then 577 return; 578 end if; 579 580 declare 581 X : Buckets_Access := HT.Buckets; 582 pragma Warnings (Off, X); 583 begin 584 HT.Buckets := New_Buckets (Length => NN); 585 Free_Buckets (X); 586 end; 587 588 return; 589 end if; 590 591 if N = HT.Buckets'Length then 592 return; 593 end if; 594 595 if N < HT.Buckets'Length then 596 597 -- This is a request to contract the buckets array. The amount of 598 -- contraction is bounded in order to preserve the invariant that the 599 -- buckets array length is never smaller than the number of elements 600 -- (the load factor is 1). 601 602 if HT.Length >= HT.Buckets'Length then 603 return; 604 end if; 605 606 NN := Prime_Numbers.To_Prime (HT.Length); 607 608 if NN >= HT.Buckets'Length then 609 return; 610 end if; 611 612 else 613 NN := Prime_Numbers.To_Prime (Count_Type'Max (N, HT.Length)); 614 615 if NN = HT.Buckets'Length then -- can't expand any more 616 return; 617 end if; 618 end if; 619 620 if HT.Busy > 0 then 621 raise Program_Error with 622 "attempt to tamper with cursors (container is busy)"; 623 end if; 624 625 Rehash : declare 626 Dst_Buckets : Buckets_Access := New_Buckets (Length => NN); 627 Src_Buckets : Buckets_Access := HT.Buckets; 628 pragma Warnings (Off, Src_Buckets); 629 630 L : Count_Type renames HT.Length; 631 LL : constant Count_Type := L; 632 633 Src_Index : Hash_Type := Src_Buckets'First; 634 635 begin 636 while L > 0 loop 637 declare 638 Src_Bucket : Node_Access renames Src_Buckets (Src_Index); 639 640 begin 641 while Src_Bucket /= null loop 642 declare 643 Src_Node : constant Node_Access := Src_Bucket; 644 645 Dst_Index : constant Hash_Type := 646 Index (Dst_Buckets.all, Src_Node); 647 648 Dst_Bucket : Node_Access renames Dst_Buckets (Dst_Index); 649 650 begin 651 Src_Bucket := Next (Src_Node); 652 653 Set_Next (Src_Node, Dst_Bucket); 654 655 Dst_Bucket := Src_Node; 656 end; 657 658 pragma Assert (L > 0); 659 L := L - 1; 660 end loop; 661 exception 662 when others => 663 -- If there's an error computing a hash value during a 664 -- rehash, then AI-302 says the nodes "become lost." The 665 -- issue is whether to actually deallocate these lost nodes, 666 -- since they might be designated by extant cursors. Here 667 -- we decide to deallocate the nodes, since it's better to 668 -- solve real problems (storage consumption) rather than 669 -- imaginary ones (the user might, or might not, dereference 670 -- a cursor designating a node that has been deallocated), 671 -- and because we have a way to vet a dangling cursor 672 -- reference anyway, and hence can actually detect the 673 -- problem. 674 675 for Dst_Index in Dst_Buckets'Range loop 676 declare 677 B : Node_Access renames Dst_Buckets (Dst_Index); 678 X : Node_Access; 679 begin 680 while B /= null loop 681 X := B; 682 B := Next (X); 683 Free (X); 684 end loop; 685 end; 686 end loop; 687 688 Free_Buckets (Dst_Buckets); 689 raise Program_Error with 690 "hash function raised exception during rehash"; 691 end; 692 693 Src_Index := Src_Index + 1; 694 end loop; 695 696 HT.Buckets := Dst_Buckets; 697 HT.Length := LL; 698 699 Free_Buckets (Src_Buckets); 700 end Rehash; 701 end Reserve_Capacity; 702 703end Ada.Containers.Hash_Tables.Generic_Operations; 704