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