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