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