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