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