1------------------------------------------------------------------------------ 2-- -- 3-- GNAT LIBRARY COMPONENTS -- 4-- -- 5-- A D A . C O N T A I N E R S . F O R M A L _ H A S H E D _ M A P S -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2010-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 28with Ada.Containers.Hash_Tables.Generic_Bounded_Operations; 29pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Operations); 30 31with Ada.Containers.Hash_Tables.Generic_Bounded_Keys; 32pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Keys); 33 34with Ada.Containers.Prime_Numbers; use Ada.Containers.Prime_Numbers; 35 36with System; use type System.Address; 37 38package body Ada.Containers.Formal_Hashed_Maps is 39 40 ----------------------- 41 -- Local Subprograms -- 42 ----------------------- 43 44 -- All local subprograms require comments ??? 45 46 function Equivalent_Keys 47 (Key : Key_Type; 48 Node : Node_Type) return Boolean; 49 pragma Inline (Equivalent_Keys); 50 51 procedure Free 52 (HT : in out Map; 53 X : Count_Type); 54 55 generic 56 with procedure Set_Element (Node : in out Node_Type); 57 procedure Generic_Allocate 58 (HT : in out Map; 59 Node : out Count_Type); 60 61 function Hash_Node (Node : Node_Type) return Hash_Type; 62 pragma Inline (Hash_Node); 63 64 function Next (Node : Node_Type) return Count_Type; 65 pragma Inline (Next); 66 67 procedure Set_Next (Node : in out Node_Type; Next : Count_Type); 68 pragma Inline (Set_Next); 69 70 function Vet (Container : Map; Position : Cursor) return Boolean; 71 72 -------------------------- 73 -- Local Instantiations -- 74 -------------------------- 75 76 package HT_Ops is 77 new Hash_Tables.Generic_Bounded_Operations 78 (HT_Types => HT_Types, 79 Hash_Node => Hash_Node, 80 Next => Next, 81 Set_Next => Set_Next); 82 83 package Key_Ops is 84 new Hash_Tables.Generic_Bounded_Keys 85 (HT_Types => HT_Types, 86 Next => Next, 87 Set_Next => Set_Next, 88 Key_Type => Key_Type, 89 Hash => Hash, 90 Equivalent_Keys => Equivalent_Keys); 91 92 --------- 93 -- "=" -- 94 --------- 95 96 function "=" (Left, Right : Map) return Boolean is 97 begin 98 if Length (Left) /= Length (Right) then 99 return False; 100 end if; 101 102 if Length (Left) = 0 then 103 return True; 104 end if; 105 106 declare 107 Node : Count_Type; 108 ENode : Count_Type; 109 110 begin 111 Node := Left.First.Node; 112 while Node /= 0 loop 113 ENode := Find (Container => Right, 114 Key => Left.Nodes (Node).Key).Node; 115 116 if ENode = 0 or else 117 Right.Nodes (ENode).Element /= Left.Nodes (Node).Element 118 then 119 return False; 120 end if; 121 122 Node := HT_Ops.Next (Left, Node); 123 end loop; 124 125 return True; 126 end; 127 end "="; 128 129 ------------ 130 -- Assign -- 131 ------------ 132 133 procedure Assign (Target : in out Map; Source : Map) is 134 procedure Insert_Element (Source_Node : Count_Type); 135 pragma Inline (Insert_Element); 136 137 procedure Insert_Elements is 138 new HT_Ops.Generic_Iteration (Insert_Element); 139 140 -------------------- 141 -- Insert_Element -- 142 -------------------- 143 144 procedure Insert_Element (Source_Node : Count_Type) is 145 N : Node_Type renames Source.Nodes (Source_Node); 146 begin 147 Target.Insert (N.Key, N.Element); 148 end Insert_Element; 149 150 -- Start of processing for Assign 151 152 begin 153 if Target'Address = Source'Address then 154 return; 155 end if; 156 157 if Target.Capacity < Length (Source) then 158 raise Constraint_Error with -- correct exception ??? 159 "Source length exceeds Target capacity"; 160 end if; 161 162 Clear (Target); 163 164 Insert_Elements (Source); 165 end Assign; 166 167 -------------- 168 -- Capacity -- 169 -------------- 170 171 function Capacity (Container : Map) return Count_Type is 172 begin 173 return Container.Nodes'Length; 174 end Capacity; 175 176 ----------- 177 -- Clear -- 178 ----------- 179 180 procedure Clear (Container : in out Map) is 181 begin 182 HT_Ops.Clear (Container); 183 end Clear; 184 185 -------------- 186 -- Contains -- 187 -------------- 188 189 function Contains (Container : Map; Key : Key_Type) return Boolean is 190 begin 191 return Find (Container, Key) /= No_Element; 192 end Contains; 193 194 ---------- 195 -- Copy -- 196 ---------- 197 198 function Copy 199 (Source : Map; 200 Capacity : Count_Type := 0) return Map 201 is 202 C : constant Count_Type := 203 Count_Type'Max (Capacity, Source.Capacity); 204 H : Hash_Type; 205 N : Count_Type; 206 Target : Map (C, Source.Modulus); 207 Cu : Cursor; 208 209 begin 210 if 0 < Capacity and then Capacity < Source.Capacity then 211 raise Capacity_Error; 212 end if; 213 214 Target.Length := Source.Length; 215 Target.Free := Source.Free; 216 217 H := 1; 218 while H <= Source.Modulus loop 219 Target.Buckets (H) := Source.Buckets (H); 220 H := H + 1; 221 end loop; 222 223 N := 1; 224 while N <= Source.Capacity loop 225 Target.Nodes (N) := Source.Nodes (N); 226 N := N + 1; 227 end loop; 228 229 while N <= C loop 230 Cu := (Node => N); 231 Free (Target, Cu.Node); 232 N := N + 1; 233 end loop; 234 235 return Target; 236 end Copy; 237 238 --------------------- 239 -- Current_To_Last -- 240 --------------------- 241 242 function Current_To_Last (Container : Map; Current : Cursor) return Map is 243 Curs : Cursor := First (Container); 244 C : Map (Container.Capacity, Container.Modulus) := 245 Copy (Container, Container.Capacity); 246 Node : Count_Type; 247 248 begin 249 if Curs = No_Element then 250 Clear (C); 251 return C; 252 253 elsif Current /= No_Element and not Has_Element (Container, Current) then 254 raise Constraint_Error; 255 256 else 257 while Curs.Node /= Current.Node loop 258 Node := Curs.Node; 259 Delete (C, Curs); 260 Curs := Next (Container, (Node => Node)); 261 end loop; 262 263 return C; 264 end if; 265 end Current_To_Last; 266 267 --------------------- 268 -- Default_Modulus -- 269 --------------------- 270 271 function Default_Modulus (Capacity : Count_Type) return Hash_Type is 272 begin 273 return To_Prime (Capacity); 274 end Default_Modulus; 275 276 ------------ 277 -- Delete -- 278 ------------ 279 280 procedure Delete (Container : in out Map; Key : Key_Type) is 281 X : Count_Type; 282 283 begin 284 Key_Ops.Delete_Key_Sans_Free (Container, Key, X); 285 286 if X = 0 then 287 raise Constraint_Error with "attempt to delete key not in map"; 288 end if; 289 290 Free (Container, X); 291 end Delete; 292 293 procedure Delete (Container : in out Map; Position : in out Cursor) is 294 begin 295 if not Has_Element (Container, Position) then 296 raise Constraint_Error with 297 "Position cursor of Delete has no element"; 298 end if; 299 300 pragma Assert (Vet (Container, Position), "bad cursor in Delete"); 301 302 HT_Ops.Delete_Node_Sans_Free (Container, Position.Node); 303 304 Free (Container, Position.Node); 305 end Delete; 306 307 ------------- 308 -- Element -- 309 ------------- 310 311 function Element (Container : Map; Key : Key_Type) return Element_Type is 312 Node : constant Count_Type := Find (Container, Key).Node; 313 314 begin 315 if Node = 0 then 316 raise Constraint_Error with 317 "no element available because key not in map"; 318 end if; 319 320 return Container.Nodes (Node).Element; 321 end Element; 322 323 function Element (Container : Map; Position : Cursor) return Element_Type is 324 begin 325 if not Has_Element (Container, Position) then 326 raise Constraint_Error with "Position cursor equals No_Element"; 327 end if; 328 329 pragma Assert (Vet (Container, Position), 330 "bad cursor in function Element"); 331 332 return Container.Nodes (Position.Node).Element; 333 end Element; 334 335 --------------------- 336 -- Equivalent_Keys -- 337 --------------------- 338 339 function Equivalent_Keys 340 (Key : Key_Type; 341 Node : Node_Type) return Boolean 342 is 343 begin 344 return Equivalent_Keys (Key, Node.Key); 345 end Equivalent_Keys; 346 347 function Equivalent_Keys 348 (Left : Map; 349 CLeft : Cursor; 350 Right : Map; 351 CRight : Cursor) return Boolean 352 is 353 begin 354 if not Has_Element (Left, CLeft) then 355 raise Constraint_Error with 356 "Left cursor of Equivalent_Keys has no element"; 357 end if; 358 359 if not Has_Element (Right, CRight) then 360 raise Constraint_Error with 361 "Right cursor of Equivalent_Keys has no element"; 362 end if; 363 364 pragma Assert (Vet (Left, CLeft), 365 "Left cursor of Equivalent_Keys is bad"); 366 pragma Assert (Vet (Right, CRight), 367 "Right cursor of Equivalent_Keys is bad"); 368 369 declare 370 LN : Node_Type renames Left.Nodes (CLeft.Node); 371 RN : Node_Type renames Right.Nodes (CRight.Node); 372 begin 373 return Equivalent_Keys (LN.Key, RN.Key); 374 end; 375 end Equivalent_Keys; 376 377 function Equivalent_Keys 378 (Left : Map; 379 CLeft : Cursor; 380 Right : Key_Type) return Boolean 381 is 382 begin 383 if not Has_Element (Left, CLeft) then 384 raise Constraint_Error with 385 "Left cursor of Equivalent_Keys has no element"; 386 end if; 387 388 pragma Assert (Vet (Left, CLeft), 389 "Left cursor in Equivalent_Keys is bad"); 390 391 declare 392 LN : Node_Type renames Left.Nodes (CLeft.Node); 393 begin 394 return Equivalent_Keys (LN.Key, Right); 395 end; 396 end Equivalent_Keys; 397 398 function Equivalent_Keys 399 (Left : Key_Type; 400 Right : Map; 401 CRight : Cursor) return Boolean 402 is 403 begin 404 if Has_Element (Right, CRight) then 405 raise Constraint_Error with 406 "Right cursor of Equivalent_Keys has no element"; 407 end if; 408 409 pragma Assert (Vet (Right, CRight), 410 "Right cursor of Equivalent_Keys is bad"); 411 412 declare 413 RN : Node_Type renames Right.Nodes (CRight.Node); 414 415 begin 416 return Equivalent_Keys (Left, RN.Key); 417 end; 418 end Equivalent_Keys; 419 420 ------------- 421 -- Exclude -- 422 ------------- 423 424 procedure Exclude (Container : in out Map; Key : Key_Type) is 425 X : Count_Type; 426 begin 427 Key_Ops.Delete_Key_Sans_Free (Container, Key, X); 428 Free (Container, X); 429 end Exclude; 430 431 ---------- 432 -- Find -- 433 ---------- 434 435 function Find (Container : Map; Key : Key_Type) return Cursor is 436 Node : constant Count_Type := Key_Ops.Find (Container, Key); 437 438 begin 439 if Node = 0 then 440 return No_Element; 441 end if; 442 443 return (Node => Node); 444 end Find; 445 446 ----------- 447 -- First -- 448 ----------- 449 450 function First (Container : Map) return Cursor is 451 Node : constant Count_Type := HT_Ops.First (Container); 452 453 begin 454 if Node = 0 then 455 return No_Element; 456 end if; 457 458 return (Node => Node); 459 end First; 460 461 ----------------------- 462 -- First_To_Previous -- 463 ----------------------- 464 465 function First_To_Previous 466 (Container : Map; 467 Current : Cursor) return Map is 468 Curs : Cursor; 469 C : Map (Container.Capacity, Container.Modulus) := 470 Copy (Container, Container.Capacity); 471 Node : Count_Type; 472 473 begin 474 Curs := Current; 475 476 if Curs = No_Element then 477 return C; 478 479 elsif not Has_Element (Container, Curs) then 480 raise Constraint_Error; 481 482 else 483 while Curs.Node /= 0 loop 484 Node := Curs.Node; 485 Delete (C, Curs); 486 Curs := Next (Container, (Node => Node)); 487 end loop; 488 489 return C; 490 end if; 491 end First_To_Previous; 492 493 ---------- 494 -- Free -- 495 ---------- 496 497 procedure Free (HT : in out Map; X : Count_Type) is 498 begin 499 HT.Nodes (X).Has_Element := False; 500 HT_Ops.Free (HT, X); 501 end Free; 502 503 ---------------------- 504 -- Generic_Allocate -- 505 ---------------------- 506 507 procedure Generic_Allocate (HT : in out Map; Node : out Count_Type) is 508 509 procedure Allocate is 510 new HT_Ops.Generic_Allocate (Set_Element); 511 512 begin 513 Allocate (HT, Node); 514 HT.Nodes (Node).Has_Element := True; 515 end Generic_Allocate; 516 517 ----------------- 518 -- Has_Element -- 519 ----------------- 520 521 function Has_Element (Container : Map; Position : Cursor) return Boolean is 522 begin 523 if Position.Node = 0 524 or else not Container.Nodes (Position.Node).Has_Element 525 then 526 return False; 527 else 528 return True; 529 end if; 530 end Has_Element; 531 532 --------------- 533 -- Hash_Node -- 534 --------------- 535 536 function Hash_Node (Node : Node_Type) return Hash_Type is 537 begin 538 return Hash (Node.Key); 539 end Hash_Node; 540 541 ------------- 542 -- Include -- 543 ------------- 544 545 procedure Include 546 (Container : in out Map; 547 Key : Key_Type; 548 New_Item : Element_Type) 549 is 550 Position : Cursor; 551 Inserted : Boolean; 552 553 begin 554 Insert (Container, Key, New_Item, Position, Inserted); 555 556 if not Inserted then 557 declare 558 N : Node_Type renames Container.Nodes (Position.Node); 559 begin 560 N.Key := Key; 561 N.Element := New_Item; 562 end; 563 end if; 564 end Include; 565 566 ------------ 567 -- Insert -- 568 ------------ 569 570 procedure Insert 571 (Container : in out Map; 572 Key : Key_Type; 573 New_Item : Element_Type; 574 Position : out Cursor; 575 Inserted : out Boolean) 576 is 577 procedure Assign_Key (Node : in out Node_Type); 578 pragma Inline (Assign_Key); 579 580 function New_Node return Count_Type; 581 pragma Inline (New_Node); 582 583 procedure Local_Insert is 584 new Key_Ops.Generic_Conditional_Insert (New_Node); 585 586 procedure Allocate is 587 new Generic_Allocate (Assign_Key); 588 589 ----------------- 590 -- Assign_Key -- 591 ----------------- 592 593 procedure Assign_Key (Node : in out Node_Type) is 594 begin 595 Node.Key := Key; 596 Node.Element := New_Item; 597 end Assign_Key; 598 599 -------------- 600 -- New_Node -- 601 -------------- 602 603 function New_Node return Count_Type is 604 Result : Count_Type; 605 begin 606 Allocate (Container, Result); 607 return Result; 608 end New_Node; 609 610 -- Start of processing for Insert 611 612 begin 613 Local_Insert (Container, Key, Position.Node, Inserted); 614 end Insert; 615 616 procedure Insert 617 (Container : in out Map; 618 Key : Key_Type; 619 New_Item : Element_Type) 620 is 621 Position : Cursor; 622 pragma Unreferenced (Position); 623 624 Inserted : Boolean; 625 626 begin 627 Insert (Container, Key, New_Item, Position, Inserted); 628 629 if not Inserted then 630 raise Constraint_Error with 631 "attempt to insert key already in map"; 632 end if; 633 end Insert; 634 635 -------------- 636 -- Is_Empty -- 637 -------------- 638 639 function Is_Empty (Container : Map) return Boolean is 640 begin 641 return Length (Container) = 0; 642 end Is_Empty; 643 644 --------- 645 -- Key -- 646 --------- 647 648 function Key (Container : Map; Position : Cursor) return Key_Type is 649 begin 650 if not Has_Element (Container, Position) then 651 raise Constraint_Error with 652 "Position cursor of function Key has no element"; 653 end if; 654 655 pragma Assert (Vet (Container, Position), "bad cursor in function Key"); 656 657 return Container.Nodes (Position.Node).Key; 658 end Key; 659 660 ------------ 661 -- Length -- 662 ------------ 663 664 function Length (Container : Map) return Count_Type is 665 begin 666 return Container.Length; 667 end Length; 668 669 ---------- 670 -- Move -- 671 ---------- 672 673 procedure Move 674 (Target : in out Map; 675 Source : in out Map) 676 is 677 NN : HT_Types.Nodes_Type renames Source.Nodes; 678 X, Y : Count_Type; 679 680 begin 681 if Target'Address = Source'Address then 682 return; 683 end if; 684 685 if Target.Capacity < Length (Source) then 686 raise Constraint_Error with -- ??? 687 "Source length exceeds Target capacity"; 688 end if; 689 690 Clear (Target); 691 692 if Source.Length = 0 then 693 return; 694 end if; 695 696 X := HT_Ops.First (Source); 697 while X /= 0 loop 698 Insert (Target, NN (X).Key, NN (X).Element); -- optimize??? 699 700 Y := HT_Ops.Next (Source, X); 701 702 HT_Ops.Delete_Node_Sans_Free (Source, X); 703 Free (Source, X); 704 705 X := Y; 706 end loop; 707 end Move; 708 709 ---------- 710 -- Next -- 711 ---------- 712 713 function Next (Node : Node_Type) return Count_Type is 714 begin 715 return Node.Next; 716 end Next; 717 718 function Next (Container : Map; Position : Cursor) return Cursor is 719 begin 720 if Position.Node = 0 then 721 return No_Element; 722 end if; 723 724 if not Has_Element (Container, Position) then 725 raise Constraint_Error 726 with "Position has no element"; 727 end if; 728 729 pragma Assert (Vet (Container, Position), "bad cursor in function Next"); 730 731 declare 732 Node : constant Count_Type := HT_Ops.Next (Container, Position.Node); 733 734 begin 735 if Node = 0 then 736 return No_Element; 737 end if; 738 739 return (Node => Node); 740 end; 741 end Next; 742 743 procedure Next (Container : Map; Position : in out Cursor) is 744 begin 745 Position := Next (Container, Position); 746 end Next; 747 748 ------------- 749 -- Overlap -- 750 ------------- 751 752 function Overlap (Left, Right : Map) return Boolean is 753 Left_Node : Count_Type; 754 Left_Nodes : Nodes_Type renames Left.Nodes; 755 756 begin 757 if Length (Right) = 0 or Length (Left) = 0 then 758 return False; 759 end if; 760 761 if Left'Address = Right'Address then 762 return True; 763 end if; 764 765 Left_Node := First (Left).Node; 766 while Left_Node /= 0 loop 767 declare 768 N : Node_Type renames Left_Nodes (Left_Node); 769 E : Key_Type renames N.Key; 770 begin 771 if Find (Right, E).Node /= 0 then 772 return True; 773 end if; 774 end; 775 776 Left_Node := HT_Ops.Next (Left, Left_Node); 777 end loop; 778 779 return False; 780 end Overlap; 781 782 ------------- 783 -- Replace -- 784 ------------- 785 786 procedure Replace 787 (Container : in out Map; 788 Key : Key_Type; 789 New_Item : Element_Type) 790 is 791 Node : constant Count_Type := Key_Ops.Find (Container, Key); 792 793 begin 794 if Node = 0 then 795 raise Constraint_Error with 796 "attempt to replace key not in map"; 797 end if; 798 799 declare 800 N : Node_Type renames Container.Nodes (Node); 801 begin 802 N.Key := Key; 803 N.Element := New_Item; 804 end; 805 end Replace; 806 807 --------------------- 808 -- Replace_Element -- 809 --------------------- 810 811 procedure Replace_Element 812 (Container : in out Map; 813 Position : Cursor; 814 New_Item : Element_Type) 815 is 816 begin 817 if not Has_Element (Container, Position) then 818 raise Constraint_Error with 819 "Position cursor of Replace_Element has no element"; 820 end if; 821 822 pragma Assert (Vet (Container, Position), 823 "bad cursor in Replace_Element"); 824 825 Container.Nodes (Position.Node).Element := New_Item; 826 end Replace_Element; 827 828 ---------------------- 829 -- Reserve_Capacity -- 830 ---------------------- 831 832 procedure Reserve_Capacity 833 (Container : in out Map; 834 Capacity : Count_Type) 835 is 836 begin 837 if Capacity > Container.Capacity then 838 raise Capacity_Error with "requested capacity is too large"; 839 end if; 840 end Reserve_Capacity; 841 842 -------------- 843 -- Set_Next -- 844 -------------- 845 846 procedure Set_Next (Node : in out Node_Type; Next : Count_Type) is 847 begin 848 Node.Next := Next; 849 end Set_Next; 850 851 ------------------ 852 -- Strict_Equal -- 853 ------------------ 854 855 function Strict_Equal (Left, Right : Map) return Boolean is 856 CuL : Cursor := First (Left); 857 CuR : Cursor := First (Right); 858 859 begin 860 if Length (Left) /= Length (Right) then 861 return False; 862 end if; 863 864 while CuL.Node /= 0 or else CuR.Node /= 0 loop 865 if CuL.Node /= CuR.Node 866 or else 867 Left.Nodes (CuL.Node).Element /= Right.Nodes (CuR.Node).Element 868 or else Left.Nodes (CuL.Node).Key /= Right.Nodes (CuR.Node).Key 869 then 870 return False; 871 end if; 872 873 CuL := Next (Left, CuL); 874 CuR := Next (Right, CuR); 875 end loop; 876 877 return True; 878 end Strict_Equal; 879 880 --------- 881 -- Vet -- 882 --------- 883 884 function Vet (Container : Map; Position : Cursor) return Boolean is 885 begin 886 if Position.Node = 0 then 887 return True; 888 end if; 889 890 declare 891 X : Count_Type; 892 893 begin 894 if Container.Length = 0 then 895 return False; 896 end if; 897 898 if Container.Capacity = 0 then 899 return False; 900 end if; 901 902 if Container.Buckets'Length = 0 then 903 return False; 904 end if; 905 906 if Position.Node > Container.Capacity then 907 return False; 908 end if; 909 910 if Container.Nodes (Position.Node).Next = Position.Node then 911 return False; 912 end if; 913 914 X := Container.Buckets 915 (Key_Ops.Index (Container, Container.Nodes (Position.Node).Key)); 916 917 for J in 1 .. Container.Length loop 918 if X = Position.Node then 919 return True; 920 end if; 921 922 if X = 0 then 923 return False; 924 end if; 925 926 if X = Container.Nodes (X).Next then 927 928 -- Prevent unnecessary looping 929 930 return False; 931 end if; 932 933 X := Container.Nodes (X).Next; 934 end loop; 935 936 return False; 937 end; 938 end Vet; 939 940end Ada.Containers.Formal_Hashed_Maps; 941