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