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