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