1------------------------------------------------------------------------------ 2-- -- 3-- GNAT LIBRARY COMPONENTS -- 4-- -- 5-- ADA.CONTAINERS.INDEFINITE_ORDERED_MULTISETS -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. -- 17-- -- 18-- As a special exception under Section 7 of GPL version 3, you are granted -- 19-- additional permissions described in the GCC Runtime Library Exception, -- 20-- version 3.1, as published by the Free Software Foundation. -- 21-- -- 22-- You should have received a copy of the GNU General Public License and -- 23-- a copy of the GCC Runtime Library Exception along with this program; -- 24-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 25-- <http://www.gnu.org/licenses/>. -- 26-- -- 27-- This unit was originally developed by Matthew J Heaney. -- 28------------------------------------------------------------------------------ 29 30with Ada.Unchecked_Deallocation; 31 32with Ada.Containers.Red_Black_Trees.Generic_Operations; 33pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations); 34 35with Ada.Containers.Red_Black_Trees.Generic_Keys; 36pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys); 37 38with Ada.Containers.Red_Black_Trees.Generic_Set_Operations; 39pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Set_Operations); 40 41with System; use type System.Address; 42 43package body Ada.Containers.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 pragma Assert (Vet (Position.Container.Tree, Position.Node), 549 "bad cursor in Element"); 550 551 return Position.Node.Element.all; 552 end Element; 553 554 ------------------------- 555 -- Equivalent_Elements -- 556 ------------------------- 557 558 function Equivalent_Elements (Left, Right : Element_Type) return Boolean is 559 begin 560 if Left < Right 561 or else Right < Left 562 then 563 return False; 564 else 565 return True; 566 end if; 567 end Equivalent_Elements; 568 569 --------------------- 570 -- Equivalent_Sets -- 571 --------------------- 572 573 function Equivalent_Sets (Left, Right : Set) return Boolean is 574 575 function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean; 576 pragma Inline (Is_Equivalent_Node_Node); 577 578 function Is_Equivalent is 579 new Tree_Operations.Generic_Equal (Is_Equivalent_Node_Node); 580 581 ----------------------------- 582 -- Is_Equivalent_Node_Node -- 583 ----------------------------- 584 585 function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean is 586 begin 587 if L.Element.all < R.Element.all then 588 return False; 589 elsif R.Element.all < L.Element.all then 590 return False; 591 else 592 return True; 593 end if; 594 end Is_Equivalent_Node_Node; 595 596 -- Start of processing for Equivalent_Sets 597 598 begin 599 return Is_Equivalent (Left.Tree, Right.Tree); 600 end Equivalent_Sets; 601 602 ------------- 603 -- Exclude -- 604 ------------- 605 606 procedure Exclude (Container : in out Set; Item : Element_Type) is 607 Tree : Tree_Type renames Container.Tree; 608 Node : Node_Access := Element_Keys.Ceiling (Tree, Item); 609 Done : constant Node_Access := Element_Keys.Upper_Bound (Tree, Item); 610 X : Node_Access; 611 612 begin 613 while Node /= Done loop 614 X := Node; 615 Node := Tree_Operations.Next (Node); 616 Tree_Operations.Delete_Node_Sans_Free (Tree, X); 617 Free (X); 618 end loop; 619 end Exclude; 620 621 ---------- 622 -- Find -- 623 ---------- 624 625 function Find (Container : Set; Item : Element_Type) return Cursor is 626 Node : constant Node_Access := Element_Keys.Find (Container.Tree, Item); 627 628 begin 629 if Node = null then 630 return No_Element; 631 end if; 632 633 return Cursor'(Container'Unrestricted_Access, Node); 634 end Find; 635 636 -------------- 637 -- Finalize -- 638 -------------- 639 640 procedure Finalize (Object : in out Iterator) is 641 begin 642 Unbusy (Object.Container.Tree.TC); 643 end Finalize; 644 645 ----------- 646 -- First -- 647 ----------- 648 649 function First (Container : Set) return Cursor is 650 begin 651 if Container.Tree.First = null then 652 return No_Element; 653 end if; 654 655 return Cursor'(Container'Unrestricted_Access, Container.Tree.First); 656 end First; 657 658 function First (Object : Iterator) return Cursor is 659 begin 660 -- The value of the iterator object's Node component influences the 661 -- behavior of the First (and Last) selector function. 662 663 -- When the Node component is null, this means the iterator object was 664 -- constructed without a start expression, in which case the (forward) 665 -- iteration starts from the (logical) beginning of the entire sequence 666 -- of items (corresponding to Container.First, for a forward iterator). 667 668 -- Otherwise, this is iteration over a partial sequence of items. When 669 -- the Node component is non-null, the iterator object was constructed 670 -- with a start expression, that specifies the position from which the 671 -- (forward) partial iteration begins. 672 673 if Object.Node = null then 674 return Object.Container.First; 675 else 676 return Cursor'(Object.Container, Object.Node); 677 end if; 678 end First; 679 680 ------------------- 681 -- First_Element -- 682 ------------------- 683 684 function First_Element (Container : Set) return Element_Type is 685 begin 686 if Container.Tree.First = null then 687 raise Constraint_Error with "set is empty"; 688 end if; 689 690 pragma Assert (Container.Tree.First.Element /= null); 691 return Container.Tree.First.Element.all; 692 end First_Element; 693 694 ----------- 695 -- Floor -- 696 ----------- 697 698 function Floor (Container : Set; Item : Element_Type) return Cursor is 699 Node : constant Node_Access := Element_Keys.Floor (Container.Tree, Item); 700 701 begin 702 if Node = null then 703 return No_Element; 704 end if; 705 706 return Cursor'(Container'Unrestricted_Access, Node); 707 end Floor; 708 709 ---------- 710 -- Free -- 711 ---------- 712 713 procedure Free (X : in out Node_Access) is 714 procedure Deallocate is 715 new Ada.Unchecked_Deallocation (Node_Type, Node_Access); 716 717 begin 718 if X = null then 719 return; 720 end if; 721 722 X.Parent := X; 723 X.Left := X; 724 X.Right := X; 725 726 begin 727 Free_Element (X.Element); 728 exception 729 when others => 730 X.Element := null; 731 Deallocate (X); 732 raise; 733 end; 734 735 Deallocate (X); 736 end Free; 737 738 ------------------ 739 -- Generic_Keys -- 740 ------------------ 741 742 package body Generic_Keys is 743 744 ----------------------- 745 -- Local Subprograms -- 746 ----------------------- 747 748 function Is_Less_Key_Node 749 (Left : Key_Type; 750 Right : Node_Access) return Boolean; 751 pragma Inline (Is_Less_Key_Node); 752 753 function Is_Greater_Key_Node 754 (Left : Key_Type; 755 Right : Node_Access) return Boolean; 756 pragma Inline (Is_Greater_Key_Node); 757 758 -------------------------- 759 -- Local Instantiations -- 760 -------------------------- 761 762 package Key_Keys is 763 new Red_Black_Trees.Generic_Keys 764 (Tree_Operations => Tree_Operations, 765 Key_Type => Key_Type, 766 Is_Less_Key_Node => Is_Less_Key_Node, 767 Is_Greater_Key_Node => Is_Greater_Key_Node); 768 769 ------------- 770 -- Ceiling -- 771 ------------- 772 773 function Ceiling (Container : Set; Key : Key_Type) return Cursor is 774 Node : constant Node_Access := Key_Keys.Ceiling (Container.Tree, Key); 775 776 begin 777 if Node = null then 778 return No_Element; 779 end if; 780 781 return Cursor'(Container'Unrestricted_Access, Node); 782 end Ceiling; 783 784 -------------- 785 -- Contains -- 786 -------------- 787 788 function Contains (Container : Set; Key : Key_Type) return Boolean is 789 begin 790 return Find (Container, Key) /= No_Element; 791 end Contains; 792 793 ------------ 794 -- Delete -- 795 ------------ 796 797 procedure Delete (Container : in out Set; Key : Key_Type) is 798 Tree : Tree_Type renames Container.Tree; 799 Node : Node_Access := Key_Keys.Ceiling (Tree, Key); 800 Done : constant Node_Access := Key_Keys.Upper_Bound (Tree, Key); 801 X : Node_Access; 802 803 begin 804 if Node = Done then 805 raise Constraint_Error with "attempt to delete key not in set"; 806 end if; 807 808 loop 809 X := Node; 810 Node := Tree_Operations.Next (Node); 811 Tree_Operations.Delete_Node_Sans_Free (Tree, X); 812 Free (X); 813 814 exit when Node = Done; 815 end loop; 816 end Delete; 817 818 ------------- 819 -- Element -- 820 ------------- 821 822 function Element (Container : Set; Key : Key_Type) return Element_Type is 823 Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); 824 825 begin 826 if Node = null then 827 raise Constraint_Error with "key not in set"; 828 end if; 829 830 return Node.Element.all; 831 end Element; 832 833 --------------------- 834 -- Equivalent_Keys -- 835 --------------------- 836 837 function Equivalent_Keys (Left, Right : Key_Type) return Boolean is 838 begin 839 if Left < Right 840 or else Right < Left 841 then 842 return False; 843 else 844 return True; 845 end if; 846 end Equivalent_Keys; 847 848 ------------- 849 -- Exclude -- 850 ------------- 851 852 procedure Exclude (Container : in out Set; Key : Key_Type) is 853 Tree : Tree_Type renames Container.Tree; 854 Node : Node_Access := Key_Keys.Ceiling (Tree, Key); 855 Done : constant Node_Access := Key_Keys.Upper_Bound (Tree, Key); 856 X : Node_Access; 857 858 begin 859 while Node /= Done loop 860 X := Node; 861 Node := Tree_Operations.Next (Node); 862 Tree_Operations.Delete_Node_Sans_Free (Tree, X); 863 Free (X); 864 end loop; 865 end Exclude; 866 867 ---------- 868 -- Find -- 869 ---------- 870 871 function Find (Container : Set; Key : Key_Type) return Cursor is 872 Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); 873 874 begin 875 if Node = null then 876 return No_Element; 877 end if; 878 879 return Cursor'(Container'Unrestricted_Access, Node); 880 end Find; 881 882 ----------- 883 -- Floor -- 884 ----------- 885 886 function Floor (Container : Set; Key : Key_Type) return Cursor is 887 Node : constant Node_Access := Key_Keys.Floor (Container.Tree, Key); 888 889 begin 890 if Node = null then 891 return No_Element; 892 end if; 893 894 return Cursor'(Container'Unrestricted_Access, Node); 895 end Floor; 896 897 ------------------------- 898 -- Is_Greater_Key_Node -- 899 ------------------------- 900 901 function Is_Greater_Key_Node 902 (Left : Key_Type; 903 Right : Node_Access) return Boolean 904 is 905 begin 906 return Key (Right.Element.all) < Left; 907 end Is_Greater_Key_Node; 908 909 ---------------------- 910 -- Is_Less_Key_Node -- 911 ---------------------- 912 913 function Is_Less_Key_Node 914 (Left : Key_Type; 915 Right : Node_Access) return Boolean 916 is 917 begin 918 return Left < Key (Right.Element.all); 919 end Is_Less_Key_Node; 920 921 ------------- 922 -- Iterate -- 923 ------------- 924 925 procedure Iterate 926 (Container : Set; 927 Key : Key_Type; 928 Process : not null access procedure (Position : Cursor)) 929 is 930 procedure Process_Node (Node : Node_Access); 931 pragma Inline (Process_Node); 932 933 procedure Local_Iterate is 934 new Key_Keys.Generic_Iteration (Process_Node); 935 936 ------------------ 937 -- Process_Node -- 938 ------------------ 939 940 procedure Process_Node (Node : Node_Access) is 941 begin 942 Process (Cursor'(Container'Unrestricted_Access, Node)); 943 end Process_Node; 944 945 T : Tree_Type renames Container.Tree'Unrestricted_Access.all; 946 Busy : With_Busy (T.TC'Unrestricted_Access); 947 948 -- Start of processing for Iterate 949 950 begin 951 Local_Iterate (T, Key); 952 end Iterate; 953 954 --------- 955 -- Key -- 956 --------- 957 958 function Key (Position : Cursor) return Key_Type is 959 begin 960 if Position.Node = null then 961 raise Constraint_Error with 962 "Position cursor equals No_Element"; 963 end if; 964 965 if Position.Node.Element = null then 966 raise Program_Error with 967 "Position cursor is bad"; 968 end if; 969 970 pragma Assert (Vet (Position.Container.Tree, Position.Node), 971 "bad cursor in Key"); 972 973 return Key (Position.Node.Element.all); 974 end Key; 975 976 --------------------- 977 -- Reverse_Iterate -- 978 --------------------- 979 980 procedure Reverse_Iterate 981 (Container : Set; 982 Key : Key_Type; 983 Process : not null access procedure (Position : Cursor)) 984 is 985 procedure Process_Node (Node : Node_Access); 986 pragma Inline (Process_Node); 987 988 ------------- 989 -- Iterate -- 990 ------------- 991 992 procedure Local_Reverse_Iterate is 993 new Key_Keys.Generic_Reverse_Iteration (Process_Node); 994 995 ------------------ 996 -- Process_Node -- 997 ------------------ 998 999 procedure Process_Node (Node : Node_Access) is 1000 begin 1001 Process (Cursor'(Container'Unrestricted_Access, Node)); 1002 end Process_Node; 1003 1004 T : Tree_Type renames Container.Tree'Unrestricted_Access.all; 1005 Busy : With_Busy (T.TC'Unrestricted_Access); 1006 1007 -- Start of processing for Reverse_Iterate 1008 1009 begin 1010 Local_Reverse_Iterate (T, Key); 1011 end Reverse_Iterate; 1012 1013 -------------------- 1014 -- Update_Element -- 1015 -------------------- 1016 1017 procedure Update_Element 1018 (Container : in out Set; 1019 Position : Cursor; 1020 Process : not null access procedure (Element : in out Element_Type)) 1021 is 1022 Tree : Tree_Type renames Container.Tree; 1023 Node : constant Node_Access := Position.Node; 1024 1025 begin 1026 if Node = null then 1027 raise Constraint_Error with "Position cursor equals No_Element"; 1028 end if; 1029 1030 if Node.Element = null then 1031 raise Program_Error with "Position cursor is bad"; 1032 end if; 1033 1034 if Position.Container /= Container'Unrestricted_Access then 1035 raise Program_Error with "Position cursor designates wrong set"; 1036 end if; 1037 1038 pragma Assert (Vet (Tree, Node), 1039 "bad cursor in Update_Element"); 1040 1041 declare 1042 E : Element_Type renames Node.Element.all; 1043 K : constant Key_Type := Key (E); 1044 Lock : With_Lock (Tree.TC'Unrestricted_Access); 1045 begin 1046 Process (E); 1047 1048 if Equivalent_Keys (Left => K, Right => Key (E)) then 1049 return; 1050 end if; 1051 end; 1052 1053 -- Delete_Node checks busy-bit 1054 1055 Tree_Operations.Delete_Node_Sans_Free (Tree, Node); 1056 1057 Insert_New_Item : declare 1058 function New_Node return Node_Access; 1059 pragma Inline (New_Node); 1060 1061 procedure Insert_Post is 1062 new Element_Keys.Generic_Insert_Post (New_Node); 1063 1064 procedure Unconditional_Insert is 1065 new Element_Keys.Generic_Unconditional_Insert (Insert_Post); 1066 1067 -------------- 1068 -- New_Node -- 1069 -------------- 1070 1071 function New_Node return Node_Access is 1072 begin 1073 Node.Color := Red_Black_Trees.Red; 1074 Node.Parent := null; 1075 Node.Left := null; 1076 Node.Right := null; 1077 1078 return Node; 1079 end New_Node; 1080 1081 Result : Node_Access; 1082 1083 -- Start of processing for Insert_New_Item 1084 1085 begin 1086 Unconditional_Insert 1087 (Tree => Tree, 1088 Key => Node.Element.all, 1089 Node => Result); 1090 1091 pragma Assert (Result = Node); 1092 end Insert_New_Item; 1093 end Update_Element; 1094 1095 end Generic_Keys; 1096 1097 ----------------- 1098 -- Has_Element -- 1099 ----------------- 1100 1101 function Has_Element (Position : Cursor) return Boolean is 1102 begin 1103 return Position /= No_Element; 1104 end Has_Element; 1105 1106 ------------ 1107 -- Insert -- 1108 ------------ 1109 1110 procedure Insert (Container : in out Set; New_Item : Element_Type) is 1111 Position : Cursor; 1112 pragma Unreferenced (Position); 1113 begin 1114 Insert (Container, New_Item, Position); 1115 end Insert; 1116 1117 procedure Insert 1118 (Container : in out Set; 1119 New_Item : Element_Type; 1120 Position : out Cursor) 1121 is 1122 begin 1123 Insert_Sans_Hint (Container.Tree, New_Item, Position.Node); 1124 Position.Container := Container'Unrestricted_Access; 1125 end Insert; 1126 1127 ---------------------- 1128 -- Insert_Sans_Hint -- 1129 ---------------------- 1130 1131 procedure Insert_Sans_Hint 1132 (Tree : in out Tree_Type; 1133 New_Item : Element_Type; 1134 Node : out Node_Access) 1135 is 1136 function New_Node return Node_Access; 1137 pragma Inline (New_Node); 1138 1139 procedure Insert_Post is 1140 new Element_Keys.Generic_Insert_Post (New_Node); 1141 1142 procedure Unconditional_Insert is 1143 new Element_Keys.Generic_Unconditional_Insert (Insert_Post); 1144 1145 -------------- 1146 -- New_Node -- 1147 -------------- 1148 1149 function New_Node return Node_Access is 1150 -- The element allocator may need an accessibility check in the case 1151 -- the actual type is class-wide or has access discriminants (see 1152 -- RM 4.8(10.1) and AI12-0035). 1153 1154 pragma Unsuppress (Accessibility_Check); 1155 1156 Element : Element_Access := new Element_Type'(New_Item); 1157 1158 begin 1159 return new Node_Type'(Parent => null, 1160 Left => null, 1161 Right => null, 1162 Color => Red_Black_Trees.Red, 1163 Element => Element); 1164 1165 exception 1166 when others => 1167 Free_Element (Element); 1168 raise; 1169 end New_Node; 1170 1171 -- Start of processing for Insert_Sans_Hint 1172 1173 begin 1174 Unconditional_Insert (Tree, New_Item, Node); 1175 end Insert_Sans_Hint; 1176 1177 ---------------------- 1178 -- Insert_With_Hint -- 1179 ---------------------- 1180 1181 procedure Insert_With_Hint 1182 (Dst_Tree : in out Tree_Type; 1183 Dst_Hint : Node_Access; 1184 Src_Node : Node_Access; 1185 Dst_Node : out Node_Access) 1186 is 1187 function New_Node return Node_Access; 1188 pragma Inline (New_Node); 1189 1190 procedure Insert_Post is 1191 new Element_Keys.Generic_Insert_Post (New_Node); 1192 1193 procedure Insert_Sans_Hint is 1194 new Element_Keys.Generic_Unconditional_Insert (Insert_Post); 1195 1196 procedure Local_Insert_With_Hint is 1197 new Element_Keys.Generic_Unconditional_Insert_With_Hint 1198 (Insert_Post, 1199 Insert_Sans_Hint); 1200 1201 -------------- 1202 -- New_Node -- 1203 -------------- 1204 1205 function New_Node return Node_Access is 1206 X : Element_Access := new Element_Type'(Src_Node.Element.all); 1207 1208 begin 1209 return new Node_Type'(Parent => null, 1210 Left => null, 1211 Right => null, 1212 Color => Red, 1213 Element => X); 1214 1215 exception 1216 when others => 1217 Free_Element (X); 1218 raise; 1219 end New_Node; 1220 1221 -- Start of processing for Insert_With_Hint 1222 1223 begin 1224 Local_Insert_With_Hint 1225 (Dst_Tree, 1226 Dst_Hint, 1227 Src_Node.Element.all, 1228 Dst_Node); 1229 end Insert_With_Hint; 1230 1231 ------------------ 1232 -- Intersection -- 1233 ------------------ 1234 1235 procedure Intersection (Target : in out Set; Source : Set) is 1236 begin 1237 Set_Ops.Intersection (Target.Tree, Source.Tree); 1238 end Intersection; 1239 1240 function Intersection (Left, Right : Set) return Set is 1241 Tree : constant Tree_Type := 1242 Set_Ops.Intersection (Left.Tree, Right.Tree); 1243 begin 1244 return Set'(Controlled with Tree); 1245 end Intersection; 1246 1247 -------------- 1248 -- Is_Empty -- 1249 -------------- 1250 1251 function Is_Empty (Container : Set) return Boolean is 1252 begin 1253 return Container.Tree.Length = 0; 1254 end Is_Empty; 1255 1256 ------------------------ 1257 -- Is_Equal_Node_Node -- 1258 ------------------------ 1259 1260 function Is_Equal_Node_Node (L, R : Node_Access) return Boolean is 1261 begin 1262 return L.Element.all = R.Element.all; 1263 end Is_Equal_Node_Node; 1264 1265 ----------------------------- 1266 -- Is_Greater_Element_Node -- 1267 ----------------------------- 1268 1269 function Is_Greater_Element_Node 1270 (Left : Element_Type; 1271 Right : Node_Access) return Boolean 1272 is 1273 begin 1274 -- e > node same as node < e 1275 1276 return Right.Element.all < Left; 1277 end Is_Greater_Element_Node; 1278 1279 -------------------------- 1280 -- Is_Less_Element_Node -- 1281 -------------------------- 1282 1283 function Is_Less_Element_Node 1284 (Left : Element_Type; 1285 Right : Node_Access) return Boolean 1286 is 1287 begin 1288 return Left < Right.Element.all; 1289 end Is_Less_Element_Node; 1290 1291 ----------------------- 1292 -- Is_Less_Node_Node -- 1293 ----------------------- 1294 1295 function Is_Less_Node_Node (L, R : Node_Access) return Boolean is 1296 begin 1297 return L.Element.all < R.Element.all; 1298 end Is_Less_Node_Node; 1299 1300 --------------- 1301 -- Is_Subset -- 1302 --------------- 1303 1304 function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is 1305 begin 1306 return Set_Ops.Is_Subset (Subset => Subset.Tree, Of_Set => Of_Set.Tree); 1307 end Is_Subset; 1308 1309 ------------- 1310 -- Iterate -- 1311 ------------- 1312 1313 procedure Iterate 1314 (Container : Set; 1315 Item : Element_Type; 1316 Process : not null access procedure (Position : Cursor)) 1317 is 1318 procedure Process_Node (Node : Node_Access); 1319 pragma Inline (Process_Node); 1320 1321 procedure Local_Iterate is 1322 new Element_Keys.Generic_Iteration (Process_Node); 1323 1324 ------------------ 1325 -- Process_Node -- 1326 ------------------ 1327 1328 procedure Process_Node (Node : Node_Access) is 1329 begin 1330 Process (Cursor'(Container'Unrestricted_Access, Node)); 1331 end Process_Node; 1332 1333 T : Tree_Type renames Container.Tree'Unrestricted_Access.all; 1334 Busy : With_Busy (T.TC'Unrestricted_Access); 1335 1336 -- Start of processing for Iterate 1337 1338 begin 1339 Local_Iterate (T, Item); 1340 end Iterate; 1341 1342 procedure Iterate 1343 (Container : Set; 1344 Process : not null access procedure (Position : Cursor)) 1345 is 1346 procedure Process_Node (Node : Node_Access); 1347 pragma Inline (Process_Node); 1348 1349 procedure Local_Iterate is 1350 new Tree_Operations.Generic_Iteration (Process_Node); 1351 1352 ------------------ 1353 -- Process_Node -- 1354 ------------------ 1355 1356 procedure Process_Node (Node : Node_Access) is 1357 begin 1358 Process (Cursor'(Container'Unrestricted_Access, Node)); 1359 end Process_Node; 1360 1361 T : Tree_Type renames Container.Tree'Unrestricted_Access.all; 1362 Busy : With_Busy (T.TC'Unrestricted_Access); 1363 1364 -- Start of processing for Iterate 1365 1366 begin 1367 Local_Iterate (T); 1368 end Iterate; 1369 1370 function Iterate (Container : Set) 1371 return Set_Iterator_Interfaces.Reversible_Iterator'Class 1372 is 1373 S : constant Set_Access := Container'Unrestricted_Access; 1374 begin 1375 -- The value of the Node component influences the behavior of the First 1376 -- and Last selector functions of the iterator object. When the Node 1377 -- component is null (as is the case here), this means the iterator 1378 -- object was constructed without a start expression. This is a complete 1379 -- iterator, meaning that the iteration starts from the (logical) 1380 -- beginning of the sequence of items. 1381 1382 -- Note: For a forward iterator, Container.First is the beginning, and 1383 -- for a reverse iterator, Container.Last is the beginning. 1384 1385 return It : constant Iterator := (Limited_Controlled with S, null) do 1386 Busy (S.Tree.TC); 1387 end return; 1388 end Iterate; 1389 1390 function Iterate (Container : Set; Start : Cursor) 1391 return Set_Iterator_Interfaces.Reversible_Iterator'Class 1392 is 1393 S : constant Set_Access := Container'Unrestricted_Access; 1394 begin 1395 -- It was formerly the case that when Start = No_Element, the partial 1396 -- iterator was defined to behave the same as for a complete iterator, 1397 -- and iterate over the entire sequence of items. However, those 1398 -- semantics were unintuitive and arguably error-prone (it is too easy 1399 -- to accidentally create an endless loop), and so they were changed, 1400 -- per the ARG meeting in Denver on 2011/11. However, there was no 1401 -- consensus about what positive meaning this corner case should have, 1402 -- and so it was decided to simply raise an exception. This does imply, 1403 -- however, that it is not possible to use a partial iterator to specify 1404 -- an empty sequence of items. 1405 1406 if Start = No_Element then 1407 raise Constraint_Error with 1408 "Start position for iterator equals No_Element"; 1409 end if; 1410 1411 if Start.Container /= Container'Unrestricted_Access then 1412 raise Program_Error with 1413 "Start cursor of Iterate designates wrong set"; 1414 end if; 1415 1416 pragma Assert (Vet (Container.Tree, Start.Node), 1417 "Start cursor of Iterate is bad"); 1418 1419 -- The value of the Node component influences the behavior of the First 1420 -- and Last selector functions of the iterator object. When the Node 1421 -- component is non-null (as is the case here), it means that this is a 1422 -- partial iteration, over a subset of the complete sequence of 1423 -- items. The iterator object was constructed with a start expression, 1424 -- indicating the position from which the iteration begins. Note that 1425 -- the start position has the same value irrespective of whether this is 1426 -- a forward or reverse iteration. 1427 1428 return It : constant Iterator := 1429 (Limited_Controlled with S, Start.Node) 1430 do 1431 Busy (S.Tree.TC); 1432 end return; 1433 end Iterate; 1434 1435 ---------- 1436 -- Last -- 1437 ---------- 1438 1439 function Last (Container : Set) return Cursor is 1440 begin 1441 if Container.Tree.Last = null then 1442 return No_Element; 1443 end if; 1444 1445 return Cursor'(Container'Unrestricted_Access, Container.Tree.Last); 1446 end Last; 1447 1448 function Last (Object : Iterator) return Cursor is 1449 begin 1450 -- The value of the iterator object's Node component influences the 1451 -- behavior of the Last (and First) selector function. 1452 1453 -- When the Node component is null, this means the iterator object was 1454 -- constructed without a start expression, in which case the (reverse) 1455 -- iteration starts from the (logical) beginning of the entire sequence 1456 -- (corresponding to Container.Last, for a reverse iterator). 1457 1458 -- Otherwise, this is iteration over a partial sequence of items. When 1459 -- the Node component is non-null, the iterator object was constructed 1460 -- with a start expression, that specifies the position from which the 1461 -- (reverse) partial iteration begins. 1462 1463 if Object.Node = null then 1464 return Object.Container.Last; 1465 else 1466 return Cursor'(Object.Container, Object.Node); 1467 end if; 1468 end Last; 1469 1470 ------------------ 1471 -- Last_Element -- 1472 ------------------ 1473 1474 function Last_Element (Container : Set) return Element_Type is 1475 begin 1476 if Container.Tree.Last = null then 1477 raise Constraint_Error with "set is empty"; 1478 end if; 1479 1480 pragma Assert (Container.Tree.Last.Element /= null); 1481 return Container.Tree.Last.Element.all; 1482 end Last_Element; 1483 1484 ---------- 1485 -- Left -- 1486 ---------- 1487 1488 function Left (Node : Node_Access) return Node_Access is 1489 begin 1490 return Node.Left; 1491 end Left; 1492 1493 ------------ 1494 -- Length -- 1495 ------------ 1496 1497 function Length (Container : Set) return Count_Type is 1498 begin 1499 return Container.Tree.Length; 1500 end Length; 1501 1502 ---------- 1503 -- Move -- 1504 ---------- 1505 1506 procedure Move is 1507 new Tree_Operations.Generic_Move (Clear); 1508 1509 procedure Move (Target : in out Set; Source : in out Set) is 1510 begin 1511 Move (Target => Target.Tree, Source => Source.Tree); 1512 end Move; 1513 1514 ---------- 1515 -- Next -- 1516 ---------- 1517 1518 function Next (Position : Cursor) return Cursor is 1519 begin 1520 if Position = No_Element then 1521 return No_Element; 1522 end if; 1523 1524 pragma Assert (Vet (Position.Container.Tree, Position.Node), 1525 "bad cursor in Next"); 1526 1527 declare 1528 Node : constant Node_Access := 1529 Tree_Operations.Next (Position.Node); 1530 1531 begin 1532 if Node = null then 1533 return No_Element; 1534 end if; 1535 1536 return Cursor'(Position.Container, Node); 1537 end; 1538 end Next; 1539 1540 procedure Next (Position : in out Cursor) is 1541 begin 1542 Position := Next (Position); 1543 end Next; 1544 1545 function Next (Object : Iterator; Position : Cursor) return Cursor is 1546 begin 1547 if Position.Container = null then 1548 return No_Element; 1549 end if; 1550 1551 if Position.Container /= Object.Container then 1552 raise Program_Error with 1553 "Position cursor of Next designates wrong set"; 1554 end if; 1555 1556 return Next (Position); 1557 end Next; 1558 1559 ------------- 1560 -- Overlap -- 1561 ------------- 1562 1563 function Overlap (Left, Right : Set) return Boolean is 1564 begin 1565 return Set_Ops.Overlap (Left.Tree, Right.Tree); 1566 end Overlap; 1567 1568 ------------ 1569 -- Parent -- 1570 ------------ 1571 1572 function Parent (Node : Node_Access) return Node_Access is 1573 begin 1574 return Node.Parent; 1575 end Parent; 1576 1577 -------------- 1578 -- Previous -- 1579 -------------- 1580 1581 function Previous (Position : Cursor) return Cursor is 1582 begin 1583 if Position = No_Element then 1584 return No_Element; 1585 end if; 1586 1587 pragma Assert (Vet (Position.Container.Tree, Position.Node), 1588 "bad cursor in Previous"); 1589 1590 declare 1591 Node : constant Node_Access := 1592 Tree_Operations.Previous (Position.Node); 1593 1594 begin 1595 if Node = null then 1596 return No_Element; 1597 end if; 1598 1599 return Cursor'(Position.Container, Node); 1600 end; 1601 end Previous; 1602 1603 procedure Previous (Position : in out Cursor) is 1604 begin 1605 Position := Previous (Position); 1606 end Previous; 1607 1608 function Previous (Object : Iterator; Position : Cursor) return Cursor is 1609 begin 1610 if Position.Container = null then 1611 return No_Element; 1612 end if; 1613 1614 if Position.Container /= Object.Container then 1615 raise Program_Error with 1616 "Position cursor of Previous designates wrong set"; 1617 end if; 1618 1619 return Previous (Position); 1620 end Previous; 1621 1622 ------------------- 1623 -- Query_Element -- 1624 ------------------- 1625 1626 procedure Query_Element 1627 (Position : Cursor; 1628 Process : not null access procedure (Element : Element_Type)) 1629 is 1630 begin 1631 if Position.Node = null then 1632 raise Constraint_Error with "Position cursor equals No_Element"; 1633 end if; 1634 1635 if Position.Node.Element = null then 1636 raise Program_Error with "Position cursor is bad"; 1637 end if; 1638 1639 pragma Assert (Vet (Position.Container.Tree, Position.Node), 1640 "bad cursor in Query_Element"); 1641 1642 declare 1643 T : Tree_Type renames Position.Container.Tree; 1644 Lock : With_Lock (T.TC'Unrestricted_Access); 1645 begin 1646 Process (Position.Node.Element.all); 1647 end; 1648 end Query_Element; 1649 1650 ---------- 1651 -- Read -- 1652 ---------- 1653 1654 procedure Read 1655 (Stream : not null access Root_Stream_Type'Class; 1656 Container : out Set) 1657 is 1658 function Read_Node 1659 (Stream : not null access Root_Stream_Type'Class) return Node_Access; 1660 pragma Inline (Read_Node); 1661 1662 procedure Read is 1663 new Tree_Operations.Generic_Read (Clear, Read_Node); 1664 1665 --------------- 1666 -- Read_Node -- 1667 --------------- 1668 1669 function Read_Node 1670 (Stream : not null access Root_Stream_Type'Class) return Node_Access 1671 is 1672 Node : Node_Access := new Node_Type; 1673 begin 1674 Node.Element := new Element_Type'(Element_Type'Input (Stream)); 1675 return Node; 1676 exception 1677 when others => 1678 Free (Node); -- Note that Free deallocates elem too 1679 raise; 1680 end Read_Node; 1681 1682 -- Start of processing for Read 1683 1684 begin 1685 Read (Stream, Container.Tree); 1686 end Read; 1687 1688 procedure Read 1689 (Stream : not null access Root_Stream_Type'Class; 1690 Item : out Cursor) 1691 is 1692 begin 1693 raise Program_Error with "attempt to stream set cursor"; 1694 end Read; 1695 1696 procedure Read 1697 (Stream : not null access Root_Stream_Type'Class; 1698 Item : out Constant_Reference_Type) 1699 is 1700 begin 1701 raise Program_Error with "attempt to stream reference"; 1702 end Read; 1703 1704 --------------------- 1705 -- Replace_Element -- 1706 --------------------- 1707 1708 procedure Replace_Element 1709 (Tree : in out Tree_Type; 1710 Node : Node_Access; 1711 Item : Element_Type) 1712 is 1713 begin 1714 if Item < Node.Element.all 1715 or else Node.Element.all < Item 1716 then 1717 null; 1718 else 1719 TE_Check (Tree.TC); 1720 1721 declare 1722 X : Element_Access := Node.Element; 1723 1724 -- The element allocator may need an accessibility check in the 1725 -- case the actual type is class-wide or has access discriminants 1726 -- (see RM 4.8(10.1) and AI12-0035). 1727 1728 pragma Unsuppress (Accessibility_Check); 1729 1730 begin 1731 Node.Element := new Element_Type'(Item); 1732 Free_Element (X); 1733 end; 1734 1735 return; 1736 end if; 1737 1738 Tree_Operations.Delete_Node_Sans_Free (Tree, Node); -- Checks busy-bit 1739 1740 Insert_New_Item : declare 1741 function New_Node return Node_Access; 1742 pragma Inline (New_Node); 1743 1744 procedure Insert_Post is 1745 new Element_Keys.Generic_Insert_Post (New_Node); 1746 1747 procedure Unconditional_Insert is 1748 new Element_Keys.Generic_Unconditional_Insert (Insert_Post); 1749 1750 -------------- 1751 -- New_Node -- 1752 -------------- 1753 1754 function New_Node return Node_Access is 1755 1756 -- The element allocator may need an accessibility check in the 1757 -- case the actual type is class-wide or has access discriminants 1758 -- (see RM 4.8(10.1) and AI12-0035). 1759 1760 pragma Unsuppress (Accessibility_Check); 1761 1762 begin 1763 Node.Element := new Element_Type'(Item); -- OK if fails 1764 Node.Color := Red_Black_Trees.Red; 1765 Node.Parent := null; 1766 Node.Left := null; 1767 Node.Right := null; 1768 1769 return Node; 1770 end New_Node; 1771 1772 Result : Node_Access; 1773 1774 X : Element_Access := Node.Element; 1775 1776 -- Start of processing for Insert_New_Item 1777 1778 begin 1779 Unconditional_Insert 1780 (Tree => Tree, 1781 Key => Item, 1782 Node => Result); 1783 pragma Assert (Result = Node); 1784 1785 Free_Element (X); -- OK if fails 1786 end Insert_New_Item; 1787 end Replace_Element; 1788 1789 procedure Replace_Element 1790 (Container : in out Set; 1791 Position : Cursor; 1792 New_Item : Element_Type) 1793 is 1794 begin 1795 if Position.Node = null then 1796 raise Constraint_Error with "Position cursor equals No_Element"; 1797 end if; 1798 1799 if Position.Node.Element = null then 1800 raise Program_Error with "Position cursor is bad"; 1801 end if; 1802 1803 if Position.Container /= Container'Unrestricted_Access then 1804 raise Program_Error with "Position cursor designates wrong set"; 1805 end if; 1806 1807 pragma Assert (Vet (Container.Tree, Position.Node), 1808 "bad cursor in Replace_Element"); 1809 1810 Replace_Element (Container.Tree, Position.Node, New_Item); 1811 end Replace_Element; 1812 1813 --------------------- 1814 -- Reverse_Iterate -- 1815 --------------------- 1816 1817 procedure Reverse_Iterate 1818 (Container : Set; 1819 Item : Element_Type; 1820 Process : not null access procedure (Position : Cursor)) 1821 is 1822 procedure Process_Node (Node : Node_Access); 1823 pragma Inline (Process_Node); 1824 1825 procedure Local_Reverse_Iterate is 1826 new Element_Keys.Generic_Reverse_Iteration (Process_Node); 1827 1828 ------------------ 1829 -- Process_Node -- 1830 ------------------ 1831 1832 procedure Process_Node (Node : Node_Access) is 1833 begin 1834 Process (Cursor'(Container'Unrestricted_Access, Node)); 1835 end Process_Node; 1836 1837 T : Tree_Type renames Container.Tree'Unrestricted_Access.all; 1838 Busy : With_Busy (T.TC'Unrestricted_Access); 1839 1840 -- Start of processing for Reverse_Iterate 1841 1842 begin 1843 Local_Reverse_Iterate (T, Item); 1844 end Reverse_Iterate; 1845 1846 procedure Reverse_Iterate 1847 (Container : Set; 1848 Process : not null access procedure (Position : Cursor)) 1849 is 1850 procedure Process_Node (Node : Node_Access); 1851 pragma Inline (Process_Node); 1852 1853 procedure Local_Reverse_Iterate is 1854 new Tree_Operations.Generic_Reverse_Iteration (Process_Node); 1855 1856 ------------------ 1857 -- Process_Node -- 1858 ------------------ 1859 1860 procedure Process_Node (Node : Node_Access) is 1861 begin 1862 Process (Cursor'(Container'Unrestricted_Access, Node)); 1863 end Process_Node; 1864 1865 T : Tree_Type renames Container.Tree'Unrestricted_Access.all; 1866 Busy : With_Busy (T.TC'Unrestricted_Access); 1867 1868 -- Start of processing for Reverse_Iterate 1869 1870 begin 1871 Local_Reverse_Iterate (T); 1872 end Reverse_Iterate; 1873 1874 ----------- 1875 -- Right -- 1876 ----------- 1877 1878 function Right (Node : Node_Access) return Node_Access is 1879 begin 1880 return Node.Right; 1881 end Right; 1882 1883 --------------- 1884 -- Set_Color -- 1885 --------------- 1886 1887 procedure Set_Color (Node : Node_Access; Color : Color_Type) is 1888 begin 1889 Node.Color := Color; 1890 end Set_Color; 1891 1892 -------------- 1893 -- Set_Left -- 1894 -------------- 1895 1896 procedure Set_Left (Node : Node_Access; Left : Node_Access) is 1897 begin 1898 Node.Left := Left; 1899 end Set_Left; 1900 1901 ---------------- 1902 -- Set_Parent -- 1903 ---------------- 1904 1905 procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is 1906 begin 1907 Node.Parent := Parent; 1908 end Set_Parent; 1909 1910 --------------- 1911 -- Set_Right -- 1912 --------------- 1913 1914 procedure Set_Right (Node : Node_Access; Right : Node_Access) is 1915 begin 1916 Node.Right := Right; 1917 end Set_Right; 1918 1919 -------------------------- 1920 -- Symmetric_Difference -- 1921 -------------------------- 1922 1923 procedure Symmetric_Difference (Target : in out Set; Source : Set) is 1924 begin 1925 Set_Ops.Symmetric_Difference (Target.Tree, Source.Tree); 1926 end Symmetric_Difference; 1927 1928 function Symmetric_Difference (Left, Right : Set) return Set is 1929 Tree : constant Tree_Type := 1930 Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree); 1931 begin 1932 return Set'(Controlled with Tree); 1933 end Symmetric_Difference; 1934 1935 ------------ 1936 -- To_Set -- 1937 ------------ 1938 1939 function To_Set (New_Item : Element_Type) return Set is 1940 Tree : Tree_Type; 1941 Node : Node_Access; 1942 pragma Unreferenced (Node); 1943 begin 1944 Insert_Sans_Hint (Tree, New_Item, Node); 1945 return Set'(Controlled with Tree); 1946 end To_Set; 1947 1948 ----------- 1949 -- Union -- 1950 ----------- 1951 1952 procedure Union (Target : in out Set; Source : Set) is 1953 begin 1954 Set_Ops.Union (Target.Tree, Source.Tree); 1955 end Union; 1956 1957 function Union (Left, Right : Set) return Set is 1958 Tree : constant Tree_Type := 1959 Set_Ops.Union (Left.Tree, Right.Tree); 1960 begin 1961 return Set'(Controlled with Tree); 1962 end Union; 1963 1964 ----------- 1965 -- Write -- 1966 ----------- 1967 1968 procedure Write 1969 (Stream : not null access Root_Stream_Type'Class; 1970 Container : Set) 1971 is 1972 procedure Write_Node 1973 (Stream : not null access Root_Stream_Type'Class; 1974 Node : Node_Access); 1975 pragma Inline (Write_Node); 1976 1977 procedure Write is 1978 new Tree_Operations.Generic_Write (Write_Node); 1979 1980 ---------------- 1981 -- Write_Node -- 1982 ---------------- 1983 1984 procedure Write_Node 1985 (Stream : not null access Root_Stream_Type'Class; 1986 Node : Node_Access) 1987 is 1988 begin 1989 Element_Type'Output (Stream, Node.Element.all); 1990 end Write_Node; 1991 1992 -- Start of processing for Write 1993 1994 begin 1995 Write (Stream, Container.Tree); 1996 end Write; 1997 1998 procedure Write 1999 (Stream : not null access Root_Stream_Type'Class; 2000 Item : Cursor) 2001 is 2002 begin 2003 raise Program_Error with "attempt to stream set cursor"; 2004 end Write; 2005 2006 procedure Write 2007 (Stream : not null access Root_Stream_Type'Class; 2008 Item : Constant_Reference_Type) 2009 is 2010 begin 2011 raise Program_Error with "attempt to stream reference"; 2012 end Write; 2013end Ada.Containers.Indefinite_Ordered_Multisets; 2014