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