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