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