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