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