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-2019, 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 Busy (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 < Source.Length then 252 if Checks and then Capacity /= 0 then 253 raise Capacity_Error 254 with "Requested capacity is less than Source length"; 255 end if; 256 257 C := Source.Length; 258 else 259 C := Capacity; 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, Hash_Type'Last); 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 Pos : Hash_Type; 661 Node : constant Node_Access := HT_Ops.First (Container.HT, Pos); 662 begin 663 if Node = null then 664 return No_Element; 665 end if; 666 667 return Cursor'(Container'Unrestricted_Access, Node, Pos); 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; Position : Hash_Type); 981 pragma Inline (Process_Node); 982 983 procedure Iterate is 984 new HT_Ops.Generic_Iteration_With_Position (Process_Node); 985 986 ------------------ 987 -- Process_Node -- 988 ------------------ 989 990 procedure Process_Node (Node : Node_Access; Position : Hash_Type) is 991 begin 992 Process (Cursor'(Container'Unrestricted_Access, Node, Position)); 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 Node : Node_Access; 1042 Pos : Hash_Type; 1043 begin 1044 if Position.Node = null then 1045 return No_Element; 1046 end if; 1047 1048 pragma Assert (Vet (Position), "bad cursor in Next"); 1049 1050 Pos := Position.Position; 1051 Node := HT_Ops.Next (Position.Container.HT, Position.Node, Pos); 1052 1053 if Node = null then 1054 return No_Element; 1055 end if; 1056 1057 return Cursor'(Position.Container, Node, Pos); 1058 end Next; 1059 1060 procedure Next (Position : in out Cursor) is 1061 begin 1062 Position := Next (Position); 1063 end Next; 1064 1065 function Next 1066 (Object : Iterator; 1067 Position : Cursor) return Cursor 1068 is 1069 begin 1070 if Position.Container = null then 1071 return No_Element; 1072 end if; 1073 1074 if Checks and then Position.Container /= Object.Container then 1075 raise Program_Error with 1076 "Position cursor of Next designates wrong set"; 1077 end if; 1078 1079 return Next (Position); 1080 end Next; 1081 1082 ------------- 1083 -- Overlap -- 1084 ------------- 1085 1086 function Overlap (Left, Right : Set) return Boolean is 1087 Left_HT : Hash_Table_Type renames Left'Unrestricted_Access.HT; 1088 Right_HT : Hash_Table_Type renames Right'Unrestricted_Access.HT; 1089 Left_Node : Node_Access; 1090 1091 begin 1092 if Right.Length = 0 then 1093 return False; 1094 end if; 1095 1096 if Left'Address = Right'Address then 1097 return True; 1098 end if; 1099 1100 Left_Node := HT_Ops.First (Left_HT); 1101 while Left_Node /= null loop 1102 if Is_In (Right_HT, Left_Node) then 1103 return True; 1104 end if; 1105 Left_Node := HT_Ops.Next (Left_HT, Left_Node); 1106 end loop; 1107 1108 return False; 1109 end Overlap; 1110 1111 ---------------------- 1112 -- Pseudo_Reference -- 1113 ---------------------- 1114 1115 function Pseudo_Reference 1116 (Container : aliased Set'Class) return Reference_Control_Type 1117 is 1118 TC : constant Tamper_Counts_Access := 1119 Container.HT.TC'Unrestricted_Access; 1120 begin 1121 return R : constant Reference_Control_Type := (Controlled with TC) do 1122 Busy (TC.all); 1123 end return; 1124 end Pseudo_Reference; 1125 1126 ------------------- 1127 -- Query_Element -- 1128 ------------------- 1129 1130 procedure Query_Element 1131 (Position : Cursor; 1132 Process : not null access procedure (Element : Element_Type)) 1133 is 1134 begin 1135 if Checks and then Position.Node = null then 1136 raise Constraint_Error with 1137 "Position cursor of Query_Element equals No_Element"; 1138 end if; 1139 1140 pragma Assert (Vet (Position), "bad cursor in Query_Element"); 1141 1142 declare 1143 HT : Hash_Table_Type renames Position.Container.HT; 1144 Lock : With_Lock (HT.TC'Unrestricted_Access); 1145 begin 1146 Process (Position.Node.Element); 1147 end; 1148 end Query_Element; 1149 1150 ---------- 1151 -- Read -- 1152 ---------- 1153 1154 procedure Read 1155 (Stream : not null access Root_Stream_Type'Class; 1156 Container : out Set) 1157 is 1158 begin 1159 Read_Nodes (Stream, Container.HT); 1160 end Read; 1161 1162 procedure Read 1163 (Stream : not null access Root_Stream_Type'Class; 1164 Item : out Cursor) 1165 is 1166 begin 1167 raise Program_Error with "attempt to stream set cursor"; 1168 end Read; 1169 1170 procedure Read 1171 (Stream : not null access Root_Stream_Type'Class; 1172 Item : out Constant_Reference_Type) 1173 is 1174 begin 1175 raise Program_Error with "attempt to stream reference"; 1176 end Read; 1177 1178 --------------- 1179 -- Read_Node -- 1180 --------------- 1181 1182 function Read_Node (Stream : not null access Root_Stream_Type'Class) 1183 return Node_Access 1184 is 1185 Node : Node_Access := new Node_Type; 1186 begin 1187 Element_Type'Read (Stream, Node.Element); 1188 return Node; 1189 exception 1190 when others => 1191 Free (Node); 1192 raise; 1193 end Read_Node; 1194 1195 ------------- 1196 -- Replace -- 1197 ------------- 1198 1199 procedure Replace 1200 (Container : in out Set; 1201 New_Item : Element_Type) 1202 is 1203 Node : constant Node_Access := 1204 Element_Keys.Find (Container.HT, New_Item); 1205 1206 begin 1207 if Checks and then Node = null then 1208 raise Constraint_Error with 1209 "attempt to replace element not in set"; 1210 end if; 1211 1212 TE_Check (Container.HT.TC); 1213 1214 Node.Element := New_Item; 1215 end Replace; 1216 1217 procedure Replace_Element 1218 (Container : in out Set; 1219 Position : Cursor; 1220 New_Item : Element_Type) 1221 is 1222 begin 1223 if Checks and then Position.Node = null then 1224 raise Constraint_Error with 1225 "Position cursor equals No_Element"; 1226 end if; 1227 1228 if Checks and then Position.Container /= Container'Unrestricted_Access 1229 then 1230 raise Program_Error with 1231 "Position cursor designates wrong set"; 1232 end if; 1233 1234 pragma Assert (Vet (Position), "bad cursor in Replace_Element"); 1235 1236 Replace_Element (Container.HT, Position.Node, New_Item); 1237 end Replace_Element; 1238 1239 ---------------------- 1240 -- Reserve_Capacity -- 1241 ---------------------- 1242 1243 procedure Reserve_Capacity 1244 (Container : in out Set; 1245 Capacity : Count_Type) 1246 is 1247 begin 1248 HT_Ops.Reserve_Capacity (Container.HT, Capacity); 1249 end Reserve_Capacity; 1250 1251 -------------- 1252 -- Set_Next -- 1253 -------------- 1254 1255 procedure Set_Next (Node : Node_Access; Next : Node_Access) is 1256 begin 1257 Node.Next := Next; 1258 end Set_Next; 1259 1260 -------------------------- 1261 -- Symmetric_Difference -- 1262 -------------------------- 1263 1264 procedure Symmetric_Difference 1265 (Target : in out Set; 1266 Source : Set) 1267 is 1268 Tgt_HT : Hash_Table_Type renames Target.HT; 1269 Src_HT : Hash_Table_Type renames Source.HT'Unrestricted_Access.all; 1270 begin 1271 if Target'Address = Source'Address then 1272 Clear (Target); 1273 return; 1274 end if; 1275 1276 TC_Check (Tgt_HT.TC); 1277 1278 declare 1279 N : constant Count_Type := Target.Length + Source.Length; 1280 begin 1281 if N > HT_Ops.Capacity (Tgt_HT) then 1282 HT_Ops.Reserve_Capacity (Tgt_HT, N); 1283 end if; 1284 end; 1285 1286 if Target.Length = 0 then 1287 Iterate_Source_When_Empty_Target : declare 1288 procedure Process (Src_Node : Node_Access); 1289 1290 procedure Iterate is new HT_Ops.Generic_Iteration (Process); 1291 1292 ------------- 1293 -- Process -- 1294 ------------- 1295 1296 procedure Process (Src_Node : Node_Access) is 1297 E : Element_Type renames Src_Node.Element; 1298 B : Buckets_Type renames Tgt_HT.Buckets.all; 1299 J : constant Hash_Type := Hash (E) mod B'Length; 1300 N : Count_Type renames Tgt_HT.Length; 1301 1302 begin 1303 B (J) := new Node_Type'(E, B (J)); 1304 N := N + 1; 1305 end Process; 1306 1307 -- Per AI05-0022, the container implementation is required to 1308 -- detect element tampering by a generic actual subprogram. 1309 1310 Lock_Tgt : With_Lock (Tgt_HT.TC'Unrestricted_Access); 1311 Lock_Src : With_Lock (Src_HT.TC'Unrestricted_Access); 1312 1313 -- Start of processing for Iterate_Source_When_Empty_Target 1314 1315 begin 1316 Iterate (Src_HT); 1317 end Iterate_Source_When_Empty_Target; 1318 1319 else 1320 Iterate_Source : declare 1321 procedure Process (Src_Node : Node_Access); 1322 1323 procedure Iterate is 1324 new HT_Ops.Generic_Iteration (Process); 1325 1326 ------------- 1327 -- Process -- 1328 ------------- 1329 1330 procedure Process (Src_Node : Node_Access) is 1331 E : Element_Type renames Src_Node.Element; 1332 B : Buckets_Type renames Tgt_HT.Buckets.all; 1333 J : constant Hash_Type := Hash (E) mod B'Length; 1334 N : Count_Type renames Tgt_HT.Length; 1335 1336 begin 1337 if B (J) = null then 1338 B (J) := new Node_Type'(E, null); 1339 N := N + 1; 1340 1341 elsif Equivalent_Elements (E, B (J).Element) then 1342 declare 1343 X : Node_Access := B (J); 1344 begin 1345 B (J) := B (J).Next; 1346 N := N - 1; 1347 Free (X); 1348 end; 1349 1350 else 1351 declare 1352 Prev : Node_Access := B (J); 1353 Curr : Node_Access := Prev.Next; 1354 1355 begin 1356 while Curr /= null loop 1357 if Equivalent_Elements (E, Curr.Element) then 1358 Prev.Next := Curr.Next; 1359 N := N - 1; 1360 Free (Curr); 1361 return; 1362 end if; 1363 1364 Prev := Curr; 1365 Curr := Prev.Next; 1366 end loop; 1367 1368 B (J) := new Node_Type'(E, B (J)); 1369 N := N + 1; 1370 end; 1371 end if; 1372 end Process; 1373 1374 -- Per AI05-0022, the container implementation is required to 1375 -- detect element tampering by a generic actual subprogram. 1376 1377 Lock_Tgt : With_Lock (Tgt_HT.TC'Unrestricted_Access); 1378 Lock_Src : With_Lock (Src_HT.TC'Unrestricted_Access); 1379 1380 -- Start of processing for Iterate_Source 1381 1382 begin 1383 Iterate (Src_HT); 1384 end Iterate_Source; 1385 end if; 1386 end Symmetric_Difference; 1387 1388 function Symmetric_Difference (Left, Right : Set) return Set is 1389 Left_HT : Hash_Table_Type renames Left'Unrestricted_Access.HT; 1390 Right_HT : Hash_Table_Type renames Right'Unrestricted_Access.HT; 1391 Buckets : HT_Types.Buckets_Access; 1392 Length : Count_Type; 1393 1394 begin 1395 if Left'Address = Right'Address then 1396 return Empty_Set; 1397 end if; 1398 1399 if Right.Length = 0 then 1400 return Left; 1401 end if; 1402 1403 if Left.Length = 0 then 1404 return Right; 1405 end if; 1406 1407 declare 1408 Size : constant Hash_Type := 1409 Prime_Numbers.To_Prime (Left.Length + Right.Length); 1410 begin 1411 Buckets := HT_Ops.New_Buckets (Length => Size); 1412 end; 1413 1414 Length := 0; 1415 1416 Iterate_Left : declare 1417 procedure Process (L_Node : Node_Access); 1418 1419 procedure Iterate is 1420 new HT_Ops.Generic_Iteration (Process); 1421 1422 ------------- 1423 -- Process -- 1424 ------------- 1425 1426 procedure Process (L_Node : Node_Access) is 1427 begin 1428 if not Is_In (Right_HT, L_Node) then 1429 declare 1430 E : Element_Type renames L_Node.Element; 1431 1432 -- Per AI05-0022, the container implementation is required 1433 -- to detect element tampering by a generic actual 1434 -- subprogram, hence the use of Checked_Index instead of a 1435 -- simple invocation of generic formal Hash. 1436 1437 J : constant Hash_Type := 1438 HT_Ops.Checked_Index (Left_HT, Buckets.all, L_Node); 1439 1440 begin 1441 Buckets (J) := new Node_Type'(E, Buckets (J)); 1442 Length := Length + 1; 1443 end; 1444 end if; 1445 end Process; 1446 1447 -- Start of processing for Iterate_Left 1448 1449 begin 1450 Iterate (Left_HT); 1451 1452 exception 1453 when others => 1454 HT_Ops.Free_Hash_Table (Buckets); 1455 raise; 1456 end Iterate_Left; 1457 1458 Iterate_Right : declare 1459 procedure Process (R_Node : Node_Access); 1460 1461 procedure Iterate is 1462 new HT_Ops.Generic_Iteration (Process); 1463 1464 ------------- 1465 -- Process -- 1466 ------------- 1467 1468 procedure Process (R_Node : Node_Access) is 1469 begin 1470 if not Is_In (Left_HT, R_Node) then 1471 declare 1472 E : Element_Type renames R_Node.Element; 1473 1474 -- Per AI05-0022, the container implementation is required 1475 -- to detect element tampering by a generic actual 1476 -- subprogram, hence the use of Checked_Index instead of a 1477 -- simple invocation of generic formal Hash. 1478 1479 J : constant Hash_Type := 1480 HT_Ops.Checked_Index (Right_HT, Buckets.all, R_Node); 1481 1482 begin 1483 Buckets (J) := new Node_Type'(E, Buckets (J)); 1484 Length := Length + 1; 1485 end; 1486 end if; 1487 end Process; 1488 1489 -- Start of processing for Iterate_Right 1490 1491 begin 1492 Iterate (Right_HT); 1493 1494 exception 1495 when others => 1496 HT_Ops.Free_Hash_Table (Buckets); 1497 raise; 1498 end Iterate_Right; 1499 1500 return (Controlled with HT => (Buckets, Length, (Busy => 0, Lock => 0))); 1501 end Symmetric_Difference; 1502 1503 ------------ 1504 -- To_Set -- 1505 ------------ 1506 1507 function To_Set (New_Item : Element_Type) return Set is 1508 HT : Hash_Table_Type; 1509 1510 Node : Node_Access; 1511 Inserted : Boolean; 1512 pragma Unreferenced (Node, Inserted); 1513 1514 begin 1515 Insert (HT, New_Item, Node, Inserted); 1516 return Set'(Controlled with HT); 1517 end To_Set; 1518 1519 ----------- 1520 -- Union -- 1521 ----------- 1522 1523 procedure Union 1524 (Target : in out Set; 1525 Source : Set) 1526 is 1527 procedure Process (Src_Node : Node_Access); 1528 1529 procedure Iterate is 1530 new HT_Ops.Generic_Iteration (Process); 1531 1532 ------------- 1533 -- Process -- 1534 ------------- 1535 1536 procedure Process (Src_Node : Node_Access) is 1537 function New_Node (Next : Node_Access) return Node_Access; 1538 pragma Inline (New_Node); 1539 1540 procedure Insert is 1541 new Element_Keys.Generic_Conditional_Insert (New_Node); 1542 1543 -------------- 1544 -- New_Node -- 1545 -------------- 1546 1547 function New_Node (Next : Node_Access) return Node_Access is 1548 Node : constant Node_Access := 1549 new Node_Type'(Src_Node.Element, Next); 1550 begin 1551 return Node; 1552 end New_Node; 1553 1554 Tgt_Node : Node_Access; 1555 Success : Boolean; 1556 pragma Unreferenced (Tgt_Node, Success); 1557 1558 -- Start of processing for Process 1559 1560 begin 1561 Insert (Target.HT, Src_Node.Element, Tgt_Node, Success); 1562 end Process; 1563 1564 -- Start of processing for Union 1565 1566 begin 1567 if Target'Address = Source'Address then 1568 return; 1569 end if; 1570 1571 TC_Check (Target.HT.TC); 1572 1573 declare 1574 N : constant Count_Type := Target.Length + Source.Length; 1575 begin 1576 if N > HT_Ops.Capacity (Target.HT) then 1577 HT_Ops.Reserve_Capacity (Target.HT, N); 1578 end if; 1579 end; 1580 1581 Iterate (Source.HT); 1582 end Union; 1583 1584 function Union (Left, Right : Set) return Set is 1585 Left_HT : Hash_Table_Type renames Left.HT'Unrestricted_Access.all; 1586 Right_HT : Hash_Table_Type renames Right.HT'Unrestricted_Access.all; 1587 Buckets : HT_Types.Buckets_Access; 1588 Length : Count_Type; 1589 1590 begin 1591 if Left'Address = Right'Address then 1592 return Left; 1593 end if; 1594 1595 if Right.Length = 0 then 1596 return Left; 1597 end if; 1598 1599 if Left.Length = 0 then 1600 return Right; 1601 end if; 1602 1603 declare 1604 Size : constant Hash_Type := 1605 Prime_Numbers.To_Prime (Left.Length + Right.Length); 1606 begin 1607 Buckets := HT_Ops.New_Buckets (Length => Size); 1608 end; 1609 1610 Iterate_Left : declare 1611 procedure Process (L_Node : Node_Access); 1612 1613 procedure Iterate is 1614 new HT_Ops.Generic_Iteration (Process); 1615 1616 ------------- 1617 -- Process -- 1618 ------------- 1619 1620 procedure Process (L_Node : Node_Access) is 1621 J : constant Hash_Type := 1622 Hash (L_Node.Element) mod Buckets'Length; 1623 1624 begin 1625 Buckets (J) := new Node_Type'(L_Node.Element, Buckets (J)); 1626 end Process; 1627 1628 -- Per AI05-0022, the container implementation is required to detect 1629 -- element tampering by a generic actual subprogram, hence the use of 1630 -- Checked_Index instead of a simple invocation of generic formal 1631 -- Hash. 1632 1633 Lock_Left : With_Lock (Left_HT.TC'Unrestricted_Access); 1634 1635 -- Start of processing for Iterate_Left 1636 1637 begin 1638 Iterate (Left_HT); 1639 exception 1640 when others => 1641 HT_Ops.Free_Hash_Table (Buckets); 1642 raise; 1643 end Iterate_Left; 1644 1645 Length := Left.Length; 1646 1647 Iterate_Right : declare 1648 procedure Process (Src_Node : Node_Access); 1649 1650 procedure Iterate is 1651 new HT_Ops.Generic_Iteration (Process); 1652 1653 ------------- 1654 -- Process -- 1655 ------------- 1656 1657 procedure Process (Src_Node : Node_Access) is 1658 J : constant Hash_Type := 1659 Hash (Src_Node.Element) mod Buckets'Length; 1660 1661 Tgt_Node : Node_Access := Buckets (J); 1662 1663 begin 1664 while Tgt_Node /= null loop 1665 if Equivalent_Elements (Src_Node.Element, Tgt_Node.Element) then 1666 return; 1667 end if; 1668 1669 Tgt_Node := Next (Tgt_Node); 1670 end loop; 1671 1672 Buckets (J) := new Node_Type'(Src_Node.Element, Buckets (J)); 1673 Length := Length + 1; 1674 end Process; 1675 1676 -- Per AI05-0022, the container implementation is required to detect 1677 -- element tampering by a generic actual subprogram, hence the use of 1678 -- Checked_Index instead of a simple invocation of generic formal 1679 -- Hash. 1680 1681 Lock_Left : With_Lock (Left_HT.TC'Unrestricted_Access); 1682 Lock_Right : With_Lock (Right_HT.TC'Unrestricted_Access); 1683 1684 -- Start of processing for Iterate_Right 1685 1686 begin 1687 Iterate (Right_HT); 1688 exception 1689 when others => 1690 HT_Ops.Free_Hash_Table (Buckets); 1691 raise; 1692 end Iterate_Right; 1693 1694 return (Controlled with HT => (Buckets, Length, (Busy => 0, Lock => 0))); 1695 end Union; 1696 1697 --------- 1698 -- Vet -- 1699 --------- 1700 1701 function Vet (Position : Cursor) return Boolean is 1702 begin 1703 if Position.Node = null then 1704 return Position.Container = null; 1705 end if; 1706 1707 if Position.Container = null then 1708 return False; 1709 end if; 1710 1711 if Position.Node.Next = Position.Node then 1712 return False; 1713 end if; 1714 1715 declare 1716 HT : Hash_Table_Type renames Position.Container.HT; 1717 X : Node_Access; 1718 1719 begin 1720 if HT.Length = 0 then 1721 return False; 1722 end if; 1723 1724 if HT.Buckets = null 1725 or else HT.Buckets'Length = 0 1726 then 1727 return False; 1728 end if; 1729 1730 X := HT.Buckets (Element_Keys.Checked_Index 1731 (HT, 1732 Position.Node.Element)); 1733 1734 for J in 1 .. HT.Length loop 1735 if X = Position.Node then 1736 return True; 1737 end if; 1738 1739 if X = null then 1740 return False; 1741 end if; 1742 1743 if X = X.Next then -- to prevent unnecessary looping 1744 return False; 1745 end if; 1746 1747 X := X.Next; 1748 end loop; 1749 1750 return False; 1751 end; 1752 end Vet; 1753 1754 ----------- 1755 -- Write -- 1756 ----------- 1757 1758 procedure Write 1759 (Stream : not null access Root_Stream_Type'Class; 1760 Container : Set) 1761 is 1762 begin 1763 Write_Nodes (Stream, Container.HT); 1764 end Write; 1765 1766 procedure Write 1767 (Stream : not null access Root_Stream_Type'Class; 1768 Item : Cursor) 1769 is 1770 begin 1771 raise Program_Error with "attempt to stream set cursor"; 1772 end Write; 1773 1774 procedure Write 1775 (Stream : not null access Root_Stream_Type'Class; 1776 Item : Constant_Reference_Type) 1777 is 1778 begin 1779 raise Program_Error with "attempt to stream reference"; 1780 end Write; 1781 1782 ---------------- 1783 -- Write_Node -- 1784 ---------------- 1785 1786 procedure Write_Node 1787 (Stream : not null access Root_Stream_Type'Class; 1788 Node : Node_Access) 1789 is 1790 begin 1791 Element_Type'Write (Stream, Node.Element); 1792 end Write_Node; 1793 1794 package body Generic_Keys is 1795 1796 ----------------------- 1797 -- Local Subprograms -- 1798 ----------------------- 1799 1800 function Equivalent_Key_Node 1801 (Key : Key_Type; 1802 Node : Node_Access) return Boolean; 1803 pragma Inline (Equivalent_Key_Node); 1804 1805 -------------------------- 1806 -- Local Instantiations -- 1807 -------------------------- 1808 1809 package Key_Keys is 1810 new Hash_Tables.Generic_Keys 1811 (HT_Types => HT_Types, 1812 Next => Next, 1813 Set_Next => Set_Next, 1814 Key_Type => Key_Type, 1815 Hash => Hash, 1816 Equivalent_Keys => Equivalent_Key_Node); 1817 1818 ------------------------ 1819 -- Constant_Reference -- 1820 ------------------------ 1821 1822 function Constant_Reference 1823 (Container : aliased Set; 1824 Key : Key_Type) return Constant_Reference_Type 1825 is 1826 HT : Hash_Table_Type renames Container'Unrestricted_Access.HT; 1827 Node : constant Node_Access := Key_Keys.Find (HT, Key); 1828 1829 begin 1830 if Checks and then Node = null then 1831 raise Constraint_Error with "Key not in set"; 1832 end if; 1833 1834 declare 1835 TC : constant Tamper_Counts_Access := 1836 HT.TC'Unrestricted_Access; 1837 begin 1838 return R : constant Constant_Reference_Type := 1839 (Element => Node.Element'Access, 1840 Control => (Controlled with TC)) 1841 do 1842 Busy (TC.all); 1843 end return; 1844 end; 1845 end Constant_Reference; 1846 1847 -------------- 1848 -- Contains -- 1849 -------------- 1850 1851 function Contains 1852 (Container : Set; 1853 Key : Key_Type) return Boolean 1854 is 1855 begin 1856 return Find (Container, Key) /= No_Element; 1857 end Contains; 1858 1859 ------------ 1860 -- Delete -- 1861 ------------ 1862 1863 procedure Delete 1864 (Container : in out Set; 1865 Key : Key_Type) 1866 is 1867 X : Node_Access; 1868 1869 begin 1870 Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X); 1871 1872 if Checks and then X = null then 1873 raise Constraint_Error with "attempt to delete key not in set"; 1874 end if; 1875 1876 Free (X); 1877 end Delete; 1878 1879 ------------- 1880 -- Element -- 1881 ------------- 1882 1883 function Element 1884 (Container : Set; 1885 Key : Key_Type) return Element_Type 1886 is 1887 HT : Hash_Table_Type renames Container'Unrestricted_Access.HT; 1888 Node : constant Node_Access := Key_Keys.Find (HT, Key); 1889 1890 begin 1891 if Checks and then Node = null then 1892 raise Constraint_Error with "key not in set"; 1893 end if; 1894 1895 return Node.Element; 1896 end Element; 1897 1898 ------------------------- 1899 -- Equivalent_Key_Node -- 1900 ------------------------- 1901 1902 function Equivalent_Key_Node 1903 (Key : Key_Type; 1904 Node : Node_Access) return Boolean 1905 is 1906 begin 1907 return Equivalent_Keys (Key, Generic_Keys.Key (Node.Element)); 1908 end Equivalent_Key_Node; 1909 1910 ------------- 1911 -- Exclude -- 1912 ------------- 1913 1914 procedure Exclude 1915 (Container : in out Set; 1916 Key : Key_Type) 1917 is 1918 X : Node_Access; 1919 begin 1920 Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X); 1921 Free (X); 1922 end Exclude; 1923 1924 -------------- 1925 -- Finalize -- 1926 -------------- 1927 1928 procedure Finalize (Control : in out Reference_Control_Type) is 1929 begin 1930 if Control.Container /= null then 1931 Impl.Reference_Control_Type (Control).Finalize; 1932 1933 if Checks and then 1934 Hash (Key (Element (Control.Old_Pos))) /= Control.Old_Hash 1935 then 1936 HT_Ops.Delete_Node_At_Index 1937 (Control.Container.HT, Control.Index, Control.Old_Pos.Node); 1938 raise Program_Error with "key not preserved in reference"; 1939 end if; 1940 1941 Control.Container := null; 1942 end if; 1943 end Finalize; 1944 1945 ---------- 1946 -- Find -- 1947 ---------- 1948 1949 function Find 1950 (Container : Set; 1951 Key : Key_Type) return Cursor 1952 is 1953 HT : Hash_Table_Type renames Container'Unrestricted_Access.HT; 1954 Node : constant Node_Access := Key_Keys.Find (HT, Key); 1955 begin 1956 if Node = null then 1957 return No_Element; 1958 else 1959 return Cursor' 1960 (Container'Unrestricted_Access, Node, Hash_Type'Last); 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 Busy (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 Busy (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