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 _ S E T 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_Sets with 39 SPARK_Mode => Off 40is 41 42 ----------------------- 43 -- Local Subprograms -- 44 ----------------------- 45 46 -- All need comments ??? 47 48 procedure Difference 49 (Left, Right : Set; 50 Target : in out Set); 51 52 function Equivalent_Keys 53 (Key : Element_Type; 54 Node : Node_Type) return Boolean; 55 pragma Inline (Equivalent_Keys); 56 57 procedure Free 58 (HT : in out Set; 59 X : Count_Type); 60 61 generic 62 with procedure Set_Element (Node : in out Node_Type); 63 procedure Generic_Allocate 64 (HT : in out Set; 65 Node : out Count_Type); 66 67 function Hash_Node (Node : Node_Type) return Hash_Type; 68 pragma Inline (Hash_Node); 69 70 procedure Insert 71 (Container : in out Set; 72 New_Item : Element_Type; 73 Node : out Count_Type; 74 Inserted : out Boolean); 75 76 procedure Intersection 77 (Left : Set; 78 Right : Set; 79 Target : in out Set); 80 81 function Is_In 82 (HT : Set; 83 Key : Node_Type) return Boolean; 84 pragma Inline (Is_In); 85 86 procedure Set_Element (Node : in out Node_Type; Item : Element_Type); 87 pragma Inline (Set_Element); 88 89 function Next (Node : Node_Type) return Count_Type; 90 pragma Inline (Next); 91 92 procedure Set_Next (Node : in out Node_Type; Next : Count_Type); 93 pragma Inline (Set_Next); 94 95 function Vet (Container : Set; Position : Cursor) return Boolean; 96 97 -------------------------- 98 -- Local Instantiations -- 99 -------------------------- 100 101 package HT_Ops is new Hash_Tables.Generic_Bounded_Operations 102 (HT_Types => HT_Types, 103 Hash_Node => Hash_Node, 104 Next => Next, 105 Set_Next => Set_Next); 106 107 package Element_Keys is new Hash_Tables.Generic_Bounded_Keys 108 (HT_Types => HT_Types, 109 Next => Next, 110 Set_Next => Set_Next, 111 Key_Type => Element_Type, 112 Hash => Hash, 113 Equivalent_Keys => Equivalent_Keys); 114 115 procedure Replace_Element is 116 new Element_Keys.Generic_Replace_Element (Hash_Node, Set_Element); 117 118 --------- 119 -- "=" -- 120 --------- 121 122 function "=" (Left, Right : Set) return Boolean is 123 begin 124 if Length (Left) /= Length (Right) then 125 return False; 126 end if; 127 128 if Length (Left) = 0 then 129 return True; 130 end if; 131 132 declare 133 Node : Count_Type; 134 ENode : Count_Type; 135 136 begin 137 Node := First (Left).Node; 138 while Node /= 0 loop 139 ENode := Find (Container => Right, 140 Item => Left.Nodes (Node).Element).Node; 141 if ENode = 0 or else 142 Right.Nodes (ENode).Element /= Left.Nodes (Node).Element 143 then 144 return False; 145 end if; 146 147 Node := HT_Ops.Next (Left, Node); 148 end loop; 149 150 return True; 151 152 end; 153 154 end "="; 155 156 ------------ 157 -- Assign -- 158 ------------ 159 160 procedure Assign (Target : in out Set; Source : Set) is 161 procedure Insert_Element (Source_Node : Count_Type); 162 163 procedure Insert_Elements is 164 new HT_Ops.Generic_Iteration (Insert_Element); 165 166 -------------------- 167 -- Insert_Element -- 168 -------------------- 169 170 procedure Insert_Element (Source_Node : Count_Type) is 171 N : Node_Type renames Source.Nodes (Source_Node); 172 X : Count_Type; 173 B : Boolean; 174 175 begin 176 Insert (Target, N.Element, X, B); 177 pragma Assert (B); 178 end Insert_Element; 179 180 -- Start of processing for Assign 181 182 begin 183 if Target'Address = Source'Address then 184 return; 185 end if; 186 187 if Target.Capacity < Length (Source) then 188 raise Storage_Error with "not enough capacity"; -- SE or CE? ??? 189 end if; 190 191 HT_Ops.Clear (Target); 192 Insert_Elements (Source); 193 end Assign; 194 195 -------------- 196 -- Capacity -- 197 -------------- 198 199 function Capacity (Container : Set) return Count_Type is 200 begin 201 return Container.Nodes'Length; 202 end Capacity; 203 204 ----------- 205 -- Clear -- 206 ----------- 207 208 procedure Clear (Container : in out Set) is 209 begin 210 HT_Ops.Clear (Container); 211 end Clear; 212 213 -------------- 214 -- Contains -- 215 -------------- 216 217 function Contains (Container : Set; Item : Element_Type) return Boolean is 218 begin 219 return Find (Container, Item) /= No_Element; 220 end Contains; 221 222 ---------- 223 -- Copy -- 224 ---------- 225 226 function Copy 227 (Source : Set; 228 Capacity : Count_Type := 0) return Set 229 is 230 C : constant Count_Type := 231 Count_Type'Max (Capacity, Source.Capacity); 232 H : Hash_Type; 233 N : Count_Type; 234 Target : Set (C, Source.Modulus); 235 Cu : Cursor; 236 237 begin 238 if 0 < Capacity and then Capacity < Source.Capacity then 239 raise Capacity_Error; 240 end if; 241 242 Target.Length := Source.Length; 243 Target.Free := Source.Free; 244 245 H := 1; 246 while H <= Source.Modulus loop 247 Target.Buckets (H) := Source.Buckets (H); 248 H := H + 1; 249 end loop; 250 251 N := 1; 252 while N <= Source.Capacity loop 253 Target.Nodes (N) := Source.Nodes (N); 254 N := N + 1; 255 end loop; 256 257 while N <= C loop 258 Cu := (Node => N); 259 Free (Target, Cu.Node); 260 N := N + 1; 261 end loop; 262 263 return Target; 264 end Copy; 265 266 --------------------- 267 -- Current_To_Last -- 268 --------------------- 269 270 function Current_To_Last (Container : Set; Current : Cursor) return Set is 271 Curs : Cursor := First (Container); 272 C : Set (Container.Capacity, Container.Modulus) := 273 Copy (Container, Container.Capacity); 274 Node : Count_Type; 275 276 begin 277 if Curs = No_Element then 278 Clear (C); 279 return C; 280 281 elsif Current /= No_Element and not Has_Element (Container, Current) then 282 raise Constraint_Error; 283 284 else 285 while Curs.Node /= Current.Node loop 286 Node := Curs.Node; 287 Delete (C, Curs); 288 Curs := Next (Container, (Node => Node)); 289 end loop; 290 291 return C; 292 end if; 293 end Current_To_Last; 294 295 --------------------- 296 -- Default_Modulus -- 297 --------------------- 298 299 function Default_Modulus (Capacity : Count_Type) return Hash_Type is 300 begin 301 return To_Prime (Capacity); 302 end Default_Modulus; 303 304 ------------ 305 -- Delete -- 306 ------------ 307 308 procedure Delete 309 (Container : in out Set; 310 Item : Element_Type) 311 is 312 X : Count_Type; 313 314 begin 315 Element_Keys.Delete_Key_Sans_Free (Container, Item, X); 316 317 if X = 0 then 318 raise Constraint_Error with "attempt to delete element not in set"; 319 end if; 320 321 Free (Container, X); 322 end Delete; 323 324 procedure Delete 325 (Container : in out Set; 326 Position : in out Cursor) 327 is 328 begin 329 if not Has_Element (Container, Position) then 330 raise Constraint_Error with "Position cursor has no element"; 331 end if; 332 333 pragma Assert (Vet (Container, Position), "bad cursor in Delete"); 334 335 HT_Ops.Delete_Node_Sans_Free (Container, Position.Node); 336 Free (Container, Position.Node); 337 338 Position := No_Element; 339 end Delete; 340 341 ---------------- 342 -- Difference -- 343 ---------------- 344 345 procedure Difference 346 (Target : in out Set; 347 Source : Set) 348 is 349 Tgt_Node, Src_Node, Src_Last, Src_Length : Count_Type; 350 351 TN : Nodes_Type renames Target.Nodes; 352 SN : Nodes_Type renames Source.Nodes; 353 354 begin 355 if Target'Address = Source'Address then 356 Clear (Target); 357 return; 358 end if; 359 360 Src_Length := Source.Length; 361 362 if Src_Length = 0 then 363 return; 364 end if; 365 366 if Src_Length >= Target.Length then 367 Tgt_Node := HT_Ops.First (Target); 368 while Tgt_Node /= 0 loop 369 if Element_Keys.Find (Source, TN (Tgt_Node).Element) /= 0 then 370 declare 371 X : constant Count_Type := Tgt_Node; 372 begin 373 Tgt_Node := HT_Ops.Next (Target, Tgt_Node); 374 HT_Ops.Delete_Node_Sans_Free (Target, X); 375 Free (Target, X); 376 end; 377 378 else 379 Tgt_Node := HT_Ops.Next (Target, Tgt_Node); 380 end if; 381 end loop; 382 383 return; 384 else 385 Src_Node := HT_Ops.First (Source); 386 Src_Last := 0; 387 end if; 388 389 while Src_Node /= Src_Last loop 390 Tgt_Node := Element_Keys.Find (Target, SN (Src_Node).Element); 391 392 if Tgt_Node /= 0 then 393 HT_Ops.Delete_Node_Sans_Free (Target, Tgt_Node); 394 Free (Target, Tgt_Node); 395 end if; 396 397 Src_Node := HT_Ops.Next (Source, Src_Node); 398 end loop; 399 end Difference; 400 401 procedure Difference 402 (Left, Right : Set; 403 Target : in out Set) 404 is 405 procedure Process (L_Node : Count_Type); 406 407 procedure Iterate is 408 new HT_Ops.Generic_Iteration (Process); 409 410 ------------- 411 -- Process -- 412 ------------- 413 414 procedure Process (L_Node : Count_Type) is 415 E : Element_Type renames Left.Nodes (L_Node).Element; 416 X : Count_Type; 417 B : Boolean; 418 begin 419 if Find (Right, E).Node = 0 then 420 Insert (Target, E, X, B); 421 pragma Assert (B); 422 end if; 423 end Process; 424 425 -- Start of processing for Difference 426 427 begin 428 Iterate (Left); 429 end Difference; 430 431 function Difference (Left, Right : Set) return Set is 432 C : Count_Type; 433 H : Hash_Type; 434 435 begin 436 if Left'Address = Right'Address then 437 return Empty_Set; 438 end if; 439 440 if Length (Left) = 0 then 441 return Empty_Set; 442 end if; 443 444 if Length (Right) = 0 then 445 return Left.Copy; 446 end if; 447 448 C := Length (Left); 449 H := Default_Modulus (C); 450 451 return S : Set (C, H) do 452 Difference (Left, Right, Target => S); 453 end return; 454 end Difference; 455 456 ------------- 457 -- Element -- 458 ------------- 459 460 function Element 461 (Container : Set; 462 Position : Cursor) return Element_Type 463 is 464 begin 465 if not Has_Element (Container, Position) then 466 raise Constraint_Error with "Position cursor equals No_Element"; 467 end if; 468 469 pragma Assert (Vet (Container, Position), 470 "bad cursor in function Element"); 471 472 return Container.Nodes (Position.Node).Element; 473 end Element; 474 475 --------------------- 476 -- Equivalent_Sets -- 477 --------------------- 478 479 function Equivalent_Sets (Left, Right : Set) return Boolean is 480 481 function Find_Equivalent_Key 482 (R_HT : Hash_Table_Type'Class; 483 L_Node : Node_Type) return Boolean; 484 pragma Inline (Find_Equivalent_Key); 485 486 function Is_Equivalent is 487 new HT_Ops.Generic_Equal (Find_Equivalent_Key); 488 489 ------------------------- 490 -- Find_Equivalent_Key -- 491 ------------------------- 492 493 function Find_Equivalent_Key 494 (R_HT : Hash_Table_Type'Class; 495 L_Node : Node_Type) return Boolean 496 is 497 R_Index : constant Hash_Type := 498 Element_Keys.Index (R_HT, L_Node.Element); 499 R_Node : Count_Type := R_HT.Buckets (R_Index); 500 RN : Nodes_Type renames R_HT.Nodes; 501 502 begin 503 loop 504 if R_Node = 0 then 505 return False; 506 end if; 507 508 if Equivalent_Elements 509 (L_Node.Element, RN (R_Node).Element) 510 then 511 return True; 512 end if; 513 514 R_Node := HT_Ops.Next (R_HT, R_Node); 515 end loop; 516 end Find_Equivalent_Key; 517 518 -- Start of processing for Equivalent_Sets 519 520 begin 521 return Is_Equivalent (Left, Right); 522 end Equivalent_Sets; 523 524 ------------------------- 525 -- Equivalent_Elements -- 526 ------------------------- 527 528 function Equivalent_Elements 529 (Left : Set; 530 CLeft : Cursor; 531 Right : Set; 532 CRight : Cursor) return Boolean 533 is 534 begin 535 if not Has_Element (Left, CLeft) then 536 raise Constraint_Error with 537 "Left cursor of Equivalent_Elements has no element"; 538 end if; 539 540 if not Has_Element (Right, CRight) then 541 raise Constraint_Error with 542 "Right cursor of Equivalent_Elements has no element"; 543 end if; 544 545 pragma Assert (Vet (Left, CLeft), 546 "bad Left cursor in Equivalent_Elements"); 547 pragma Assert (Vet (Right, CRight), 548 "bad Right cursor in Equivalent_Elements"); 549 550 declare 551 LN : Node_Type renames Left.Nodes (CLeft.Node); 552 RN : Node_Type renames Right.Nodes (CRight.Node); 553 begin 554 return Equivalent_Elements (LN.Element, RN.Element); 555 end; 556 end Equivalent_Elements; 557 558 function Equivalent_Elements 559 (Left : Set; 560 CLeft : Cursor; 561 Right : Element_Type) return Boolean 562 is 563 begin 564 if not Has_Element (Left, CLeft) then 565 raise Constraint_Error with 566 "Left cursor of Equivalent_Elements has no element"; 567 end if; 568 569 pragma Assert (Vet (Left, CLeft), 570 "Left cursor in Equivalent_Elements is bad"); 571 572 declare 573 LN : Node_Type renames Left.Nodes (CLeft.Node); 574 begin 575 return Equivalent_Elements (LN.Element, Right); 576 end; 577 end Equivalent_Elements; 578 579 function Equivalent_Elements 580 (Left : Element_Type; 581 Right : Set; 582 CRight : Cursor) return Boolean 583 is 584 begin 585 if not Has_Element (Right, CRight) then 586 raise Constraint_Error with 587 "Right cursor of Equivalent_Elements has no element"; 588 end if; 589 590 pragma Assert 591 (Vet (Right, CRight), 592 "Right cursor of Equivalent_Elements is bad"); 593 594 declare 595 RN : Node_Type renames Right.Nodes (CRight.Node); 596 begin 597 return Equivalent_Elements (Left, RN.Element); 598 end; 599 end Equivalent_Elements; 600 601 --------------------- 602 -- Equivalent_Keys -- 603 --------------------- 604 605 function Equivalent_Keys 606 (Key : Element_Type; 607 Node : Node_Type) return Boolean 608 is 609 begin 610 return Equivalent_Elements (Key, Node.Element); 611 end Equivalent_Keys; 612 613 ------------- 614 -- Exclude -- 615 ------------- 616 617 procedure Exclude 618 (Container : in out Set; 619 Item : Element_Type) 620 is 621 X : Count_Type; 622 begin 623 Element_Keys.Delete_Key_Sans_Free (Container, Item, X); 624 Free (Container, X); 625 end Exclude; 626 627 ---------- 628 -- Find -- 629 ---------- 630 631 function Find 632 (Container : Set; 633 Item : Element_Type) return Cursor 634 is 635 Node : constant Count_Type := Element_Keys.Find (Container, Item); 636 637 begin 638 if Node = 0 then 639 return No_Element; 640 end if; 641 642 return (Node => Node); 643 end Find; 644 645 ----------- 646 -- First -- 647 ----------- 648 649 function First (Container : Set) return Cursor is 650 Node : constant Count_Type := HT_Ops.First (Container); 651 652 begin 653 if Node = 0 then 654 return No_Element; 655 end if; 656 657 return (Node => Node); 658 end First; 659 660 ----------------------- 661 -- First_To_Previous -- 662 ----------------------- 663 664 function First_To_Previous 665 (Container : Set; 666 Current : Cursor) return Set 667 is 668 Curs : Cursor := Current; 669 C : Set (Container.Capacity, Container.Modulus) := 670 Copy (Container, Container.Capacity); 671 Node : Count_Type; 672 673 begin 674 if Curs = No_Element then 675 return C; 676 677 elsif not Has_Element (Container, Curs) then 678 raise Constraint_Error; 679 680 else 681 while Curs.Node /= 0 loop 682 Node := Curs.Node; 683 Delete (C, Curs); 684 Curs := Next (Container, (Node => Node)); 685 end loop; 686 687 return C; 688 end if; 689 end First_To_Previous; 690 691 ---------- 692 -- Free -- 693 ---------- 694 695 procedure Free 696 (HT : in out Set; 697 X : Count_Type) 698 is 699 begin 700 HT.Nodes (X).Has_Element := False; 701 HT_Ops.Free (HT, X); 702 end Free; 703 704 ---------------------- 705 -- Generic_Allocate -- 706 ---------------------- 707 708 procedure Generic_Allocate 709 (HT : in out Set; 710 Node : out Count_Type) 711 is 712 procedure Allocate is new HT_Ops.Generic_Allocate (Set_Element); 713 begin 714 Allocate (HT, Node); 715 HT.Nodes (Node).Has_Element := True; 716 end Generic_Allocate; 717 718 ----------------- 719 -- Has_Element -- 720 ----------------- 721 722 function Has_Element (Container : Set; Position : Cursor) return Boolean is 723 begin 724 if Position.Node = 0 725 or else not Container.Nodes (Position.Node).Has_Element 726 then 727 return False; 728 end if; 729 730 return True; 731 end Has_Element; 732 733 --------------- 734 -- Hash_Node -- 735 --------------- 736 737 function Hash_Node (Node : Node_Type) return Hash_Type is 738 begin 739 return Hash (Node.Element); 740 end Hash_Node; 741 742 ------------- 743 -- Include -- 744 ------------- 745 746 procedure Include 747 (Container : in out Set; 748 New_Item : Element_Type) 749 is 750 Position : Cursor; 751 Inserted : Boolean; 752 753 begin 754 Insert (Container, New_Item, Position, Inserted); 755 756 if not Inserted then 757 Container.Nodes (Position.Node).Element := New_Item; 758 end if; 759 end Include; 760 761 ------------ 762 -- Insert -- 763 ------------ 764 765 procedure Insert 766 (Container : in out Set; 767 New_Item : Element_Type; 768 Position : out Cursor; 769 Inserted : out Boolean) 770 is 771 begin 772 Insert (Container, New_Item, Position.Node, Inserted); 773 end Insert; 774 775 procedure Insert 776 (Container : in out Set; 777 New_Item : Element_Type) 778 is 779 Position : Cursor; 780 Inserted : Boolean; 781 782 begin 783 Insert (Container, New_Item, Position, Inserted); 784 785 if not Inserted then 786 raise Constraint_Error with 787 "attempt to insert element already in set"; 788 end if; 789 end Insert; 790 791 procedure Insert 792 (Container : in out Set; 793 New_Item : Element_Type; 794 Node : out Count_Type; 795 Inserted : out Boolean) 796 is 797 procedure Allocate_Set_Element (Node : in out Node_Type); 798 pragma Inline (Allocate_Set_Element); 799 800 function New_Node return Count_Type; 801 pragma Inline (New_Node); 802 803 procedure Local_Insert is 804 new Element_Keys.Generic_Conditional_Insert (New_Node); 805 806 procedure Allocate is 807 new Generic_Allocate (Allocate_Set_Element); 808 809 --------------------------- 810 -- Allocate_Set_Element -- 811 --------------------------- 812 813 procedure Allocate_Set_Element (Node : in out Node_Type) is 814 begin 815 Node.Element := New_Item; 816 end Allocate_Set_Element; 817 818 -------------- 819 -- New_Node -- 820 -------------- 821 822 function New_Node return Count_Type is 823 Result : Count_Type; 824 begin 825 Allocate (Container, Result); 826 return Result; 827 end New_Node; 828 829 -- Start of processing for Insert 830 831 begin 832 Local_Insert (Container, New_Item, Node, Inserted); 833 end Insert; 834 835 ------------------ 836 -- Intersection -- 837 ------------------ 838 839 procedure Intersection 840 (Target : in out Set; 841 Source : Set) 842 is 843 Tgt_Node : Count_Type; 844 TN : Nodes_Type renames Target.Nodes; 845 846 begin 847 if Target'Address = Source'Address then 848 return; 849 end if; 850 851 if Source.Length = 0 then 852 Clear (Target); 853 return; 854 end if; 855 856 Tgt_Node := HT_Ops.First (Target); 857 while Tgt_Node /= 0 loop 858 if Find (Source, TN (Tgt_Node).Element).Node /= 0 then 859 Tgt_Node := HT_Ops.Next (Target, Tgt_Node); 860 861 else 862 declare 863 X : constant Count_Type := Tgt_Node; 864 begin 865 Tgt_Node := HT_Ops.Next (Target, Tgt_Node); 866 HT_Ops.Delete_Node_Sans_Free (Target, X); 867 Free (Target, X); 868 end; 869 end if; 870 end loop; 871 end Intersection; 872 873 procedure Intersection 874 (Left : Set; 875 Right : Set; 876 Target : in out Set) 877 is 878 procedure Process (L_Node : Count_Type); 879 880 procedure Iterate is 881 new HT_Ops.Generic_Iteration (Process); 882 883 ------------- 884 -- Process -- 885 ------------- 886 887 procedure Process (L_Node : Count_Type) is 888 E : Element_Type renames Left.Nodes (L_Node).Element; 889 X : Count_Type; 890 B : Boolean; 891 892 begin 893 if Find (Right, E).Node /= 0 then 894 Insert (Target, E, X, B); 895 pragma Assert (B); 896 end if; 897 end Process; 898 899 -- Start of processing for Intersection 900 901 begin 902 Iterate (Left); 903 end Intersection; 904 905 function Intersection (Left, Right : Set) return Set is 906 C : Count_Type; 907 H : Hash_Type; 908 909 begin 910 if Left'Address = Right'Address then 911 return Left.Copy; 912 end if; 913 914 C := Count_Type'Min (Length (Left), Length (Right)); -- ??? 915 H := Default_Modulus (C); 916 917 return S : Set (C, H) do 918 if Length (Left) /= 0 and Length (Right) /= 0 then 919 Intersection (Left, Right, Target => S); 920 end if; 921 end return; 922 end Intersection; 923 924 -------------- 925 -- Is_Empty -- 926 -------------- 927 928 function Is_Empty (Container : Set) return Boolean is 929 begin 930 return Length (Container) = 0; 931 end Is_Empty; 932 933 ----------- 934 -- Is_In -- 935 ----------- 936 937 function Is_In (HT : Set; Key : Node_Type) return Boolean is 938 begin 939 return Element_Keys.Find (HT, Key.Element) /= 0; 940 end Is_In; 941 942 --------------- 943 -- Is_Subset -- 944 --------------- 945 946 function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is 947 Subset_Node : Count_Type; 948 Subset_Nodes : Nodes_Type renames Subset.Nodes; 949 950 begin 951 if Subset'Address = Of_Set'Address then 952 return True; 953 end if; 954 955 if Length (Subset) > Length (Of_Set) then 956 return False; 957 end if; 958 959 Subset_Node := First (Subset).Node; 960 while Subset_Node /= 0 loop 961 declare 962 N : Node_Type renames Subset_Nodes (Subset_Node); 963 E : Element_Type renames N.Element; 964 965 begin 966 if Find (Of_Set, E).Node = 0 then 967 return False; 968 end if; 969 end; 970 971 Subset_Node := HT_Ops.Next (Subset, Subset_Node); 972 end loop; 973 974 return True; 975 end Is_Subset; 976 977 ------------ 978 -- Length -- 979 ------------ 980 981 function Length (Container : Set) return Count_Type is 982 begin 983 return Container.Length; 984 end Length; 985 986 ---------- 987 -- Move -- 988 ---------- 989 990 -- Comments??? 991 992 procedure Move (Target : in out Set; Source : in out Set) is 993 NN : HT_Types.Nodes_Type renames Source.Nodes; 994 X, Y : Count_Type; 995 996 begin 997 if Target'Address = Source'Address then 998 return; 999 end if; 1000 1001 if Target.Capacity < Length (Source) then 1002 raise Constraint_Error with -- ??? 1003 "Source length exceeds Target capacity"; 1004 end if; 1005 1006 Clear (Target); 1007 1008 if Source.Length = 0 then 1009 return; 1010 end if; 1011 1012 X := HT_Ops.First (Source); 1013 while X /= 0 loop 1014 Insert (Target, NN (X).Element); -- optimize??? 1015 1016 Y := HT_Ops.Next (Source, X); 1017 1018 HT_Ops.Delete_Node_Sans_Free (Source, X); 1019 Free (Source, X); 1020 1021 X := Y; 1022 end loop; 1023 end Move; 1024 1025 ---------- 1026 -- Next -- 1027 ---------- 1028 1029 function Next (Node : Node_Type) return Count_Type is 1030 begin 1031 return Node.Next; 1032 end Next; 1033 1034 function Next (Container : Set; Position : Cursor) return Cursor is 1035 begin 1036 if Position.Node = 0 then 1037 return No_Element; 1038 end if; 1039 1040 if not Has_Element (Container, Position) then 1041 raise Constraint_Error 1042 with "Position has no element"; 1043 end if; 1044 1045 pragma Assert (Vet (Container, Position), "bad cursor in Next"); 1046 1047 return (Node => HT_Ops.Next (Container, Position.Node)); 1048 end Next; 1049 1050 procedure Next (Container : Set; Position : in out Cursor) is 1051 begin 1052 Position := Next (Container, Position); 1053 end Next; 1054 1055 ------------- 1056 -- Overlap -- 1057 ------------- 1058 1059 function Overlap (Left, Right : Set) return Boolean is 1060 Left_Node : Count_Type; 1061 Left_Nodes : Nodes_Type renames Left.Nodes; 1062 1063 begin 1064 if Length (Right) = 0 or Length (Left) = 0 then 1065 return False; 1066 end if; 1067 1068 if Left'Address = Right'Address then 1069 return True; 1070 end if; 1071 1072 Left_Node := First (Left).Node; 1073 while Left_Node /= 0 loop 1074 declare 1075 N : Node_Type renames Left_Nodes (Left_Node); 1076 E : Element_Type renames N.Element; 1077 begin 1078 if Find (Right, E).Node /= 0 then 1079 return True; 1080 end if; 1081 end; 1082 1083 Left_Node := HT_Ops.Next (Left, Left_Node); 1084 end loop; 1085 1086 return False; 1087 end Overlap; 1088 1089 ------------- 1090 -- Replace -- 1091 ------------- 1092 1093 procedure Replace 1094 (Container : in out Set; 1095 New_Item : Element_Type) 1096 is 1097 Node : constant Count_Type := Element_Keys.Find (Container, New_Item); 1098 1099 begin 1100 if Node = 0 then 1101 raise Constraint_Error with 1102 "attempt to replace element not in set"; 1103 end if; 1104 1105 Container.Nodes (Node).Element := New_Item; 1106 end Replace; 1107 1108 --------------------- 1109 -- Replace_Element -- 1110 --------------------- 1111 1112 procedure Replace_Element 1113 (Container : in out Set; 1114 Position : Cursor; 1115 New_Item : Element_Type) 1116 is 1117 begin 1118 if not Has_Element (Container, Position) then 1119 raise Constraint_Error with 1120 "Position cursor equals No_Element"; 1121 end if; 1122 1123 pragma Assert (Vet (Container, Position), 1124 "bad cursor in Replace_Element"); 1125 1126 Replace_Element (Container, Position.Node, New_Item); 1127 end Replace_Element; 1128 1129 ---------------------- 1130 -- Reserve_Capacity -- 1131 ---------------------- 1132 1133 procedure Reserve_Capacity 1134 (Container : in out Set; 1135 Capacity : Count_Type) 1136 is 1137 begin 1138 if Capacity > Container.Capacity then 1139 raise Constraint_Error with "requested capacity is too large"; 1140 end if; 1141 end Reserve_Capacity; 1142 1143 ------------------ 1144 -- Set_Element -- 1145 ------------------ 1146 1147 procedure Set_Element (Node : in out Node_Type; Item : Element_Type) is 1148 begin 1149 Node.Element := Item; 1150 end Set_Element; 1151 1152 -------------- 1153 -- Set_Next -- 1154 -------------- 1155 1156 procedure Set_Next (Node : in out Node_Type; Next : Count_Type) is 1157 begin 1158 Node.Next := Next; 1159 end Set_Next; 1160 1161 ------------------ 1162 -- Strict_Equal -- 1163 ------------------ 1164 1165 function Strict_Equal (Left, Right : Set) return Boolean is 1166 CuL : Cursor := First (Left); 1167 CuR : Cursor := First (Right); 1168 1169 begin 1170 if Length (Left) /= Length (Right) then 1171 return False; 1172 end if; 1173 1174 while CuL.Node /= 0 or CuR.Node /= 0 loop 1175 if CuL.Node /= CuR.Node 1176 or else Left.Nodes (CuL.Node).Element /= 1177 Right.Nodes (CuR.Node).Element 1178 then 1179 return False; 1180 end if; 1181 1182 CuL := Next (Left, CuL); 1183 CuR := Next (Right, CuR); 1184 end loop; 1185 1186 return True; 1187 end Strict_Equal; 1188 1189 -------------------------- 1190 -- Symmetric_Difference -- 1191 -------------------------- 1192 1193 procedure Symmetric_Difference 1194 (Target : in out Set; 1195 Source : Set) 1196 is 1197 procedure Process (Source_Node : Count_Type); 1198 pragma Inline (Process); 1199 1200 procedure Iterate is new HT_Ops.Generic_Iteration (Process); 1201 1202 ------------- 1203 -- Process -- 1204 ------------- 1205 1206 procedure Process (Source_Node : Count_Type) is 1207 N : Node_Type renames Source.Nodes (Source_Node); 1208 X : Count_Type; 1209 B : Boolean; 1210 begin 1211 if Is_In (Target, N) then 1212 Delete (Target, N.Element); 1213 else 1214 Insert (Target, N.Element, X, B); 1215 pragma Assert (B); 1216 end if; 1217 end Process; 1218 1219 -- Start of processing for Symmetric_Difference 1220 1221 begin 1222 if Target'Address = Source'Address then 1223 Clear (Target); 1224 return; 1225 end if; 1226 1227 if Length (Target) = 0 then 1228 Assign (Target, Source); 1229 return; 1230 end if; 1231 1232 Iterate (Source); 1233 end Symmetric_Difference; 1234 1235 function Symmetric_Difference (Left, Right : Set) return Set is 1236 C : Count_Type; 1237 H : Hash_Type; 1238 1239 begin 1240 if Left'Address = Right'Address then 1241 return Empty_Set; 1242 end if; 1243 1244 if Length (Right) = 0 then 1245 return Left.Copy; 1246 end if; 1247 1248 if Length (Left) = 0 then 1249 return Right.Copy; 1250 end if; 1251 1252 C := Length (Left) + Length (Right); 1253 H := Default_Modulus (C); 1254 1255 return S : Set (C, H) do 1256 Difference (Left, Right, S); 1257 Difference (Right, Left, S); 1258 end return; 1259 end Symmetric_Difference; 1260 1261 ------------ 1262 -- To_Set -- 1263 ------------ 1264 1265 function To_Set (New_Item : Element_Type) return Set is 1266 X : Count_Type; 1267 B : Boolean; 1268 1269 begin 1270 return S : Set (Capacity => 1, Modulus => 1) do 1271 Insert (S, New_Item, X, B); 1272 pragma Assert (B); 1273 end return; 1274 end To_Set; 1275 1276 ----------- 1277 -- Union -- 1278 ----------- 1279 1280 procedure Union 1281 (Target : in out Set; 1282 Source : Set) 1283 is 1284 procedure Process (Src_Node : Count_Type); 1285 1286 procedure Iterate is 1287 new HT_Ops.Generic_Iteration (Process); 1288 1289 ------------- 1290 -- Process -- 1291 ------------- 1292 1293 procedure Process (Src_Node : Count_Type) is 1294 N : Node_Type renames Source.Nodes (Src_Node); 1295 E : Element_Type renames N.Element; 1296 1297 X : Count_Type; 1298 B : Boolean; 1299 1300 begin 1301 Insert (Target, E, X, B); 1302 end Process; 1303 1304 -- Start of processing for Union 1305 1306 begin 1307 if Target'Address = Source'Address then 1308 return; 1309 end if; 1310 1311 Iterate (Source); 1312 end Union; 1313 1314 function Union (Left, Right : Set) return Set is 1315 C : Count_Type; 1316 H : Hash_Type; 1317 1318 begin 1319 if Left'Address = Right'Address then 1320 return Left.Copy; 1321 end if; 1322 1323 if Length (Right) = 0 then 1324 return Left.Copy; 1325 end if; 1326 1327 if Length (Left) = 0 then 1328 return Right.Copy; 1329 end if; 1330 1331 C := Length (Left) + Length (Right); 1332 H := Default_Modulus (C); 1333 return S : Set (C, H) do 1334 Assign (Target => S, Source => Left); 1335 Union (Target => S, Source => Right); 1336 end return; 1337 end Union; 1338 1339 --------- 1340 -- Vet -- 1341 --------- 1342 1343 function Vet (Container : Set; Position : Cursor) return Boolean is 1344 begin 1345 if Position.Node = 0 then 1346 return True; 1347 end if; 1348 1349 declare 1350 S : Set renames Container; 1351 N : Nodes_Type renames S.Nodes; 1352 X : Count_Type; 1353 1354 begin 1355 if S.Length = 0 then 1356 return False; 1357 end if; 1358 1359 if Position.Node > N'Last then 1360 return False; 1361 end if; 1362 1363 if N (Position.Node).Next = Position.Node then 1364 return False; 1365 end if; 1366 1367 X := S.Buckets (Element_Keys.Index (S, N (Position.Node).Element)); 1368 1369 for J in 1 .. S.Length loop 1370 if X = Position.Node then 1371 return True; 1372 end if; 1373 1374 if X = 0 then 1375 return False; 1376 end if; 1377 1378 if X = N (X).Next then -- to prevent unnecessary looping 1379 return False; 1380 end if; 1381 1382 X := N (X).Next; 1383 end loop; 1384 1385 return False; 1386 end; 1387 end Vet; 1388 1389 package body Generic_Keys with SPARK_Mode => Off is 1390 1391 ----------------------- 1392 -- Local Subprograms -- 1393 ----------------------- 1394 1395 function Equivalent_Key_Node 1396 (Key : Key_Type; 1397 Node : Node_Type) return Boolean; 1398 pragma Inline (Equivalent_Key_Node); 1399 1400 -------------------------- 1401 -- Local Instantiations -- 1402 -------------------------- 1403 1404 package Key_Keys is 1405 new Hash_Tables.Generic_Bounded_Keys 1406 (HT_Types => HT_Types, 1407 Next => Next, 1408 Set_Next => Set_Next, 1409 Key_Type => Key_Type, 1410 Hash => Hash, 1411 Equivalent_Keys => Equivalent_Key_Node); 1412 1413 -------------- 1414 -- Contains -- 1415 -------------- 1416 1417 function Contains 1418 (Container : Set; 1419 Key : Key_Type) return Boolean 1420 is 1421 begin 1422 return Find (Container, Key) /= No_Element; 1423 end Contains; 1424 1425 ------------ 1426 -- Delete -- 1427 ------------ 1428 1429 procedure Delete 1430 (Container : in out Set; 1431 Key : Key_Type) 1432 is 1433 X : Count_Type; 1434 1435 begin 1436 Key_Keys.Delete_Key_Sans_Free (Container, Key, X); 1437 1438 if X = 0 then 1439 raise Constraint_Error with "attempt to delete key not in set"; 1440 end if; 1441 1442 Free (Container, X); 1443 end Delete; 1444 1445 ------------- 1446 -- Element -- 1447 ------------- 1448 1449 function Element 1450 (Container : Set; 1451 Key : Key_Type) return Element_Type 1452 is 1453 Node : constant Count_Type := Find (Container, Key).Node; 1454 1455 begin 1456 if Node = 0 then 1457 raise Constraint_Error with "key not in map"; 1458 end if; 1459 1460 return Container.Nodes (Node).Element; 1461 end Element; 1462 1463 ------------------------- 1464 -- Equivalent_Key_Node -- 1465 ------------------------- 1466 1467 function Equivalent_Key_Node 1468 (Key : Key_Type; 1469 Node : Node_Type) return Boolean 1470 is 1471 begin 1472 return Equivalent_Keys (Key, Generic_Keys.Key (Node.Element)); 1473 end Equivalent_Key_Node; 1474 1475 ------------- 1476 -- Exclude -- 1477 ------------- 1478 1479 procedure Exclude 1480 (Container : in out Set; 1481 Key : Key_Type) 1482 is 1483 X : Count_Type; 1484 begin 1485 Key_Keys.Delete_Key_Sans_Free (Container, Key, X); 1486 Free (Container, X); 1487 end Exclude; 1488 1489 ---------- 1490 -- Find -- 1491 ---------- 1492 1493 function Find 1494 (Container : Set; 1495 Key : Key_Type) return Cursor 1496 is 1497 Node : constant Count_Type := Key_Keys.Find (Container, Key); 1498 begin 1499 return (if Node = 0 then No_Element else (Node => Node)); 1500 end Find; 1501 1502 --------- 1503 -- Key -- 1504 --------- 1505 1506 function Key (Container : Set; Position : Cursor) return Key_Type is 1507 begin 1508 if not Has_Element (Container, Position) then 1509 raise Constraint_Error with 1510 "Position cursor has no element"; 1511 end if; 1512 1513 pragma Assert 1514 (Vet (Container, Position), "bad cursor in function Key"); 1515 1516 declare 1517 N : Node_Type renames Container.Nodes (Position.Node); 1518 begin 1519 return Key (N.Element); 1520 end; 1521 end Key; 1522 1523 ------------- 1524 -- Replace -- 1525 ------------- 1526 1527 procedure Replace 1528 (Container : in out Set; 1529 Key : Key_Type; 1530 New_Item : Element_Type) 1531 is 1532 Node : constant Count_Type := Key_Keys.Find (Container, Key); 1533 1534 begin 1535 if Node = 0 then 1536 raise Constraint_Error with 1537 "attempt to replace key not in set"; 1538 end if; 1539 1540 Replace_Element (Container, Node, New_Item); 1541 end Replace; 1542 1543 end Generic_Keys; 1544 1545end Ada.Containers.Formal_Hashed_Sets; 1546