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