1------------------------------------------------------------------------------ 2-- -- 3-- GNAT LIBRARY COMPONENTS -- 4-- -- 5-- A D A . C O N T A I N E R S . H A S H E D _ S E T S -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2004-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-- This unit was originally developed by Matthew J Heaney. -- 28------------------------------------------------------------------------------ 29 30with Ada.Unchecked_Deallocation; 31 32with Ada.Containers.Hash_Tables.Generic_Operations; 33pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Operations); 34 35with Ada.Containers.Hash_Tables.Generic_Keys; 36pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys); 37 38with Ada.Containers.Prime_Numbers; 39 40with System; use type System.Address; 41 42package body Ada.Containers.Hashed_Sets is 43 44 type Iterator is limited new 45 Set_Iterator_Interfaces.Forward_Iterator with record 46 Container : Set_Access; 47 end record; 48 49 overriding function First (Object : Iterator) return Cursor; 50 51 overriding function Next 52 (Object : Iterator; 53 Position : Cursor) return Cursor; 54 55 ----------------------- 56 -- Local Subprograms -- 57 ----------------------- 58 59 procedure Assign (Node : Node_Access; Item : Element_Type); 60 pragma Inline (Assign); 61 62 function Copy_Node (Source : Node_Access) return Node_Access; 63 pragma Inline (Copy_Node); 64 65 function Equivalent_Keys 66 (Key : Element_Type; 67 Node : Node_Access) return Boolean; 68 pragma Inline (Equivalent_Keys); 69 70 function Find_Equal_Key 71 (R_HT : Hash_Table_Type; 72 L_Node : Node_Access) return Boolean; 73 74 function Find_Equivalent_Key 75 (R_HT : Hash_Table_Type; 76 L_Node : Node_Access) return Boolean; 77 78 procedure Free (X : in out Node_Access); 79 80 function Hash_Node (Node : Node_Access) return Hash_Type; 81 pragma Inline (Hash_Node); 82 83 procedure Insert 84 (HT : in out Hash_Table_Type; 85 New_Item : Element_Type; 86 Node : out Node_Access; 87 Inserted : out Boolean); 88 89 function Is_In 90 (HT : Hash_Table_Type; 91 Key : Node_Access) return Boolean; 92 pragma Inline (Is_In); 93 94 function Next (Node : Node_Access) return Node_Access; 95 pragma Inline (Next); 96 97 function Read_Node (Stream : not null access Root_Stream_Type'Class) 98 return Node_Access; 99 pragma Inline (Read_Node); 100 101 procedure Set_Next (Node : Node_Access; Next : Node_Access); 102 pragma Inline (Set_Next); 103 104 function Vet (Position : Cursor) return Boolean; 105 106 procedure Write_Node 107 (Stream : not null access Root_Stream_Type'Class; 108 Node : Node_Access); 109 pragma Inline (Write_Node); 110 111 -------------------------- 112 -- Local Instantiations -- 113 -------------------------- 114 115 package HT_Ops is new Hash_Tables.Generic_Operations 116 (HT_Types => HT_Types, 117 Hash_Node => Hash_Node, 118 Next => Next, 119 Set_Next => Set_Next, 120 Copy_Node => Copy_Node, 121 Free => Free); 122 123 package Element_Keys is new Hash_Tables.Generic_Keys 124 (HT_Types => HT_Types, 125 Next => Next, 126 Set_Next => Set_Next, 127 Key_Type => Element_Type, 128 Hash => Hash, 129 Equivalent_Keys => Equivalent_Keys); 130 131 function Is_Equal is 132 new HT_Ops.Generic_Equal (Find_Equal_Key); 133 134 function Is_Equivalent is 135 new HT_Ops.Generic_Equal (Find_Equivalent_Key); 136 137 procedure Read_Nodes is 138 new HT_Ops.Generic_Read (Read_Node); 139 140 procedure Replace_Element is 141 new Element_Keys.Generic_Replace_Element (Hash_Node, Assign); 142 143 procedure Write_Nodes is 144 new HT_Ops.Generic_Write (Write_Node); 145 146 --------- 147 -- "=" -- 148 --------- 149 150 function "=" (Left, Right : Set) return Boolean is 151 begin 152 return Is_Equal (Left.HT, Right.HT); 153 end "="; 154 155 ------------ 156 -- Adjust -- 157 ------------ 158 159 procedure Adjust (Container : in out Set) is 160 begin 161 HT_Ops.Adjust (Container.HT); 162 end Adjust; 163 164 procedure Adjust (Control : in out Reference_Control_Type) is 165 begin 166 if Control.Container /= null then 167 declare 168 HT : Hash_Table_Type renames Control.Container.all.HT; 169 B : Natural renames HT.Busy; 170 L : Natural renames HT.Lock; 171 begin 172 B := B + 1; 173 L := L + 1; 174 end; 175 end if; 176 end Adjust; 177 178 ------------ 179 -- Assign -- 180 ------------ 181 182 procedure Assign (Node : Node_Access; Item : Element_Type) is 183 begin 184 Node.Element := Item; 185 end Assign; 186 187 procedure Assign (Target : in out Set; Source : Set) is 188 begin 189 if Target'Address = Source'Address then 190 return; 191 end if; 192 193 Target.Clear; 194 Target.Union (Source); 195 end Assign; 196 197 -------------- 198 -- Capacity -- 199 -------------- 200 201 function Capacity (Container : Set) return Count_Type is 202 begin 203 return HT_Ops.Capacity (Container.HT); 204 end Capacity; 205 206 ----------- 207 -- Clear -- 208 ----------- 209 210 procedure Clear (Container : in out Set) is 211 begin 212 HT_Ops.Clear (Container.HT); 213 end Clear; 214 215 ------------------------ 216 -- Constant_Reference -- 217 ------------------------ 218 219 function Constant_Reference 220 (Container : aliased Set; 221 Position : Cursor) return Constant_Reference_Type 222 is 223 begin 224 if Position.Container = null then 225 raise Constraint_Error with "Position cursor has no element"; 226 end if; 227 228 if Position.Container /= Container'Unrestricted_Access then 229 raise Program_Error with 230 "Position cursor designates wrong container"; 231 end if; 232 233 pragma Assert (Vet (Position), "bad cursor in Constant_Reference"); 234 235 declare 236 HT : Hash_Table_Type renames Position.Container.all.HT; 237 B : Natural renames HT.Busy; 238 L : Natural renames HT.Lock; 239 begin 240 return R : constant Constant_Reference_Type := 241 (Element => Position.Node.Element'Access, 242 Control => (Controlled with Container'Unrestricted_Access)) 243 do 244 B := B + 1; 245 L := L + 1; 246 end return; 247 end; 248 end Constant_Reference; 249 250 -------------- 251 -- Contains -- 252 -------------- 253 254 function Contains (Container : Set; Item : Element_Type) return Boolean is 255 begin 256 return Find (Container, Item) /= No_Element; 257 end Contains; 258 259 ---------- 260 -- Copy -- 261 ---------- 262 263 function Copy 264 (Source : Set; 265 Capacity : Count_Type := 0) return Set 266 is 267 C : Count_Type; 268 269 begin 270 if Capacity = 0 then 271 C := Source.Length; 272 273 elsif Capacity >= Source.Length then 274 C := Capacity; 275 276 else 277 raise Capacity_Error 278 with "Requested capacity is less than Source length"; 279 end if; 280 281 return Target : Set do 282 Target.Reserve_Capacity (C); 283 Target.Assign (Source); 284 end return; 285 end Copy; 286 287 --------------- 288 -- Copy_Node -- 289 --------------- 290 291 function Copy_Node (Source : Node_Access) return Node_Access is 292 begin 293 return new Node_Type'(Element => Source.Element, Next => null); 294 end Copy_Node; 295 296 ------------ 297 -- Delete -- 298 ------------ 299 300 procedure Delete 301 (Container : in out Set; 302 Item : Element_Type) 303 is 304 X : Node_Access; 305 306 begin 307 Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X); 308 309 if X = null then 310 raise Constraint_Error with "attempt to delete element not in set"; 311 end if; 312 313 Free (X); 314 end Delete; 315 316 procedure Delete 317 (Container : in out Set; 318 Position : in out Cursor) 319 is 320 begin 321 if Position.Node = null then 322 raise Constraint_Error with "Position cursor equals No_Element"; 323 end if; 324 325 if Position.Container /= Container'Unrestricted_Access then 326 raise Program_Error with "Position cursor designates wrong set"; 327 end if; 328 329 if Container.HT.Busy > 0 then 330 raise Program_Error with 331 "attempt to tamper with cursors (set is busy)"; 332 end if; 333 334 pragma Assert (Vet (Position), "bad cursor in Delete"); 335 336 HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node); 337 338 Free (Position.Node); 339 Position.Container := null; 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 : Node_Access; 351 352 begin 353 if Target'Address = Source'Address then 354 Clear (Target); 355 return; 356 end if; 357 358 if Source.HT.Length = 0 then 359 return; 360 end if; 361 362 if Target.HT.Busy > 0 then 363 raise Program_Error with 364 "attempt to tamper with cursors (set is busy)"; 365 end if; 366 367 if Source.HT.Length < Target.HT.Length then 368 declare 369 Src_Node : Node_Access; 370 371 begin 372 Src_Node := HT_Ops.First (Source.HT); 373 while Src_Node /= null loop 374 Tgt_Node := Element_Keys.Find (Target.HT, Src_Node.Element); 375 376 if Tgt_Node /= null then 377 HT_Ops.Delete_Node_Sans_Free (Target.HT, Tgt_Node); 378 Free (Tgt_Node); 379 end if; 380 381 Src_Node := HT_Ops.Next (Source.HT, Src_Node); 382 end loop; 383 end; 384 385 else 386 Tgt_Node := HT_Ops.First (Target.HT); 387 while Tgt_Node /= null loop 388 if Is_In (Source.HT, Tgt_Node) then 389 declare 390 X : Node_Access := Tgt_Node; 391 begin 392 Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node); 393 HT_Ops.Delete_Node_Sans_Free (Target.HT, X); 394 Free (X); 395 end; 396 397 else 398 Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node); 399 end if; 400 end loop; 401 end if; 402 end Difference; 403 404 function Difference (Left, Right : Set) return Set is 405 Buckets : HT_Types.Buckets_Access; 406 Length : Count_Type; 407 408 begin 409 if Left'Address = Right'Address then 410 return Empty_Set; 411 end if; 412 413 if Left.HT.Length = 0 then 414 return Empty_Set; 415 end if; 416 417 if Right.HT.Length = 0 then 418 return Left; 419 end if; 420 421 declare 422 Size : constant Hash_Type := Prime_Numbers.To_Prime (Left.Length); 423 begin 424 Buckets := HT_Ops.New_Buckets (Length => Size); 425 end; 426 427 Length := 0; 428 429 Iterate_Left : declare 430 procedure Process (L_Node : Node_Access); 431 432 procedure Iterate is 433 new HT_Ops.Generic_Iteration (Process); 434 435 ------------- 436 -- Process -- 437 ------------- 438 439 procedure Process (L_Node : Node_Access) is 440 begin 441 if not Is_In (Right.HT, L_Node) then 442 declare 443 J : constant Hash_Type := 444 Hash (L_Node.Element) mod Buckets'Length; 445 446 Bucket : Node_Access renames Buckets (J); 447 448 begin 449 Bucket := new Node_Type'(L_Node.Element, Bucket); 450 end; 451 452 Length := Length + 1; 453 end if; 454 end Process; 455 456 -- Start of processing for Iterate_Left 457 458 begin 459 Iterate (Left.HT); 460 exception 461 when others => 462 HT_Ops.Free_Hash_Table (Buckets); 463 raise; 464 end Iterate_Left; 465 466 return (Controlled with HT => (Buckets, Length, 0, 0)); 467 end Difference; 468 469 ------------- 470 -- Element -- 471 ------------- 472 473 function Element (Position : Cursor) return Element_Type is 474 begin 475 if Position.Node = null then 476 raise Constraint_Error with "Position cursor equals No_Element"; 477 end if; 478 479 pragma Assert (Vet (Position), "bad cursor in function Element"); 480 481 return Position.Node.Element; 482 end Element; 483 484 --------------------- 485 -- Equivalent_Sets -- 486 --------------------- 487 488 function Equivalent_Sets (Left, Right : Set) return Boolean is 489 begin 490 return Is_Equivalent (Left.HT, Right.HT); 491 end Equivalent_Sets; 492 493 ------------------------- 494 -- Equivalent_Elements -- 495 ------------------------- 496 497 function Equivalent_Elements (Left, Right : Cursor) 498 return Boolean is 499 begin 500 if Left.Node = null then 501 raise Constraint_Error with 502 "Left cursor of Equivalent_Elements equals No_Element"; 503 end if; 504 505 if Right.Node = null then 506 raise Constraint_Error with 507 "Right cursor of Equivalent_Elements equals No_Element"; 508 end if; 509 510 pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Elements"); 511 pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Elements"); 512 513 return Equivalent_Elements (Left.Node.Element, Right.Node.Element); 514 end Equivalent_Elements; 515 516 function Equivalent_Elements (Left : Cursor; Right : Element_Type) 517 return Boolean is 518 begin 519 if Left.Node = null then 520 raise Constraint_Error with 521 "Left cursor of Equivalent_Elements equals No_Element"; 522 end if; 523 524 pragma Assert (Vet (Left), "Left cursor in Equivalent_Elements is bad"); 525 526 return Equivalent_Elements (Left.Node.Element, Right); 527 end Equivalent_Elements; 528 529 function Equivalent_Elements (Left : Element_Type; Right : Cursor) 530 return Boolean is 531 begin 532 if Right.Node = null then 533 raise Constraint_Error with 534 "Right cursor of Equivalent_Elements equals No_Element"; 535 end if; 536 537 pragma Assert 538 (Vet (Right), 539 "Right cursor of Equivalent_Elements is bad"); 540 541 return Equivalent_Elements (Left, Right.Node.Element); 542 end Equivalent_Elements; 543 544 --------------------- 545 -- Equivalent_Keys -- 546 --------------------- 547 548 function Equivalent_Keys (Key : Element_Type; Node : Node_Access) 549 return Boolean is 550 begin 551 return Equivalent_Elements (Key, Node.Element); 552 end Equivalent_Keys; 553 554 ------------- 555 -- Exclude -- 556 ------------- 557 558 procedure Exclude 559 (Container : in out Set; 560 Item : Element_Type) 561 is 562 X : Node_Access; 563 begin 564 Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X); 565 Free (X); 566 end Exclude; 567 568 -------------- 569 -- Finalize -- 570 -------------- 571 572 procedure Finalize (Container : in out Set) is 573 begin 574 HT_Ops.Finalize (Container.HT); 575 end Finalize; 576 577 procedure Finalize (Control : in out Reference_Control_Type) is 578 begin 579 if Control.Container /= null then 580 declare 581 HT : Hash_Table_Type renames Control.Container.all.HT; 582 B : Natural renames HT.Busy; 583 L : Natural renames HT.Lock; 584 begin 585 B := B - 1; 586 L := L - 1; 587 end; 588 589 Control.Container := null; 590 end if; 591 end Finalize; 592 593 ---------- 594 -- Find -- 595 ---------- 596 597 function Find 598 (Container : Set; 599 Item : Element_Type) return Cursor 600 is 601 Node : constant Node_Access := Element_Keys.Find (Container.HT, Item); 602 603 begin 604 if Node = null then 605 return No_Element; 606 end if; 607 608 return Cursor'(Container'Unrestricted_Access, Node); 609 end Find; 610 611 -------------------- 612 -- Find_Equal_Key -- 613 -------------------- 614 615 function Find_Equal_Key 616 (R_HT : Hash_Table_Type; 617 L_Node : Node_Access) return Boolean 618 is 619 R_Index : constant Hash_Type := 620 Element_Keys.Index (R_HT, L_Node.Element); 621 622 R_Node : Node_Access := R_HT.Buckets (R_Index); 623 624 begin 625 loop 626 if R_Node = null then 627 return False; 628 end if; 629 630 if L_Node.Element = R_Node.Element then 631 return True; 632 end if; 633 634 R_Node := Next (R_Node); 635 end loop; 636 end Find_Equal_Key; 637 638 ------------------------- 639 -- Find_Equivalent_Key -- 640 ------------------------- 641 642 function Find_Equivalent_Key 643 (R_HT : Hash_Table_Type; 644 L_Node : Node_Access) return Boolean 645 is 646 R_Index : constant Hash_Type := 647 Element_Keys.Index (R_HT, L_Node.Element); 648 649 R_Node : Node_Access := R_HT.Buckets (R_Index); 650 651 begin 652 loop 653 if R_Node = null then 654 return False; 655 end if; 656 657 if Equivalent_Elements (L_Node.Element, R_Node.Element) then 658 return True; 659 end if; 660 661 R_Node := Next (R_Node); 662 end loop; 663 end Find_Equivalent_Key; 664 665 ----------- 666 -- First -- 667 ----------- 668 669 function First (Container : Set) return Cursor is 670 Node : constant Node_Access := HT_Ops.First (Container.HT); 671 672 begin 673 if Node = null then 674 return No_Element; 675 end if; 676 677 return Cursor'(Container'Unrestricted_Access, Node); 678 end First; 679 680 function First (Object : Iterator) return Cursor is 681 begin 682 return Object.Container.First; 683 end First; 684 685 ---------- 686 -- Free -- 687 ---------- 688 689 procedure Free (X : in out Node_Access) is 690 procedure Deallocate is 691 new Ada.Unchecked_Deallocation (Node_Type, Node_Access); 692 693 begin 694 if X /= null then 695 X.Next := X; -- detect mischief (in Vet) 696 Deallocate (X); 697 end if; 698 end Free; 699 700 ----------------- 701 -- Has_Element -- 702 ----------------- 703 704 function Has_Element (Position : Cursor) return Boolean is 705 begin 706 pragma Assert (Vet (Position), "bad cursor in Has_Element"); 707 return Position.Node /= null; 708 end Has_Element; 709 710 --------------- 711 -- Hash_Node -- 712 --------------- 713 714 function Hash_Node (Node : Node_Access) return Hash_Type is 715 begin 716 return Hash (Node.Element); 717 end Hash_Node; 718 719 ------------- 720 -- Include -- 721 ------------- 722 723 procedure Include 724 (Container : in out Set; 725 New_Item : Element_Type) 726 is 727 Position : Cursor; 728 Inserted : Boolean; 729 730 begin 731 Insert (Container, New_Item, Position, Inserted); 732 733 if not Inserted then 734 if Container.HT.Lock > 0 then 735 raise Program_Error with 736 "attempt to tamper with elements (set is locked)"; 737 end if; 738 739 Position.Node.Element := New_Item; 740 end if; 741 end Include; 742 743 ------------ 744 -- Insert -- 745 ------------ 746 747 procedure Insert 748 (Container : in out Set; 749 New_Item : Element_Type; 750 Position : out Cursor; 751 Inserted : out Boolean) 752 is 753 begin 754 Insert (Container.HT, New_Item, Position.Node, Inserted); 755 Position.Container := Container'Unchecked_Access; 756 end Insert; 757 758 procedure Insert 759 (Container : in out Set; 760 New_Item : Element_Type) 761 is 762 Position : Cursor; 763 pragma Unreferenced (Position); 764 765 Inserted : Boolean; 766 767 begin 768 Insert (Container, New_Item, Position, Inserted); 769 770 if not Inserted then 771 raise Constraint_Error with 772 "attempt to insert element already in set"; 773 end if; 774 end Insert; 775 776 procedure Insert 777 (HT : in out Hash_Table_Type; 778 New_Item : Element_Type; 779 Node : out Node_Access; 780 Inserted : out Boolean) 781 is 782 function New_Node (Next : Node_Access) return Node_Access; 783 pragma Inline (New_Node); 784 785 procedure Local_Insert is 786 new Element_Keys.Generic_Conditional_Insert (New_Node); 787 788 -------------- 789 -- New_Node -- 790 -------------- 791 792 function New_Node (Next : Node_Access) return Node_Access is 793 begin 794 return new Node_Type'(New_Item, Next); 795 end New_Node; 796 797 -- Start of processing for Insert 798 799 begin 800 if HT_Ops.Capacity (HT) = 0 then 801 HT_Ops.Reserve_Capacity (HT, 1); 802 end if; 803 804 Local_Insert (HT, New_Item, Node, Inserted); 805 806 if Inserted 807 and then HT.Length > HT_Ops.Capacity (HT) 808 then 809 HT_Ops.Reserve_Capacity (HT, HT.Length); 810 end if; 811 end Insert; 812 813 ------------------ 814 -- Intersection -- 815 ------------------ 816 817 procedure Intersection 818 (Target : in out Set; 819 Source : Set) 820 is 821 Tgt_Node : Node_Access; 822 823 begin 824 if Target'Address = Source'Address then 825 return; 826 end if; 827 828 if Source.HT.Length = 0 then 829 Clear (Target); 830 return; 831 end if; 832 833 if Target.HT.Busy > 0 then 834 raise Program_Error with 835 "attempt to tamper with cursors (set is busy)"; 836 end if; 837 838 Tgt_Node := HT_Ops.First (Target.HT); 839 while Tgt_Node /= null loop 840 if Is_In (Source.HT, Tgt_Node) then 841 Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node); 842 843 else 844 declare 845 X : Node_Access := Tgt_Node; 846 begin 847 Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node); 848 HT_Ops.Delete_Node_Sans_Free (Target.HT, X); 849 Free (X); 850 end; 851 end if; 852 end loop; 853 end Intersection; 854 855 function Intersection (Left, Right : Set) return Set is 856 Buckets : HT_Types.Buckets_Access; 857 Length : Count_Type; 858 859 begin 860 if Left'Address = Right'Address then 861 return Left; 862 end if; 863 864 Length := Count_Type'Min (Left.Length, Right.Length); 865 866 if Length = 0 then 867 return Empty_Set; 868 end if; 869 870 declare 871 Size : constant Hash_Type := Prime_Numbers.To_Prime (Length); 872 begin 873 Buckets := HT_Ops.New_Buckets (Length => Size); 874 end; 875 876 Length := 0; 877 878 Iterate_Left : declare 879 procedure Process (L_Node : Node_Access); 880 881 procedure Iterate is 882 new HT_Ops.Generic_Iteration (Process); 883 884 ------------- 885 -- Process -- 886 ------------- 887 888 procedure Process (L_Node : Node_Access) is 889 begin 890 if Is_In (Right.HT, L_Node) then 891 declare 892 J : constant Hash_Type := 893 Hash (L_Node.Element) mod Buckets'Length; 894 895 Bucket : Node_Access renames Buckets (J); 896 897 begin 898 Bucket := new Node_Type'(L_Node.Element, Bucket); 899 end; 900 901 Length := Length + 1; 902 end if; 903 end Process; 904 905 -- Start of processing for Iterate_Left 906 907 begin 908 Iterate (Left.HT); 909 exception 910 when others => 911 HT_Ops.Free_Hash_Table (Buckets); 912 raise; 913 end Iterate_Left; 914 915 return (Controlled with HT => (Buckets, Length, 0, 0)); 916 end Intersection; 917 918 -------------- 919 -- Is_Empty -- 920 -------------- 921 922 function Is_Empty (Container : Set) return Boolean is 923 begin 924 return Container.HT.Length = 0; 925 end Is_Empty; 926 927 ----------- 928 -- Is_In -- 929 ----------- 930 931 function Is_In (HT : Hash_Table_Type; Key : Node_Access) return Boolean is 932 begin 933 return Element_Keys.Find (HT, Key.Element) /= null; 934 end Is_In; 935 936 --------------- 937 -- Is_Subset -- 938 --------------- 939 940 function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is 941 Subset_Node : Node_Access; 942 943 begin 944 if Subset'Address = Of_Set'Address then 945 return True; 946 end if; 947 948 if Subset.Length > Of_Set.Length then 949 return False; 950 end if; 951 952 Subset_Node := HT_Ops.First (Subset.HT); 953 while Subset_Node /= null loop 954 if not Is_In (Of_Set.HT, Subset_Node) then 955 return False; 956 end if; 957 Subset_Node := HT_Ops.Next (Subset.HT, Subset_Node); 958 end loop; 959 960 return True; 961 end Is_Subset; 962 963 ------------- 964 -- Iterate -- 965 ------------- 966 967 procedure Iterate 968 (Container : Set; 969 Process : not null access procedure (Position : Cursor)) 970 is 971 procedure Process_Node (Node : Node_Access); 972 pragma Inline (Process_Node); 973 974 procedure Iterate is 975 new HT_Ops.Generic_Iteration (Process_Node); 976 977 ------------------ 978 -- Process_Node -- 979 ------------------ 980 981 procedure Process_Node (Node : Node_Access) is 982 begin 983 Process (Cursor'(Container'Unrestricted_Access, Node)); 984 end Process_Node; 985 986 B : Natural renames Container'Unrestricted_Access.HT.Busy; 987 988 -- Start of processing for Iterate 989 990 begin 991 B := B + 1; 992 993 begin 994 Iterate (Container.HT); 995 exception 996 when others => 997 B := B - 1; 998 raise; 999 end; 1000 1001 B := B - 1; 1002 end Iterate; 1003 1004 function Iterate 1005 (Container : Set) return Set_Iterator_Interfaces.Forward_Iterator'Class 1006 is 1007 begin 1008 return Iterator'(Container => Container'Unrestricted_Access); 1009 end Iterate; 1010 1011 ------------ 1012 -- Length -- 1013 ------------ 1014 1015 function Length (Container : Set) return Count_Type is 1016 begin 1017 return Container.HT.Length; 1018 end Length; 1019 1020 ---------- 1021 -- Move -- 1022 ---------- 1023 1024 procedure Move (Target : in out Set; Source : in out Set) is 1025 begin 1026 HT_Ops.Move (Target => Target.HT, Source => Source.HT); 1027 end Move; 1028 1029 ---------- 1030 -- Next -- 1031 ---------- 1032 1033 function Next (Node : Node_Access) return Node_Access is 1034 begin 1035 return Node.Next; 1036 end Next; 1037 1038 function Next (Position : Cursor) return Cursor is 1039 begin 1040 if Position.Node = null then 1041 return No_Element; 1042 end if; 1043 1044 pragma Assert (Vet (Position), "bad cursor in Next"); 1045 1046 declare 1047 HT : Hash_Table_Type renames Position.Container.HT; 1048 Node : constant Node_Access := HT_Ops.Next (HT, Position.Node); 1049 1050 begin 1051 if Node = null then 1052 return No_Element; 1053 end if; 1054 1055 return Cursor'(Position.Container, Node); 1056 end; 1057 end Next; 1058 1059 procedure Next (Position : in out Cursor) is 1060 begin 1061 Position := Next (Position); 1062 end Next; 1063 1064 function Next 1065 (Object : Iterator; 1066 Position : Cursor) return Cursor 1067 is 1068 begin 1069 if Position.Container = null then 1070 return No_Element; 1071 end if; 1072 1073 if Position.Container /= Object.Container then 1074 raise Program_Error with 1075 "Position cursor of Next designates wrong set"; 1076 end if; 1077 1078 return Next (Position); 1079 end Next; 1080 1081 ------------- 1082 -- Overlap -- 1083 ------------- 1084 1085 function Overlap (Left, Right : Set) return Boolean is 1086 Left_Node : Node_Access; 1087 1088 begin 1089 if Right.Length = 0 then 1090 return False; 1091 end if; 1092 1093 if Left'Address = Right'Address then 1094 return True; 1095 end if; 1096 1097 Left_Node := HT_Ops.First (Left.HT); 1098 while Left_Node /= null loop 1099 if Is_In (Right.HT, Left_Node) then 1100 return True; 1101 end if; 1102 Left_Node := HT_Ops.Next (Left.HT, Left_Node); 1103 end loop; 1104 1105 return False; 1106 end Overlap; 1107 1108 ------------------- 1109 -- Query_Element -- 1110 ------------------- 1111 1112 procedure Query_Element 1113 (Position : Cursor; 1114 Process : not null access procedure (Element : Element_Type)) 1115 is 1116 begin 1117 if Position.Node = null then 1118 raise Constraint_Error with 1119 "Position cursor of Query_Element equals No_Element"; 1120 end if; 1121 1122 pragma Assert (Vet (Position), "bad cursor in Query_Element"); 1123 1124 declare 1125 HT : Hash_Table_Type renames Position.Container.HT; 1126 1127 B : Natural renames HT.Busy; 1128 L : Natural renames HT.Lock; 1129 1130 begin 1131 B := B + 1; 1132 L := L + 1; 1133 1134 begin 1135 Process (Position.Node.Element); 1136 exception 1137 when others => 1138 L := L - 1; 1139 B := B - 1; 1140 raise; 1141 end; 1142 1143 L := L - 1; 1144 B := B - 1; 1145 end; 1146 end Query_Element; 1147 1148 ---------- 1149 -- Read -- 1150 ---------- 1151 1152 procedure Read 1153 (Stream : not null access Root_Stream_Type'Class; 1154 Container : out Set) 1155 is 1156 begin 1157 Read_Nodes (Stream, Container.HT); 1158 end Read; 1159 1160 procedure Read 1161 (Stream : not null access Root_Stream_Type'Class; 1162 Item : out Cursor) 1163 is 1164 begin 1165 raise Program_Error with "attempt to stream set cursor"; 1166 end Read; 1167 1168 procedure Read 1169 (Stream : not null access Root_Stream_Type'Class; 1170 Item : out Constant_Reference_Type) 1171 is 1172 begin 1173 raise Program_Error with "attempt to stream reference"; 1174 end Read; 1175 1176 --------------- 1177 -- Read_Node -- 1178 --------------- 1179 1180 function Read_Node (Stream : not null access Root_Stream_Type'Class) 1181 return Node_Access 1182 is 1183 Node : Node_Access := new Node_Type; 1184 1185 begin 1186 Element_Type'Read (Stream, Node.Element); 1187 return Node; 1188 exception 1189 when others => 1190 Free (Node); 1191 raise; 1192 end Read_Node; 1193 1194 ------------- 1195 -- Replace -- 1196 ------------- 1197 1198 procedure Replace 1199 (Container : in out Set; 1200 New_Item : Element_Type) 1201 is 1202 Node : constant Node_Access := 1203 Element_Keys.Find (Container.HT, New_Item); 1204 1205 begin 1206 if Node = null then 1207 raise Constraint_Error with 1208 "attempt to replace element not in set"; 1209 end if; 1210 1211 if Container.HT.Lock > 0 then 1212 raise Program_Error with 1213 "attempt to tamper with elements (set is locked)"; 1214 end if; 1215 1216 Node.Element := New_Item; 1217 end Replace; 1218 1219 procedure Replace_Element 1220 (Container : in out Set; 1221 Position : Cursor; 1222 New_Item : Element_Type) 1223 is 1224 begin 1225 if Position.Node = null then 1226 raise Constraint_Error with 1227 "Position cursor equals No_Element"; 1228 end if; 1229 1230 if Position.Container /= Container'Unrestricted_Access then 1231 raise Program_Error with 1232 "Position cursor designates wrong set"; 1233 end if; 1234 1235 pragma Assert (Vet (Position), "bad cursor in Replace_Element"); 1236 1237 Replace_Element (Container.HT, Position.Node, New_Item); 1238 end Replace_Element; 1239 1240 ---------------------- 1241 -- Reserve_Capacity -- 1242 ---------------------- 1243 1244 procedure Reserve_Capacity 1245 (Container : in out Set; 1246 Capacity : Count_Type) 1247 is 1248 begin 1249 HT_Ops.Reserve_Capacity (Container.HT, Capacity); 1250 end Reserve_Capacity; 1251 1252 -------------- 1253 -- Set_Next -- 1254 -------------- 1255 1256 procedure Set_Next (Node : Node_Access; Next : Node_Access) is 1257 begin 1258 Node.Next := Next; 1259 end Set_Next; 1260 1261 -------------------------- 1262 -- Symmetric_Difference -- 1263 -------------------------- 1264 1265 procedure Symmetric_Difference 1266 (Target : in out Set; 1267 Source : Set) 1268 is 1269 begin 1270 if Target'Address = Source'Address then 1271 Clear (Target); 1272 return; 1273 end if; 1274 1275 if Target.HT.Busy > 0 then 1276 raise Program_Error with 1277 "attempt to tamper with cursors (set is busy)"; 1278 end if; 1279 1280 declare 1281 N : constant Count_Type := Target.Length + Source.Length; 1282 begin 1283 if N > HT_Ops.Capacity (Target.HT) then 1284 HT_Ops.Reserve_Capacity (Target.HT, N); 1285 end if; 1286 end; 1287 1288 if Target.Length = 0 then 1289 Iterate_Source_When_Empty_Target : declare 1290 procedure Process (Src_Node : Node_Access); 1291 1292 procedure Iterate is 1293 new HT_Ops.Generic_Iteration (Process); 1294 1295 ------------- 1296 -- Process -- 1297 ------------- 1298 1299 procedure Process (Src_Node : Node_Access) is 1300 E : Element_Type renames Src_Node.Element; 1301 B : Buckets_Type renames Target.HT.Buckets.all; 1302 J : constant Hash_Type := Hash (E) mod B'Length; 1303 N : Count_Type renames Target.HT.Length; 1304 1305 begin 1306 B (J) := new Node_Type'(E, B (J)); 1307 N := N + 1; 1308 end Process; 1309 1310 -- Start of processing for Iterate_Source_When_Empty_Target 1311 1312 begin 1313 Iterate (Source.HT); 1314 end Iterate_Source_When_Empty_Target; 1315 1316 else 1317 Iterate_Source : declare 1318 procedure Process (Src_Node : Node_Access); 1319 1320 procedure Iterate is 1321 new HT_Ops.Generic_Iteration (Process); 1322 1323 ------------- 1324 -- Process -- 1325 ------------- 1326 1327 procedure Process (Src_Node : Node_Access) is 1328 E : Element_Type renames Src_Node.Element; 1329 B : Buckets_Type renames Target.HT.Buckets.all; 1330 J : constant Hash_Type := Hash (E) mod B'Length; 1331 N : Count_Type renames Target.HT.Length; 1332 1333 begin 1334 if B (J) = null then 1335 B (J) := new Node_Type'(E, null); 1336 N := N + 1; 1337 1338 elsif Equivalent_Elements (E, B (J).Element) then 1339 declare 1340 X : Node_Access := B (J); 1341 begin 1342 B (J) := B (J).Next; 1343 N := N - 1; 1344 Free (X); 1345 end; 1346 1347 else 1348 declare 1349 Prev : Node_Access := B (J); 1350 Curr : Node_Access := Prev.Next; 1351 1352 begin 1353 while Curr /= null loop 1354 if Equivalent_Elements (E, Curr.Element) then 1355 Prev.Next := Curr.Next; 1356 N := N - 1; 1357 Free (Curr); 1358 return; 1359 end if; 1360 1361 Prev := Curr; 1362 Curr := Prev.Next; 1363 end loop; 1364 1365 B (J) := new Node_Type'(E, B (J)); 1366 N := N + 1; 1367 end; 1368 end if; 1369 end Process; 1370 1371 -- Start of processing for Iterate_Source 1372 1373 begin 1374 Iterate (Source.HT); 1375 end Iterate_Source; 1376 end if; 1377 end Symmetric_Difference; 1378 1379 function Symmetric_Difference (Left, Right : Set) return Set is 1380 Buckets : HT_Types.Buckets_Access; 1381 Length : Count_Type; 1382 1383 begin 1384 if Left'Address = Right'Address then 1385 return Empty_Set; 1386 end if; 1387 1388 if Right.Length = 0 then 1389 return Left; 1390 end if; 1391 1392 if Left.Length = 0 then 1393 return Right; 1394 end if; 1395 1396 declare 1397 Size : constant Hash_Type := 1398 Prime_Numbers.To_Prime (Left.Length + Right.Length); 1399 begin 1400 Buckets := HT_Ops.New_Buckets (Length => Size); 1401 end; 1402 1403 Length := 0; 1404 1405 Iterate_Left : declare 1406 procedure Process (L_Node : Node_Access); 1407 1408 procedure Iterate is 1409 new HT_Ops.Generic_Iteration (Process); 1410 1411 ------------- 1412 -- Process -- 1413 ------------- 1414 1415 procedure Process (L_Node : Node_Access) is 1416 begin 1417 if not Is_In (Right.HT, L_Node) then 1418 declare 1419 E : Element_Type renames L_Node.Element; 1420 J : constant Hash_Type := Hash (E) mod Buckets'Length; 1421 1422 begin 1423 Buckets (J) := new Node_Type'(E, Buckets (J)); 1424 Length := Length + 1; 1425 end; 1426 end if; 1427 end Process; 1428 1429 -- Start of processing for Iterate_Left 1430 1431 begin 1432 Iterate (Left.HT); 1433 exception 1434 when others => 1435 HT_Ops.Free_Hash_Table (Buckets); 1436 raise; 1437 end Iterate_Left; 1438 1439 Iterate_Right : declare 1440 procedure Process (R_Node : Node_Access); 1441 1442 procedure Iterate is 1443 new HT_Ops.Generic_Iteration (Process); 1444 1445 ------------- 1446 -- Process -- 1447 ------------- 1448 1449 procedure Process (R_Node : Node_Access) is 1450 begin 1451 if not Is_In (Left.HT, R_Node) then 1452 declare 1453 E : Element_Type renames R_Node.Element; 1454 J : constant Hash_Type := Hash (E) mod Buckets'Length; 1455 1456 begin 1457 Buckets (J) := new Node_Type'(E, Buckets (J)); 1458 Length := Length + 1; 1459 end; 1460 end if; 1461 end Process; 1462 1463 -- Start of processing for Iterate_Right 1464 1465 begin 1466 Iterate (Right.HT); 1467 exception 1468 when others => 1469 HT_Ops.Free_Hash_Table (Buckets); 1470 raise; 1471 end Iterate_Right; 1472 1473 return (Controlled with HT => (Buckets, Length, 0, 0)); 1474 end Symmetric_Difference; 1475 1476 ------------ 1477 -- To_Set -- 1478 ------------ 1479 1480 function To_Set (New_Item : Element_Type) return Set is 1481 HT : Hash_Table_Type; 1482 1483 Node : Node_Access; 1484 Inserted : Boolean; 1485 pragma Unreferenced (Node, Inserted); 1486 1487 begin 1488 Insert (HT, New_Item, Node, Inserted); 1489 return Set'(Controlled with HT); 1490 end To_Set; 1491 1492 ----------- 1493 -- Union -- 1494 ----------- 1495 1496 procedure Union 1497 (Target : in out Set; 1498 Source : Set) 1499 is 1500 procedure Process (Src_Node : Node_Access); 1501 1502 procedure Iterate is 1503 new HT_Ops.Generic_Iteration (Process); 1504 1505 ------------- 1506 -- Process -- 1507 ------------- 1508 1509 procedure Process (Src_Node : Node_Access) is 1510 function New_Node (Next : Node_Access) return Node_Access; 1511 pragma Inline (New_Node); 1512 1513 procedure Insert is 1514 new Element_Keys.Generic_Conditional_Insert (New_Node); 1515 1516 -------------- 1517 -- New_Node -- 1518 -------------- 1519 1520 function New_Node (Next : Node_Access) return Node_Access is 1521 Node : constant Node_Access := 1522 new Node_Type'(Src_Node.Element, Next); 1523 begin 1524 return Node; 1525 end New_Node; 1526 1527 Tgt_Node : Node_Access; 1528 Success : Boolean; 1529 pragma Unreferenced (Tgt_Node, Success); 1530 1531 -- Start of processing for Process 1532 1533 begin 1534 Insert (Target.HT, Src_Node.Element, Tgt_Node, Success); 1535 end Process; 1536 1537 -- Start of processing for Union 1538 1539 begin 1540 if Target'Address = Source'Address then 1541 return; 1542 end if; 1543 1544 if Target.HT.Busy > 0 then 1545 raise Program_Error with 1546 "attempt to tamper with cursors (set is busy)"; 1547 end if; 1548 1549 declare 1550 N : constant Count_Type := Target.Length + Source.Length; 1551 begin 1552 if N > HT_Ops.Capacity (Target.HT) then 1553 HT_Ops.Reserve_Capacity (Target.HT, N); 1554 end if; 1555 end; 1556 1557 Iterate (Source.HT); 1558 end Union; 1559 1560 function Union (Left, Right : Set) return Set is 1561 Buckets : HT_Types.Buckets_Access; 1562 Length : Count_Type; 1563 1564 begin 1565 if Left'Address = Right'Address then 1566 return Left; 1567 end if; 1568 1569 if Right.Length = 0 then 1570 return Left; 1571 end if; 1572 1573 if Left.Length = 0 then 1574 return Right; 1575 end if; 1576 1577 declare 1578 Size : constant Hash_Type := 1579 Prime_Numbers.To_Prime (Left.Length + Right.Length); 1580 begin 1581 Buckets := HT_Ops.New_Buckets (Length => Size); 1582 end; 1583 1584 Iterate_Left : declare 1585 procedure Process (L_Node : Node_Access); 1586 1587 procedure Iterate is 1588 new HT_Ops.Generic_Iteration (Process); 1589 1590 ------------- 1591 -- Process -- 1592 ------------- 1593 1594 procedure Process (L_Node : Node_Access) is 1595 J : constant Hash_Type := 1596 Hash (L_Node.Element) mod Buckets'Length; 1597 1598 begin 1599 Buckets (J) := new Node_Type'(L_Node.Element, Buckets (J)); 1600 end Process; 1601 1602 -- Start of processing for Iterate_Left 1603 1604 begin 1605 Iterate (Left.HT); 1606 exception 1607 when others => 1608 HT_Ops.Free_Hash_Table (Buckets); 1609 raise; 1610 end Iterate_Left; 1611 1612 Length := Left.Length; 1613 1614 Iterate_Right : declare 1615 procedure Process (Src_Node : Node_Access); 1616 1617 procedure Iterate is 1618 new HT_Ops.Generic_Iteration (Process); 1619 1620 ------------- 1621 -- Process -- 1622 ------------- 1623 1624 procedure Process (Src_Node : Node_Access) is 1625 J : constant Hash_Type := 1626 Hash (Src_Node.Element) mod Buckets'Length; 1627 1628 Tgt_Node : Node_Access := Buckets (J); 1629 1630 begin 1631 while Tgt_Node /= null loop 1632 if Equivalent_Elements (Src_Node.Element, Tgt_Node.Element) then 1633 return; 1634 end if; 1635 1636 Tgt_Node := Next (Tgt_Node); 1637 end loop; 1638 1639 Buckets (J) := new Node_Type'(Src_Node.Element, Buckets (J)); 1640 Length := Length + 1; 1641 end Process; 1642 1643 -- Start of processing for Iterate_Right 1644 1645 begin 1646 Iterate (Right.HT); 1647 exception 1648 when others => 1649 HT_Ops.Free_Hash_Table (Buckets); 1650 raise; 1651 end Iterate_Right; 1652 1653 return (Controlled with HT => (Buckets, Length, 0, 0)); 1654 end Union; 1655 1656 --------- 1657 -- Vet -- 1658 --------- 1659 1660 function Vet (Position : Cursor) return Boolean is 1661 begin 1662 if Position.Node = null then 1663 return Position.Container = null; 1664 end if; 1665 1666 if Position.Container = null then 1667 return False; 1668 end if; 1669 1670 if Position.Node.Next = Position.Node then 1671 return False; 1672 end if; 1673 1674 declare 1675 HT : Hash_Table_Type renames Position.Container.HT; 1676 X : Node_Access; 1677 1678 begin 1679 if HT.Length = 0 then 1680 return False; 1681 end if; 1682 1683 if HT.Buckets = null 1684 or else HT.Buckets'Length = 0 1685 then 1686 return False; 1687 end if; 1688 1689 X := HT.Buckets (Element_Keys.Index (HT, Position.Node.Element)); 1690 1691 for J in 1 .. HT.Length loop 1692 if X = Position.Node then 1693 return True; 1694 end if; 1695 1696 if X = null then 1697 return False; 1698 end if; 1699 1700 if X = X.Next then -- to prevent unnecessary looping 1701 return False; 1702 end if; 1703 1704 X := X.Next; 1705 end loop; 1706 1707 return False; 1708 end; 1709 end Vet; 1710 1711 ----------- 1712 -- Write -- 1713 ----------- 1714 1715 procedure Write 1716 (Stream : not null access Root_Stream_Type'Class; 1717 Container : Set) 1718 is 1719 begin 1720 Write_Nodes (Stream, Container.HT); 1721 end Write; 1722 1723 procedure Write 1724 (Stream : not null access Root_Stream_Type'Class; 1725 Item : Cursor) 1726 is 1727 begin 1728 raise Program_Error with "attempt to stream set cursor"; 1729 end Write; 1730 1731 procedure Write 1732 (Stream : not null access Root_Stream_Type'Class; 1733 Item : Constant_Reference_Type) 1734 is 1735 begin 1736 raise Program_Error with "attempt to stream reference"; 1737 end Write; 1738 1739 ---------------- 1740 -- Write_Node -- 1741 ---------------- 1742 1743 procedure Write_Node 1744 (Stream : not null access Root_Stream_Type'Class; 1745 Node : Node_Access) 1746 is 1747 begin 1748 Element_Type'Write (Stream, Node.Element); 1749 end Write_Node; 1750 1751 package body Generic_Keys is 1752 1753 ----------------------- 1754 -- Local Subprograms -- 1755 ----------------------- 1756 1757 function Equivalent_Key_Node 1758 (Key : Key_Type; 1759 Node : Node_Access) return Boolean; 1760 pragma Inline (Equivalent_Key_Node); 1761 1762 -------------------------- 1763 -- Local Instantiations -- 1764 -------------------------- 1765 1766 package Key_Keys is 1767 new Hash_Tables.Generic_Keys 1768 (HT_Types => HT_Types, 1769 Next => Next, 1770 Set_Next => Set_Next, 1771 Key_Type => Key_Type, 1772 Hash => Hash, 1773 Equivalent_Keys => Equivalent_Key_Node); 1774 1775 ------------------------ 1776 -- Constant_Reference -- 1777 ------------------------ 1778 1779 function Constant_Reference 1780 (Container : aliased Set; 1781 Key : Key_Type) return Constant_Reference_Type 1782 is 1783 Node : constant Node_Access := Key_Keys.Find (Container.HT, Key); 1784 1785 begin 1786 if Node = null then 1787 raise Constraint_Error with "Key not in set"; 1788 end if; 1789 1790 declare 1791 HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT; 1792 B : Natural renames HT.Busy; 1793 L : Natural renames HT.Lock; 1794 begin 1795 return R : constant Constant_Reference_Type := 1796 (Element => Node.Element'Access, 1797 Control => (Controlled with Container'Unrestricted_Access)) 1798 do 1799 B := B + 1; 1800 L := L + 1; 1801 end return; 1802 end; 1803 end Constant_Reference; 1804 1805 -------------- 1806 -- Contains -- 1807 -------------- 1808 1809 function Contains 1810 (Container : Set; 1811 Key : Key_Type) return Boolean 1812 is 1813 begin 1814 return Find (Container, Key) /= No_Element; 1815 end Contains; 1816 1817 ------------ 1818 -- Delete -- 1819 ------------ 1820 1821 procedure Delete 1822 (Container : in out Set; 1823 Key : Key_Type) 1824 is 1825 X : Node_Access; 1826 1827 begin 1828 Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X); 1829 1830 if X = null then 1831 raise Constraint_Error with "attempt to delete key not in set"; 1832 end if; 1833 1834 Free (X); 1835 end Delete; 1836 1837 ------------- 1838 -- Element -- 1839 ------------- 1840 1841 function Element 1842 (Container : Set; 1843 Key : Key_Type) return Element_Type 1844 is 1845 Node : constant Node_Access := Key_Keys.Find (Container.HT, Key); 1846 1847 begin 1848 if Node = null then 1849 raise Constraint_Error with "key not in map"; -- ??? "set" 1850 end if; 1851 1852 return Node.Element; 1853 end Element; 1854 1855 ------------------------- 1856 -- Equivalent_Key_Node -- 1857 ------------------------- 1858 1859 function Equivalent_Key_Node 1860 (Key : Key_Type; 1861 Node : Node_Access) return Boolean 1862 is 1863 begin 1864 return Equivalent_Keys (Key, Generic_Keys.Key (Node.Element)); 1865 end Equivalent_Key_Node; 1866 1867 ------------- 1868 -- Exclude -- 1869 ------------- 1870 1871 procedure Exclude 1872 (Container : in out Set; 1873 Key : Key_Type) 1874 is 1875 X : Node_Access; 1876 begin 1877 Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X); 1878 Free (X); 1879 end Exclude; 1880 1881 ---------- 1882 -- Find -- 1883 ---------- 1884 1885 function Find 1886 (Container : Set; 1887 Key : Key_Type) return Cursor 1888 is 1889 Node : constant Node_Access := Key_Keys.Find (Container.HT, Key); 1890 1891 begin 1892 if Node = null then 1893 return No_Element; 1894 end if; 1895 1896 return Cursor'(Container'Unrestricted_Access, Node); 1897 end Find; 1898 1899 --------- 1900 -- Key -- 1901 --------- 1902 1903 function Key (Position : Cursor) return Key_Type is 1904 begin 1905 if Position.Node = null then 1906 raise Constraint_Error with 1907 "Position cursor equals No_Element"; 1908 end if; 1909 1910 pragma Assert (Vet (Position), "bad cursor in function Key"); 1911 1912 return Key (Position.Node.Element); 1913 end Key; 1914 1915 ---------- 1916 -- Read -- 1917 ---------- 1918 1919 procedure Read 1920 (Stream : not null access Root_Stream_Type'Class; 1921 Item : out Reference_Type) 1922 is 1923 begin 1924 raise Program_Error with "attempt to stream reference"; 1925 end Read; 1926 1927 ------------------------------ 1928 -- Reference_Preserving_Key -- 1929 ------------------------------ 1930 1931 function Reference_Preserving_Key 1932 (Container : aliased in out Set; 1933 Position : Cursor) return Reference_Type 1934 is 1935 begin 1936 if Position.Container = null then 1937 raise Constraint_Error with "Position cursor has no element"; 1938 end if; 1939 1940 if Position.Container /= Container'Unrestricted_Access then 1941 raise Program_Error with 1942 "Position cursor designates wrong container"; 1943 end if; 1944 1945 pragma Assert 1946 (Vet (Position), 1947 "bad cursor in function Reference_Preserving_Key"); 1948 1949 -- Some form of finalization will be required in order to actually 1950 -- check that the key-part of the element designated by Position has 1951 -- not changed. ??? 1952 1953 return (Element => Position.Node.Element'Access); 1954 end Reference_Preserving_Key; 1955 1956 function Reference_Preserving_Key 1957 (Container : aliased in out Set; 1958 Key : Key_Type) return Reference_Type 1959 is 1960 Node : constant Node_Access := Key_Keys.Find (Container.HT, Key); 1961 1962 begin 1963 if Node = null then 1964 raise Constraint_Error with "Key not in set"; 1965 end if; 1966 1967 -- Some form of finalization will be required in order to actually 1968 -- check that the key-part of the element designated by Key has not 1969 -- changed. ??? 1970 1971 return (Element => Node.Element'Access); 1972 end Reference_Preserving_Key; 1973 1974 ------------- 1975 -- Replace -- 1976 ------------- 1977 1978 procedure Replace 1979 (Container : in out Set; 1980 Key : Key_Type; 1981 New_Item : Element_Type) 1982 is 1983 Node : constant Node_Access := Key_Keys.Find (Container.HT, Key); 1984 1985 begin 1986 if Node = null then 1987 raise Constraint_Error with 1988 "attempt to replace key not in set"; 1989 end if; 1990 1991 Replace_Element (Container.HT, Node, New_Item); 1992 end Replace; 1993 1994 ----------------------------------- 1995 -- Update_Element_Preserving_Key -- 1996 ----------------------------------- 1997 1998 procedure Update_Element_Preserving_Key 1999 (Container : in out Set; 2000 Position : Cursor; 2001 Process : not null access 2002 procedure (Element : in out Element_Type)) 2003 is 2004 HT : Hash_Table_Type renames Container.HT; 2005 Indx : Hash_Type; 2006 2007 begin 2008 if Position.Node = null then 2009 raise Constraint_Error with 2010 "Position cursor equals No_Element"; 2011 end if; 2012 2013 if Position.Container /= Container'Unrestricted_Access then 2014 raise Program_Error with 2015 "Position cursor designates wrong set"; 2016 end if; 2017 2018 if HT.Buckets = null 2019 or else HT.Buckets'Length = 0 2020 or else HT.Length = 0 2021 or else Position.Node.Next = Position.Node 2022 then 2023 raise Program_Error with "Position cursor is bad (set is empty)"; 2024 end if; 2025 2026 pragma Assert 2027 (Vet (Position), 2028 "bad cursor in Update_Element_Preserving_Key"); 2029 2030 Indx := HT_Ops.Index (HT, Position.Node); 2031 2032 declare 2033 E : Element_Type renames Position.Node.Element; 2034 K : constant Key_Type := Key (E); 2035 2036 B : Natural renames HT.Busy; 2037 L : Natural renames HT.Lock; 2038 2039 begin 2040 B := B + 1; 2041 L := L + 1; 2042 2043 begin 2044 Process (E); 2045 exception 2046 when others => 2047 L := L - 1; 2048 B := B - 1; 2049 raise; 2050 end; 2051 2052 L := L - 1; 2053 B := B - 1; 2054 2055 if Equivalent_Keys (K, Key (E)) then 2056 pragma Assert (Hash (K) = Hash (E)); 2057 return; 2058 end if; 2059 end; 2060 2061 if HT.Buckets (Indx) = Position.Node then 2062 HT.Buckets (Indx) := Position.Node.Next; 2063 2064 else 2065 declare 2066 Prev : Node_Access := HT.Buckets (Indx); 2067 2068 begin 2069 while Prev.Next /= Position.Node loop 2070 Prev := Prev.Next; 2071 2072 if Prev = null then 2073 raise Program_Error with 2074 "Position cursor is bad (node not found)"; 2075 end if; 2076 end loop; 2077 2078 Prev.Next := Position.Node.Next; 2079 end; 2080 end if; 2081 2082 HT.Length := HT.Length - 1; 2083 2084 declare 2085 X : Node_Access := Position.Node; 2086 2087 begin 2088 Free (X); 2089 end; 2090 2091 raise Program_Error with "key was modified"; 2092 end Update_Element_Preserving_Key; 2093 2094 ----------- 2095 -- Write -- 2096 ----------- 2097 2098 procedure Write 2099 (Stream : not null access Root_Stream_Type'Class; 2100 Item : Reference_Type) 2101 is 2102 begin 2103 raise Program_Error with "attempt to stream reference"; 2104 end Write; 2105 2106 end Generic_Keys; 2107 2108end Ada.Containers.Hashed_Sets; 2109