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