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