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