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