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