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