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