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