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