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-2012, 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 Target.Length := Source.Length; 237 Target.Free := Source.Free; 238 239 H := 1; 240 while H <= Source.Modulus loop 241 Target.Buckets (H) := Source.Buckets (H); 242 H := H + 1; 243 end loop; 244 245 N := 1; 246 while N <= Source.Capacity loop 247 Target.Nodes (N) := Source.Nodes (N); 248 N := N + 1; 249 end loop; 250 251 while N <= C loop 252 Cu := (Node => N); 253 Free (Target, Cu.Node); 254 N := N + 1; 255 end loop; 256 257 return Target; 258 end Copy; 259 260 --------------------- 261 -- Default_Modulus -- 262 --------------------- 263 264 function Default_Modulus (Capacity : Count_Type) return Hash_Type is 265 begin 266 return To_Prime (Capacity); 267 end Default_Modulus; 268 269 ------------ 270 -- Delete -- 271 ------------ 272 273 procedure Delete 274 (Container : in out Set; 275 Item : Element_Type) 276 is 277 X : Count_Type; 278 279 begin 280 Element_Keys.Delete_Key_Sans_Free (Container, Item, X); 281 282 if X = 0 then 283 raise Constraint_Error with "attempt to delete element not in set"; 284 end if; 285 286 Free (Container, X); 287 end Delete; 288 289 procedure Delete 290 (Container : in out Set; 291 Position : in out Cursor) 292 is 293 begin 294 if not Has_Element (Container, Position) then 295 raise Constraint_Error with "Position cursor has no element"; 296 end if; 297 298 if Container.Busy > 0 then 299 raise Program_Error with 300 "attempt to tamper with elements (set is busy)"; 301 end if; 302 303 pragma Assert (Vet (Container, Position), "bad cursor in Delete"); 304 305 HT_Ops.Delete_Node_Sans_Free (Container, Position.Node); 306 Free (Container, Position.Node); 307 308 Position := No_Element; 309 end Delete; 310 311 ---------------- 312 -- Difference -- 313 ---------------- 314 315 procedure Difference 316 (Target : in out Set; 317 Source : Set) 318 is 319 Tgt_Node, Src_Node, Src_Last, Src_Length : Count_Type; 320 321 TN : Nodes_Type renames Target.Nodes; 322 SN : Nodes_Type renames Source.Nodes; 323 324 begin 325 if Target'Address = Source'Address then 326 Clear (Target); 327 return; 328 end if; 329 330 Src_Length := Source.Length; 331 332 if Src_Length = 0 then 333 return; 334 end if; 335 336 if Target.Busy > 0 then 337 raise Program_Error with 338 "attempt to tamper with elements (set is busy)"; 339 end if; 340 341 if Src_Length >= Target.Length then 342 Tgt_Node := HT_Ops.First (Target); 343 while Tgt_Node /= 0 loop 344 if Element_Keys.Find (Source, TN (Tgt_Node).Element) /= 0 then 345 declare 346 X : constant Count_Type := Tgt_Node; 347 begin 348 Tgt_Node := HT_Ops.Next (Target, Tgt_Node); 349 HT_Ops.Delete_Node_Sans_Free (Target, X); 350 Free (Target, X); 351 end; 352 353 else 354 Tgt_Node := HT_Ops.Next (Target, Tgt_Node); 355 end if; 356 end loop; 357 358 return; 359 else 360 Src_Node := HT_Ops.First (Source); 361 Src_Last := 0; 362 end if; 363 364 while Src_Node /= Src_Last loop 365 Tgt_Node := Element_Keys.Find (Target, SN (Src_Node).Element); 366 367 if Tgt_Node /= 0 then 368 HT_Ops.Delete_Node_Sans_Free (Target, Tgt_Node); 369 Free (Target, Tgt_Node); 370 end if; 371 372 Src_Node := HT_Ops.Next (Source, Src_Node); 373 end loop; 374 end Difference; 375 376 procedure Difference 377 (Left, Right : Set; 378 Target : in out Set) 379 is 380 procedure Process (L_Node : Count_Type); 381 382 procedure Iterate is 383 new HT_Ops.Generic_Iteration (Process); 384 385 ------------- 386 -- Process -- 387 ------------- 388 389 procedure Process (L_Node : Count_Type) is 390 E : Element_Type renames Left.Nodes (L_Node).Element; 391 X : Count_Type; 392 B : Boolean; 393 begin 394 if Find (Right, E).Node = 0 then 395 Insert (Target, E, X, B); 396 pragma Assert (B); 397 end if; 398 end Process; 399 400 -- Start of processing for Difference 401 402 begin 403 Iterate (Left); 404 end Difference; 405 406 function Difference (Left, Right : Set) return Set is 407 C : Count_Type; 408 H : Hash_Type; 409 410 begin 411 if Left'Address = Right'Address then 412 return Empty_Set; 413 end if; 414 415 if Length (Left) = 0 then 416 return Empty_Set; 417 end if; 418 419 if Length (Right) = 0 then 420 return Left.Copy; 421 end if; 422 423 C := Length (Left); 424 H := Default_Modulus (C); 425 426 return S : Set (C, H) do 427 Difference (Left, Right, Target => S); 428 end return; 429 end Difference; 430 431 ------------- 432 -- Element -- 433 ------------- 434 435 function Element 436 (Container : Set; 437 Position : Cursor) return Element_Type 438 is 439 begin 440 if not Has_Element (Container, Position) then 441 raise Constraint_Error with "Position cursor equals No_Element"; 442 end if; 443 444 pragma Assert (Vet (Container, Position), 445 "bad cursor in function Element"); 446 447 return Container.Nodes (Position.Node).Element; 448 end Element; 449 450 --------------------- 451 -- Equivalent_Sets -- 452 --------------------- 453 454 function Equivalent_Sets (Left, Right : Set) return Boolean is 455 456 function Find_Equivalent_Key 457 (R_HT : Hash_Table_Type'Class; 458 L_Node : Node_Type) return Boolean; 459 pragma Inline (Find_Equivalent_Key); 460 461 function Is_Equivalent is 462 new HT_Ops.Generic_Equal (Find_Equivalent_Key); 463 464 ------------------------- 465 -- Find_Equivalent_Key -- 466 ------------------------- 467 468 function Find_Equivalent_Key 469 (R_HT : Hash_Table_Type'Class; 470 L_Node : Node_Type) return Boolean 471 is 472 R_Index : constant Hash_Type := 473 Element_Keys.Index (R_HT, L_Node.Element); 474 R_Node : Count_Type := R_HT.Buckets (R_Index); 475 RN : Nodes_Type renames R_HT.Nodes; 476 477 begin 478 loop 479 if R_Node = 0 then 480 return False; 481 end if; 482 483 if Equivalent_Elements (L_Node.Element, 484 RN (R_Node).Element) then 485 return True; 486 end if; 487 488 R_Node := HT_Ops.Next (R_HT, R_Node); 489 end loop; 490 end Find_Equivalent_Key; 491 492 -- Start of processing of Equivalent_Sets 493 494 begin 495 return Is_Equivalent (Left, Right); 496 end Equivalent_Sets; 497 498 ------------------------- 499 -- Equivalent_Elements -- 500 ------------------------- 501 502 function Equivalent_Elements 503 (Left : Set; 504 CLeft : Cursor; 505 Right : Set; 506 CRight : Cursor) return Boolean 507 is 508 begin 509 if not Has_Element (Left, CLeft) then 510 raise Constraint_Error with 511 "Left cursor of Equivalent_Elements has no element"; 512 end if; 513 514 if not Has_Element (Right, CRight) then 515 raise Constraint_Error with 516 "Right cursor of Equivalent_Elements has no element"; 517 end if; 518 519 pragma Assert (Vet (Left, CLeft), 520 "bad Left cursor in Equivalent_Elements"); 521 pragma Assert (Vet (Right, CRight), 522 "bad Right cursor in Equivalent_Elements"); 523 524 declare 525 LN : Node_Type renames Left.Nodes (CLeft.Node); 526 RN : Node_Type renames Right.Nodes (CRight.Node); 527 begin 528 return Equivalent_Elements (LN.Element, RN.Element); 529 end; 530 end Equivalent_Elements; 531 532 function Equivalent_Elements 533 (Left : Set; 534 CLeft : Cursor; 535 Right : Element_Type) return Boolean 536 is 537 begin 538 if not Has_Element (Left, CLeft) then 539 raise Constraint_Error with 540 "Left cursor of Equivalent_Elements has no element"; 541 end if; 542 543 pragma Assert (Vet (Left, CLeft), 544 "Left cursor in Equivalent_Elements is bad"); 545 546 declare 547 LN : Node_Type renames Left.Nodes (CLeft.Node); 548 begin 549 return Equivalent_Elements (LN.Element, Right); 550 end; 551 end Equivalent_Elements; 552 553 function Equivalent_Elements 554 (Left : Element_Type; 555 Right : Set; 556 CRight : Cursor) return Boolean 557 is 558 begin 559 if not Has_Element (Right, CRight) then 560 raise Constraint_Error with 561 "Right cursor of Equivalent_Elements has no element"; 562 end if; 563 564 pragma Assert 565 (Vet (Right, CRight), 566 "Right cursor of Equivalent_Elements is bad"); 567 568 declare 569 RN : Node_Type renames Right.Nodes (CRight.Node); 570 begin 571 return Equivalent_Elements (Left, RN.Element); 572 end; 573 end Equivalent_Elements; 574 575 -- What does the following comment signify??? 576 -- NOT MODIFIED 577 578 --------------------- 579 -- Equivalent_Keys -- 580 --------------------- 581 582 function Equivalent_Keys 583 (Key : Element_Type; 584 Node : Node_Type) return Boolean 585 is 586 begin 587 return Equivalent_Elements (Key, Node.Element); 588 end Equivalent_Keys; 589 590 ------------- 591 -- Exclude -- 592 ------------- 593 594 procedure Exclude 595 (Container : in out Set; 596 Item : Element_Type) 597 is 598 X : Count_Type; 599 begin 600 Element_Keys.Delete_Key_Sans_Free (Container, Item, X); 601 Free (Container, X); 602 end Exclude; 603 604 ---------- 605 -- Find -- 606 ---------- 607 608 function Find 609 (Container : Set; 610 Item : Element_Type) return Cursor 611 is 612 Node : constant Count_Type := Element_Keys.Find (Container, Item); 613 614 begin 615 if Node = 0 then 616 return No_Element; 617 end if; 618 619 return (Node => Node); 620 end Find; 621 622 ----------- 623 -- First -- 624 ----------- 625 626 function First (Container : Set) return Cursor is 627 Node : constant Count_Type := HT_Ops.First (Container); 628 629 begin 630 if Node = 0 then 631 return No_Element; 632 end if; 633 634 return (Node => Node); 635 end First; 636 637 ---------- 638 -- Free -- 639 ---------- 640 641 procedure Free 642 (HT : in out Set; 643 X : Count_Type) 644 is 645 begin 646 HT.Nodes (X).Has_Element := False; 647 HT_Ops.Free (HT, X); 648 end Free; 649 650 ---------------------- 651 -- Generic_Allocate -- 652 ---------------------- 653 654 procedure Generic_Allocate 655 (HT : in out Set; 656 Node : out Count_Type) 657 is 658 procedure Allocate is new HT_Ops.Generic_Allocate (Set_Element); 659 begin 660 Allocate (HT, Node); 661 HT.Nodes (Node).Has_Element := True; 662 end Generic_Allocate; 663 664 ----------------- 665 -- Has_Element -- 666 ----------------- 667 668 function Has_Element (Container : Set; Position : Cursor) return Boolean is 669 begin 670 if Position.Node = 0 671 or else not Container.Nodes (Position.Node).Has_Element 672 then 673 return False; 674 end if; 675 676 return True; 677 end Has_Element; 678 679 --------------- 680 -- Hash_Node -- 681 --------------- 682 683 function Hash_Node (Node : Node_Type) return Hash_Type is 684 begin 685 return Hash (Node.Element); 686 end Hash_Node; 687 688 ------------- 689 -- Include -- 690 ------------- 691 692 procedure Include 693 (Container : in out Set; 694 New_Item : Element_Type) 695 is 696 Position : Cursor; 697 Inserted : Boolean; 698 699 begin 700 Insert (Container, New_Item, Position, Inserted); 701 702 if not Inserted then 703 if Container.Lock > 0 then 704 raise Program_Error with 705 "attempt to tamper with cursors (set is locked)"; 706 end if; 707 708 Container.Nodes (Position.Node).Element := New_Item; 709 end if; 710 end Include; 711 712 ------------ 713 -- Insert -- 714 ------------ 715 716 procedure Insert 717 (Container : in out Set; 718 New_Item : Element_Type; 719 Position : out Cursor; 720 Inserted : out Boolean) 721 is 722 begin 723 Insert (Container, New_Item, Position.Node, Inserted); 724 end Insert; 725 726 procedure Insert 727 (Container : in out Set; 728 New_Item : Element_Type) 729 is 730 Position : Cursor; 731 Inserted : Boolean; 732 733 begin 734 Insert (Container, New_Item, Position, Inserted); 735 736 if not Inserted then 737 raise Constraint_Error with 738 "attempt to insert element already in set"; 739 end if; 740 end Insert; 741 742 procedure Insert 743 (Container : in out Set; 744 New_Item : Element_Type; 745 Node : out Count_Type; 746 Inserted : out Boolean) 747 is 748 procedure Allocate_Set_Element (Node : in out Node_Type); 749 pragma Inline (Allocate_Set_Element); 750 751 function New_Node return Count_Type; 752 pragma Inline (New_Node); 753 754 procedure Local_Insert is 755 new Element_Keys.Generic_Conditional_Insert (New_Node); 756 757 procedure Allocate is 758 new Generic_Allocate (Allocate_Set_Element); 759 760 --------------------------- 761 -- Allocate_Set_Element -- 762 --------------------------- 763 764 procedure Allocate_Set_Element (Node : in out Node_Type) is 765 begin 766 Node.Element := New_Item; 767 end Allocate_Set_Element; 768 769 -------------- 770 -- New_Node -- 771 -------------- 772 773 function New_Node return Count_Type is 774 Result : Count_Type; 775 begin 776 Allocate (Container, Result); 777 return Result; 778 end New_Node; 779 780 -- Start of processing for Insert 781 782 begin 783 Local_Insert (Container, New_Item, Node, Inserted); 784 end Insert; 785 786 ------------------ 787 -- Intersection -- 788 ------------------ 789 790 procedure Intersection 791 (Target : in out Set; 792 Source : Set) 793 is 794 Tgt_Node : Count_Type; 795 TN : Nodes_Type renames Target.Nodes; 796 797 begin 798 if Target'Address = Source'Address then 799 return; 800 end if; 801 802 if Source.Length = 0 then 803 Clear (Target); 804 return; 805 end if; 806 807 if Target.Busy > 0 then 808 raise Program_Error with 809 "attempt to tamper with elements (set is busy)"; 810 end if; 811 812 Tgt_Node := HT_Ops.First (Target); 813 while Tgt_Node /= 0 loop 814 if Find (Source, TN (Tgt_Node).Element).Node /= 0 then 815 Tgt_Node := HT_Ops.Next (Target, Tgt_Node); 816 817 else 818 declare 819 X : constant Count_Type := Tgt_Node; 820 begin 821 Tgt_Node := HT_Ops.Next (Target, Tgt_Node); 822 HT_Ops.Delete_Node_Sans_Free (Target, X); 823 Free (Target, X); 824 end; 825 end if; 826 end loop; 827 end Intersection; 828 829 procedure Intersection 830 (Left : Set; 831 Right : Set; 832 Target : in out Set) 833 is 834 procedure Process (L_Node : Count_Type); 835 836 procedure Iterate is 837 new HT_Ops.Generic_Iteration (Process); 838 839 ------------- 840 -- Process -- 841 ------------- 842 843 procedure Process (L_Node : Count_Type) is 844 E : Element_Type renames Left.Nodes (L_Node).Element; 845 X : Count_Type; 846 B : Boolean; 847 848 begin 849 if Find (Right, E).Node /= 0 then 850 Insert (Target, E, X, B); 851 pragma Assert (B); 852 end if; 853 end Process; 854 855 -- Start of processing for Intersection 856 857 begin 858 Iterate (Left); 859 end Intersection; 860 861 function Intersection (Left, Right : Set) return Set is 862 C : Count_Type; 863 H : Hash_Type; 864 865 begin 866 if Left'Address = Right'Address then 867 return Left.Copy; 868 end if; 869 870 C := Count_Type'Min (Length (Left), Length (Right)); -- ??? 871 H := Default_Modulus (C); 872 873 return S : Set (C, H) do 874 if Length (Left) /= 0 and Length (Right) /= 0 then 875 Intersection (Left, Right, Target => S); 876 end if; 877 end return; 878 end Intersection; 879 880 -------------- 881 -- Is_Empty -- 882 -------------- 883 884 function Is_Empty (Container : Set) return Boolean is 885 begin 886 return Length (Container) = 0; 887 end Is_Empty; 888 889 ----------- 890 -- Is_In -- 891 ----------- 892 893 function Is_In (HT : Set; Key : Node_Type) return Boolean is 894 begin 895 return Element_Keys.Find (HT, Key.Element) /= 0; 896 end Is_In; 897 898 --------------- 899 -- Is_Subset -- 900 --------------- 901 902 function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is 903 Subset_Node : Count_Type; 904 Subset_Nodes : Nodes_Type renames Subset.Nodes; 905 906 begin 907 if Subset'Address = Of_Set'Address then 908 return True; 909 end if; 910 911 if Length (Subset) > Length (Of_Set) then 912 return False; 913 end if; 914 915 Subset_Node := First (Subset).Node; 916 while Subset_Node /= 0 loop 917 declare 918 N : Node_Type renames Subset_Nodes (Subset_Node); 919 E : Element_Type renames N.Element; 920 921 begin 922 if Find (Of_Set, E).Node = 0 then 923 return False; 924 end if; 925 end; 926 927 Subset_Node := HT_Ops.Next (Subset, Subset_Node); 928 end loop; 929 930 return True; 931 end Is_Subset; 932 933 ------------- 934 -- Iterate -- 935 ------------- 936 937 procedure Iterate 938 (Container : Set; 939 Process : 940 not null access procedure (Container : Set; Position : Cursor)) 941 is 942 procedure Process_Node (Node : Count_Type); 943 pragma Inline (Process_Node); 944 945 procedure Iterate is 946 new HT_Ops.Generic_Iteration (Process_Node); 947 948 ------------------ 949 -- Process_Node -- 950 ------------------ 951 952 procedure Process_Node (Node : Count_Type) is 953 begin 954 Process (Container, (Node => Node)); 955 end Process_Node; 956 957 B : Natural renames Container'Unrestricted_Access.Busy; 958 959 -- Start of processing for Iterate 960 961 begin 962 B := B + 1; 963 964 begin 965 Iterate (Container); 966 exception 967 when others => 968 B := B - 1; 969 raise; 970 end; 971 972 B := B - 1; 973 end Iterate; 974 975 ---------- 976 -- Left -- 977 ---------- 978 979 function Left (Container : Set; Position : Cursor) return Set is 980 Curs : Cursor := Position; 981 C : Set (Container.Capacity, Container.Modulus) := 982 Copy (Container, Container.Capacity); 983 Node : Count_Type; 984 985 begin 986 if Curs = No_Element then 987 return C; 988 end if; 989 990 if not Has_Element (Container, Curs) then 991 raise Constraint_Error; 992 end if; 993 994 while Curs.Node /= 0 loop 995 Node := Curs.Node; 996 Delete (C, Curs); 997 Curs := Next (Container, (Node => Node)); 998 end loop; 999 1000 return C; 1001 end Left; 1002 1003 ------------ 1004 -- Length -- 1005 ------------ 1006 1007 function Length (Container : Set) return Count_Type is 1008 begin 1009 return Container.Length; 1010 end Length; 1011 1012 ---------- 1013 -- Move -- 1014 ---------- 1015 1016 -- Comments??? 1017 1018 procedure Move (Target : in out Set; Source : in out Set) is 1019 NN : HT_Types.Nodes_Type renames Source.Nodes; 1020 X, Y : Count_Type; 1021 1022 begin 1023 if Target'Address = Source'Address then 1024 return; 1025 end if; 1026 1027 if Target.Capacity < Length (Source) then 1028 raise Constraint_Error with -- ??? 1029 "Source length exceeds Target capacity"; 1030 end if; 1031 1032 if Source.Busy > 0 then 1033 raise Program_Error with 1034 "attempt to tamper with cursors of Source (list is busy)"; 1035 end if; 1036 1037 Clear (Target); 1038 1039 if Source.Length = 0 then 1040 return; 1041 end if; 1042 1043 X := HT_Ops.First (Source); 1044 while X /= 0 loop 1045 Insert (Target, NN (X).Element); -- optimize??? 1046 1047 Y := HT_Ops.Next (Source, X); 1048 1049 HT_Ops.Delete_Node_Sans_Free (Source, X); 1050 Free (Source, X); 1051 1052 X := Y; 1053 end loop; 1054 end Move; 1055 1056 ---------- 1057 -- Next -- 1058 ---------- 1059 1060 function Next (Node : Node_Type) return Count_Type is 1061 begin 1062 return Node.Next; 1063 end Next; 1064 1065 function Next (Container : Set; Position : Cursor) return Cursor is 1066 begin 1067 if Position.Node = 0 then 1068 return No_Element; 1069 end if; 1070 1071 if not Has_Element (Container, Position) then 1072 raise Constraint_Error 1073 with "Position has no element"; 1074 end if; 1075 1076 pragma Assert (Vet (Container, Position), "bad cursor in Next"); 1077 1078 return (Node => HT_Ops.Next (Container, Position.Node)); 1079 end Next; 1080 1081 procedure Next (Container : Set; Position : in out Cursor) is 1082 begin 1083 Position := Next (Container, Position); 1084 end Next; 1085 1086 ------------- 1087 -- Overlap -- 1088 ------------- 1089 1090 function Overlap (Left, Right : Set) return Boolean is 1091 Left_Node : Count_Type; 1092 Left_Nodes : Nodes_Type renames Left.Nodes; 1093 1094 begin 1095 if Length (Right) = 0 or Length (Left) = 0 then 1096 return False; 1097 end if; 1098 1099 if Left'Address = Right'Address then 1100 return True; 1101 end if; 1102 1103 Left_Node := First (Left).Node; 1104 while Left_Node /= 0 loop 1105 declare 1106 N : Node_Type renames Left_Nodes (Left_Node); 1107 E : Element_Type renames N.Element; 1108 begin 1109 if Find (Right, E).Node /= 0 then 1110 return True; 1111 end if; 1112 end; 1113 1114 Left_Node := HT_Ops.Next (Left, Left_Node); 1115 end loop; 1116 1117 return False; 1118 end Overlap; 1119 1120 ------------------- 1121 -- Query_Element -- 1122 ------------------- 1123 1124 procedure Query_Element 1125 (Container : in out Set; 1126 Position : Cursor; 1127 Process : not null access procedure (Element : Element_Type)) 1128 is 1129 begin 1130 if not Has_Element (Container, Position) then 1131 raise Constraint_Error with 1132 "Position cursor of Query_Element has no element"; 1133 end if; 1134 1135 pragma Assert (Vet (Container, Position), "bad cursor in Query_Element"); 1136 1137 declare 1138 B : Natural renames Container.Busy; 1139 L : Natural renames Container.Lock; 1140 1141 begin 1142 B := B + 1; 1143 L := L + 1; 1144 1145 begin 1146 Process (Container.Nodes (Position.Node).Element); 1147 exception 1148 when others => 1149 L := L - 1; 1150 B := B - 1; 1151 raise; 1152 end; 1153 1154 L := L - 1; 1155 B := B - 1; 1156 end; 1157 end Query_Element; 1158 1159 ---------- 1160 -- Read -- 1161 ---------- 1162 1163 procedure Read 1164 (Stream : not null access Root_Stream_Type'Class; 1165 Container : out Set) 1166 is 1167 function Read_Node (Stream : not null access Root_Stream_Type'Class) 1168 return Count_Type; 1169 1170 procedure Read_Nodes is 1171 new HT_Ops.Generic_Read (Read_Node); 1172 1173 --------------- 1174 -- Read_Node -- 1175 --------------- 1176 1177 function Read_Node (Stream : not null access Root_Stream_Type'Class) 1178 return Count_Type 1179 is 1180 procedure Read_Element (Node : in out Node_Type); 1181 pragma Inline (Read_Element); 1182 1183 procedure Allocate is new Generic_Allocate (Read_Element); 1184 1185 ------------------ 1186 -- Read_Element -- 1187 ------------------ 1188 1189 procedure Read_Element (Node : in out Node_Type) is 1190 begin 1191 Element_Type'Read (Stream, Node.Element); 1192 end Read_Element; 1193 1194 Node : Count_Type; 1195 1196 -- Start of processing for Read_Node 1197 1198 begin 1199 Allocate (Container, Node); 1200 return Node; 1201 end Read_Node; 1202 1203 -- Start of processing for Read 1204 1205 begin 1206 Read_Nodes (Stream, Container); 1207 end Read; 1208 1209 procedure Read 1210 (Stream : not null access Root_Stream_Type'Class; 1211 Item : out Cursor) 1212 is 1213 begin 1214 raise Program_Error with "attempt to stream set cursor"; 1215 end Read; 1216 1217 ------------- 1218 -- Replace -- 1219 ------------- 1220 1221 procedure Replace 1222 (Container : in out Set; 1223 New_Item : Element_Type) 1224 is 1225 Node : constant Count_Type := Element_Keys.Find (Container, New_Item); 1226 1227 begin 1228 if Node = 0 then 1229 raise Constraint_Error with 1230 "attempt to replace element not in set"; 1231 end if; 1232 1233 if Container.Lock > 0 then 1234 raise Program_Error with 1235 "attempt to tamper with cursors (set is locked)"; 1236 end if; 1237 1238 Container.Nodes (Node).Element := New_Item; 1239 end Replace; 1240 1241 --------------------- 1242 -- Replace_Element -- 1243 --------------------- 1244 1245 procedure Replace_Element 1246 (Container : in out Set; 1247 Position : Cursor; 1248 New_Item : Element_Type) 1249 is 1250 begin 1251 if not Has_Element (Container, Position) then 1252 raise Constraint_Error with 1253 "Position cursor equals No_Element"; 1254 end if; 1255 1256 pragma Assert (Vet (Container, Position), 1257 "bad cursor in Replace_Element"); 1258 1259 Replace_Element (Container, Position.Node, New_Item); 1260 end Replace_Element; 1261 1262 ---------------------- 1263 -- Reserve_Capacity -- 1264 ---------------------- 1265 1266 procedure Reserve_Capacity 1267 (Container : in out Set; 1268 Capacity : Count_Type) 1269 is 1270 begin 1271 if Capacity > Container.Capacity then 1272 raise Constraint_Error with "requested capacity is too large"; 1273 end if; 1274 end Reserve_Capacity; 1275 1276 ----------- 1277 -- Right -- 1278 ----------- 1279 1280 function Right (Container : Set; Position : Cursor) return Set is 1281 Curs : Cursor := First (Container); 1282 C : Set (Container.Capacity, Container.Modulus) := 1283 Copy (Container, Container.Capacity); 1284 Node : Count_Type; 1285 1286 begin 1287 if Curs = No_Element then 1288 Clear (C); 1289 return C; 1290 end if; 1291 1292 if Position /= No_Element and not Has_Element (Container, Position) then 1293 raise Constraint_Error; 1294 end if; 1295 1296 while Curs.Node /= Position.Node loop 1297 Node := Curs.Node; 1298 Delete (C, Curs); 1299 Curs := Next (Container, (Node => Node)); 1300 end loop; 1301 1302 return C; 1303 end Right; 1304 1305 ------------------ 1306 -- Set_Element -- 1307 ------------------ 1308 1309 procedure Set_Element (Node : in out Node_Type; Item : Element_Type) is 1310 begin 1311 Node.Element := Item; 1312 end Set_Element; 1313 1314 -------------- 1315 -- Set_Next -- 1316 -------------- 1317 1318 procedure Set_Next (Node : in out Node_Type; Next : Count_Type) is 1319 begin 1320 Node.Next := Next; 1321 end Set_Next; 1322 1323 ------------------ 1324 -- Strict_Equal -- 1325 ------------------ 1326 1327 function Strict_Equal (Left, Right : Set) return Boolean is 1328 CuL : Cursor := First (Left); 1329 CuR : Cursor := First (Right); 1330 1331 begin 1332 if Length (Left) /= Length (Right) then 1333 return False; 1334 end if; 1335 1336 while CuL.Node /= 0 or CuR.Node /= 0 loop 1337 if CuL.Node /= CuR.Node 1338 or else Left.Nodes (CuL.Node).Element /= 1339 Right.Nodes (CuR.Node).Element 1340 then 1341 return False; 1342 end if; 1343 1344 CuL := Next (Left, CuL); 1345 CuR := Next (Right, CuR); 1346 end loop; 1347 1348 return True; 1349 end Strict_Equal; 1350 1351 -------------------------- 1352 -- Symmetric_Difference -- 1353 -------------------------- 1354 1355 procedure Symmetric_Difference 1356 (Target : in out Set; 1357 Source : Set) 1358 is 1359 procedure Process (Source_Node : Count_Type); 1360 pragma Inline (Process); 1361 1362 procedure Iterate is new HT_Ops.Generic_Iteration (Process); 1363 1364 ------------- 1365 -- Process -- 1366 ------------- 1367 1368 procedure Process (Source_Node : Count_Type) is 1369 N : Node_Type renames Source.Nodes (Source_Node); 1370 X : Count_Type; 1371 B : Boolean; 1372 begin 1373 if Is_In (Target, N) then 1374 Delete (Target, N.Element); 1375 else 1376 Insert (Target, N.Element, X, B); 1377 pragma Assert (B); 1378 end if; 1379 end Process; 1380 1381 -- Start of processing for Symmetric_Difference 1382 1383 begin 1384 if Target'Address = Source'Address then 1385 Clear (Target); 1386 return; 1387 end if; 1388 1389 if Length (Target) = 0 then 1390 Assign (Target, Source); 1391 return; 1392 end if; 1393 1394 if Target.Busy > 0 then 1395 raise Program_Error with 1396 "attempt to tamper with elements (set is busy)"; 1397 end if; 1398 1399 Iterate (Source); 1400 end Symmetric_Difference; 1401 1402 function Symmetric_Difference (Left, Right : Set) return Set is 1403 C : Count_Type; 1404 H : Hash_Type; 1405 1406 begin 1407 if Left'Address = Right'Address then 1408 return Empty_Set; 1409 end if; 1410 1411 if Length (Right) = 0 then 1412 return Left.Copy; 1413 end if; 1414 1415 if Length (Left) = 0 then 1416 return Right.Copy; 1417 end if; 1418 1419 C := Length (Left) + Length (Right); 1420 H := Default_Modulus (C); 1421 1422 return S : Set (C, H) do 1423 Difference (Left, Right, S); 1424 Difference (Right, Left, S); 1425 end return; 1426 end Symmetric_Difference; 1427 1428 ------------ 1429 -- To_Set -- 1430 ------------ 1431 1432 function To_Set (New_Item : Element_Type) return Set is 1433 X : Count_Type; 1434 B : Boolean; 1435 1436 begin 1437 return S : Set (Capacity => 1, Modulus => 1) do 1438 Insert (S, New_Item, X, B); 1439 pragma Assert (B); 1440 end return; 1441 end To_Set; 1442 1443 ----------- 1444 -- Union -- 1445 ----------- 1446 1447 procedure Union 1448 (Target : in out Set; 1449 Source : Set) 1450 is 1451 procedure Process (Src_Node : Count_Type); 1452 1453 procedure Iterate is 1454 new HT_Ops.Generic_Iteration (Process); 1455 1456 ------------- 1457 -- Process -- 1458 ------------- 1459 1460 procedure Process (Src_Node : Count_Type) is 1461 N : Node_Type renames Source.Nodes (Src_Node); 1462 E : Element_Type renames N.Element; 1463 1464 X : Count_Type; 1465 B : Boolean; 1466 1467 begin 1468 Insert (Target, E, X, B); 1469 end Process; 1470 1471 -- Start of processing for Union 1472 1473 begin 1474 if Target'Address = Source'Address then 1475 return; 1476 end if; 1477 1478 if Target.Busy > 0 then 1479 raise Program_Error with 1480 "attempt to tamper with elements (set is busy)"; 1481 end if; 1482 Iterate (Source); 1483 end Union; 1484 1485 function Union (Left, Right : Set) return Set is 1486 C : Count_Type; 1487 H : Hash_Type; 1488 1489 begin 1490 if Left'Address = Right'Address then 1491 return Left.Copy; 1492 end if; 1493 1494 if Length (Right) = 0 then 1495 return Left.Copy; 1496 end if; 1497 1498 if Length (Left) = 0 then 1499 return Right.Copy; 1500 end if; 1501 1502 C := Length (Left) + Length (Right); 1503 H := Default_Modulus (C); 1504 return S : Set (C, H) do 1505 Assign (Target => S, Source => Left); 1506 Union (Target => S, Source => Right); 1507 end return; 1508 end Union; 1509 1510 --------- 1511 -- Vet -- 1512 --------- 1513 1514 function Vet (Container : Set; Position : Cursor) return Boolean is 1515 begin 1516 if Position.Node = 0 then 1517 return True; 1518 end if; 1519 1520 declare 1521 S : Set renames Container; 1522 N : Nodes_Type renames S.Nodes; 1523 X : Count_Type; 1524 1525 begin 1526 if S.Length = 0 then 1527 return False; 1528 end if; 1529 1530 if Position.Node > N'Last then 1531 return False; 1532 end if; 1533 1534 if N (Position.Node).Next = Position.Node then 1535 return False; 1536 end if; 1537 1538 X := S.Buckets (Element_Keys.Index (S, N (Position.Node).Element)); 1539 1540 for J in 1 .. S.Length loop 1541 if X = Position.Node then 1542 return True; 1543 end if; 1544 1545 if X = 0 then 1546 return False; 1547 end if; 1548 1549 if X = N (X).Next then -- to prevent unnecessary looping 1550 return False; 1551 end if; 1552 1553 X := N (X).Next; 1554 end loop; 1555 1556 return False; 1557 end; 1558 end Vet; 1559 1560 ----------- 1561 -- Write -- 1562 ----------- 1563 1564 procedure Write 1565 (Stream : not null access Root_Stream_Type'Class; 1566 Container : Set) 1567 is 1568 procedure Write_Node 1569 (Stream : not null access Root_Stream_Type'Class; 1570 Node : Node_Type); 1571 pragma Inline (Write_Node); 1572 1573 procedure Write_Nodes is 1574 new HT_Ops.Generic_Write (Write_Node); 1575 1576 ---------------- 1577 -- Write_Node -- 1578 ---------------- 1579 1580 procedure Write_Node 1581 (Stream : not null access Root_Stream_Type'Class; 1582 Node : Node_Type) 1583 is 1584 begin 1585 Element_Type'Write (Stream, Node.Element); 1586 end Write_Node; 1587 1588 -- Start of processing for Write 1589 1590 begin 1591 Write_Nodes (Stream, Container); 1592 end Write; 1593 1594 procedure Write 1595 (Stream : not null access Root_Stream_Type'Class; 1596 Item : Cursor) 1597 is 1598 begin 1599 raise Program_Error with "attempt to stream set cursor"; 1600 end Write; 1601 package body Generic_Keys is 1602 1603 ----------------------- 1604 -- Local Subprograms -- 1605 ----------------------- 1606 1607 function Equivalent_Key_Node 1608 (Key : Key_Type; 1609 Node : Node_Type) return Boolean; 1610 pragma Inline (Equivalent_Key_Node); 1611 1612 -------------------------- 1613 -- Local Instantiations -- 1614 -------------------------- 1615 1616 package Key_Keys is 1617 new Hash_Tables.Generic_Bounded_Keys 1618 (HT_Types => HT_Types, 1619 Next => Next, 1620 Set_Next => Set_Next, 1621 Key_Type => Key_Type, 1622 Hash => Hash, 1623 Equivalent_Keys => Equivalent_Key_Node); 1624 1625 -------------- 1626 -- Contains -- 1627 -------------- 1628 1629 function Contains 1630 (Container : Set; 1631 Key : Key_Type) return Boolean 1632 is 1633 begin 1634 return Find (Container, Key) /= No_Element; 1635 end Contains; 1636 1637 ------------ 1638 -- Delete -- 1639 ------------ 1640 1641 procedure Delete 1642 (Container : in out Set; 1643 Key : Key_Type) 1644 is 1645 X : Count_Type; 1646 1647 begin 1648 Key_Keys.Delete_Key_Sans_Free (Container, Key, X); 1649 1650 if X = 0 then 1651 raise Constraint_Error with "attempt to delete key not in set"; 1652 end if; 1653 1654 Free (Container, X); 1655 end Delete; 1656 1657 ------------- 1658 -- Element -- 1659 ------------- 1660 1661 function Element 1662 (Container : Set; 1663 Key : Key_Type) return Element_Type 1664 is 1665 Node : constant Count_Type := Find (Container, Key).Node; 1666 1667 begin 1668 if Node = 0 then 1669 raise Constraint_Error with "key not in map"; 1670 end if; 1671 1672 return Container.Nodes (Node).Element; 1673 end Element; 1674 1675 ------------------------- 1676 -- Equivalent_Key_Node -- 1677 ------------------------- 1678 1679 function Equivalent_Key_Node 1680 (Key : Key_Type; 1681 Node : Node_Type) return Boolean 1682 is 1683 begin 1684 return Equivalent_Keys (Key, Generic_Keys.Key (Node.Element)); 1685 end Equivalent_Key_Node; 1686 1687 ------------- 1688 -- Exclude -- 1689 ------------- 1690 1691 procedure Exclude 1692 (Container : in out Set; 1693 Key : Key_Type) 1694 is 1695 X : Count_Type; 1696 begin 1697 Key_Keys.Delete_Key_Sans_Free (Container, Key, X); 1698 Free (Container, X); 1699 end Exclude; 1700 1701 ---------- 1702 -- Find -- 1703 ---------- 1704 1705 function Find 1706 (Container : Set; 1707 Key : Key_Type) return Cursor 1708 is 1709 Node : constant Count_Type := Key_Keys.Find (Container, Key); 1710 begin 1711 return (if Node = 0 then No_Element else (Node => Node)); 1712 end Find; 1713 1714 --------- 1715 -- Key -- 1716 --------- 1717 1718 function Key (Container : Set; Position : Cursor) return Key_Type is 1719 begin 1720 if not Has_Element (Container, Position) then 1721 raise Constraint_Error with 1722 "Position cursor has no element"; 1723 end if; 1724 1725 pragma Assert 1726 (Vet (Container, Position), "bad cursor in function Key"); 1727 1728 declare 1729 N : Node_Type renames Container.Nodes (Position.Node); 1730 begin 1731 return Key (N.Element); 1732 end; 1733 end Key; 1734 1735 ------------- 1736 -- Replace -- 1737 ------------- 1738 1739 procedure Replace 1740 (Container : in out Set; 1741 Key : Key_Type; 1742 New_Item : Element_Type) 1743 is 1744 Node : constant Count_Type := Key_Keys.Find (Container, Key); 1745 1746 begin 1747 if Node = 0 then 1748 raise Constraint_Error with 1749 "attempt to replace key not in set"; 1750 end if; 1751 1752 Replace_Element (Container, Node, New_Item); 1753 end Replace; 1754 1755 ----------------------------------- 1756 -- Update_Element_Preserving_Key -- 1757 ----------------------------------- 1758 1759 procedure Update_Element_Preserving_Key 1760 (Container : in out Set; 1761 Position : Cursor; 1762 Process : not null access 1763 procedure (Element : in out Element_Type)) 1764 is 1765 Indx : Hash_Type; 1766 N : Nodes_Type renames Container.Nodes; 1767 1768 begin 1769 if Position.Node = 0 then 1770 raise Constraint_Error with 1771 "Position cursor equals No_Element"; 1772 end if; 1773 1774 pragma Assert 1775 (Vet (Container, Position), 1776 "bad cursor in Update_Element_Preserving_Key"); 1777 1778 -- Record bucket now, in case key is changed 1779 1780 Indx := HT_Ops.Index (Container.Buckets, N (Position.Node)); 1781 1782 declare 1783 E : Element_Type renames N (Position.Node).Element; 1784 K : constant Key_Type := Key (E); 1785 B : Natural renames Container.Busy; 1786 L : Natural renames Container.Lock; 1787 1788 begin 1789 B := B + 1; 1790 L := L + 1; 1791 1792 begin 1793 Process (E); 1794 exception 1795 when others => 1796 L := L - 1; 1797 B := B - 1; 1798 raise; 1799 end; 1800 1801 L := L - 1; 1802 B := B - 1; 1803 1804 if Equivalent_Keys (K, Key (E)) then 1805 pragma Assert (Hash (K) = Hash (E)); 1806 return; 1807 end if; 1808 end; 1809 1810 -- Key was modified, so remove this node from set 1811 1812 if Container.Buckets (Indx) = Position.Node then 1813 Container.Buckets (Indx) := N (Position.Node).Next; 1814 1815 else 1816 declare 1817 Prev : Count_Type := Container.Buckets (Indx); 1818 1819 begin 1820 while N (Prev).Next /= Position.Node loop 1821 Prev := N (Prev).Next; 1822 1823 if Prev = 0 then 1824 raise Program_Error with 1825 "Position cursor is bad (node not found)"; 1826 end if; 1827 end loop; 1828 1829 N (Prev).Next := N (Position.Node).Next; 1830 end; 1831 end if; 1832 1833 Container.Length := Container.Length - 1; 1834 Free (Container, Position.Node); 1835 1836 raise Program_Error with "key was modified"; 1837 end Update_Element_Preserving_Key; 1838 1839 end Generic_Keys; 1840 1841end Ada.Containers.Formal_Hashed_Sets; 1842