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