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