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