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