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